[CONTACT]

[ABOUT]

[POLICY]

[ADVERTISE]

C ALGORITHM COLLECTED ALGORITHMS FROM

Found at: ftp.icm.edu.pl:70/packages/netlib/toms-2014-06-10/777

C      ALGORITHM 777, COLLECTED ALGORITHMS FROM ACM.
C      THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE,
C      VOL. 23,NO. 4,  December, 1997, P.  514--549.
#! /bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #! /bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
#	Doc
#	Drivers
#	Info
#	Src
# This archive created: Fri Jul 31 08:42:45 1998
export PATH; PATH=/bin:$PATH
if test ! -d 'Doc'
then
	mkdir 'Doc'
fi
cd 'Doc'
if test -f 'README.txt'
then
	echo shar: will not over-write existing file "'README.txt'"
else
cat << \SHAR_EOF > 'README.txt'
!
!      HOMPACK90 is a suite of FORTRAN 90 subroutines for solving nonlinear
! systems of equations by homotopy methods.  There are subroutines for
! fixed point, zero finding, and general homotopy curve tracking problems,
! utilizing both dense and sparse Jacobian matrices, and implementing
! three different algorithms: ODE-based, normal flow, and augmented
! Jacobian.  The (driver) subroutines called by the user are given in the 
! table below, and are well documented internally.  The user need not
! be concerned with any other subroutines in HOMPACK90.
!
!
!                  Problem type
! --------|--------|--------|--------|--------|--------|
!      x = f(x)    |    F(x) = 0     |rho(a,lambda,x)=0|
! --------|--------|--------|--------|--------|--------|
!  dense  | sparse | dense  | sparse | dense  | sparse |  Algorithm
! --------|--------|--------|--------|--------|--------|---------------------
!  FIXPDF | FIXPDS | FIXPDF | FIXPDS | FIXPDF | FIXPDS | ODE based
! --------|--------|--------|--------|--------|--------|---------------------
!  FIXPNF | FIXPNS | FIXPNF | FIXPNS | FIXPNF | FIXPNS | normal flow
! --------|--------|--------|--------|--------|--------|---------------------
!  FIXPQF | FIXPQS | FIXPQF | FIXPQS | FIXPQF | FIXPQS | augmented Jacobian
! --------|--------|--------|--------|--------|--------|---------------------
!
!
! The sparse subroutines use either the packed skyline storage scheme
! standard in structural mechanics or the compressed sparse row storage
! format, but any sparse storage scheme can be used by replacing some of
! the low-level HOMPACK90 routines with user-written routines.  The
! stepping subroutines STEP?? or the reverse call subroutines STEPNX and
! ROOTNX may be of interest to some users with special curve tracking
! needs.
!
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

		
! ORGANIZATIONAL DETAILS.  HOMPACK90 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 LAPACK and 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 HOMPACK90 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 HOMPACK90 routines is:
! 
! [FIXPDF] [FODE, ROOT, SINTRP, STEPS] [DGEQPF]
! 
! [FIXPDS] [FODEDS, ROOT, SINTRP, STEPDS] [GMFADS, GMRES, 
!      GMRILUDS, ILUFDS, ILUSOLVDS, MULTDS, MULT2DS, PCGDS, SOLVDS]
! 
! [FIXPNF] [ROOTNF, STEPNF, TANGNF] [DGEQPF, DORMQR, ROOT]
! 
! [FIXPNS] [ROOTNS, STEPNS, TANGNS] [GMFADS, GMRES, GMRILUDS,
!      ILUFDS, ILUSOLVDS,  MULTDS, MULT2DS, PCGDS, ROOT, SOLVDS]
! 
! [FIXPQF] [ROOTQF, STEPQF, TANGQF] [DGEQRF, DORGQR, UPQRQF]
! 
! [FIXPQS] [ROOTNS, STEPQS, TANGNS] [GMFADS, GMRES, GMRILUDS,
!      ILUFDS, ILUSOLVDS, MULTDS, MULT2DS, PCGDS, ROOT, SOLVDS]
! 
! [POLSYS1H] [FIXPNF, ROOTNF, STEPNF, TANGNF] 
!      [DGEQPF, DGEQRF, DORMQR, DIVP, FFUNP, GFUNP, HFUNP, HFUN1P, 
!       INITP, MULP, OTPUTP, POWP, RHO, RHOJAC, ROOT, SCLGNP, STRPTP]
! 
! The LAPACK and BLAS subroutines used by HOMPACK90 are
! DCOPY, DDOT, DGEMM, DGEMV, DGEQPF, DGEQR2, DGEQRF, DGER, DLAIC1,
! DLAMCH, DLAPY2, DLARF, DLARFB, DLARFG, DLARFT, DNRM2, DORG2R, DORGQR,
! DORM2R, DORMQR, DSCAL, DSWAP, DTPMV, DTPSV, DTRMM, DTRMV, DTRSV,
! IDAMAX, ILAENV, LSAME, XERBLA.
! 
! The user written subroutines, of which exactly two must be supplied
! depending on the driver chosen, are F, FJAC, FJACS, RHO, RHOA, RHOJAC,
! and RHOJS.  These external subroutines must conform to the interfaces
! contained in the module HOMOTOPY.  The module REAL_PRECISION contains
! machine dependent constants, which must be changed appropriately before
! compilation. The module HOMPACK90_GLOBAL contains global storage, and
! must be used by the user written subroutines.
!
! Testing and installation:  HOMPACK90 consists of 4 modules---HOMOTOPY
! (contains interfaces for the user written external subroutines),
! HOMPACK90 (encapsulates all the drivers), HOMPACK90_GLOBAL (global
! dynamic storage), REAL_PRECISION (defines precision of all reals)---and
! external subroutines, all contained in the files hompack90.f, 
! blas1.f, blas2.f, blas3.f and lapack.f.
! The file template.f contains templates for the user written
! subroutines.  There are three main programs driver[123].f for testing,
! with sample output given in the files RES[123].  driver1.f and
! driver3.f have no input files; driver2.f reads a data file DATA2 and
! writes the solution in a file RES2.OUT (for post-processing), since
! this is normally how the polynomial system driver POLSYS1H would be used.
! 
! To test the dense (1), sparse (3), polynomial system (2) algorithms
! respectively in HOMPACK90, compile and link in order the files
! hompack90.f lapack.f blas1.f blas2.f blas3.f driver1.f 
! (driver3.f, driver2.f respectively).
! The modules and external subroutines in hompack90.f, blas1.f, blas2.f,
! blas3.f and lapack.f (BLAS and LAPACK routines) can be kept in module
! and object libraries and need not be recompiled.
!
!
! Inquiries should be directed to Layne T. Watson, Departments of Computer
! Science and Mathematics, Virginia Polytechnic Institute & State
! University, Blacksburg, VA 24061-0106; (540) 231-7540; ltw@cs.vt.edu  .
! 
SHAR_EOF
fi # end of overwriting check
cd ..
if test ! -d 'Drivers'
then
	mkdir 'Drivers'
fi
cd 'Drivers'
if test -f 'template.f'
then
	echo shar: will not over-write existing file "'template.f'"
else
cat << \SHAR_EOF > 'template.f'
! Template for user written subroutines.
!
!  USE statements for the modules REAL_PRECISION and HOMPACK90_GLOBAL
!  should always be present in the user's subroutines.  The user
!  written subroutines must conform to the interfaces in the module
!  HOMOTOPY.
!
C
C All data and subroutines defining the problem should be coded here.
C
      SUBROUTINE F(X,V)
      USE REAL_PRECISION, ONLY : R8
      REAL (KIND=R8), DIMENSION(:), INTENT(IN):: X(:)
      REAL (KIND=R8), DIMENSION(:), INTENT(OUT):: V(:)
C
C Evaluate  F(X)  and return in the vector  V .
C
      RETURN
      END SUBROUTINE F

		
      SUBROUTINE FJAC(X,V,K)
      USE REAL_PRECISION, ONLY : R8
      REAL (KIND=R8), DIMENSION(:), INTENT(IN):: X(:)
      REAL (KIND=R8), DIMENSION(:), INTENT(OUT):: V(:)
      INTEGER, INTENT(IN):: K
C
C Return in  V  the Kth column of the Jacobian matrix of
C F(X) evaluated at  X .
C
      RETURN
      END SUBROUTINE FJAC

		
      SUBROUTINE RHO(A,LAMBDA,X,V)
      USE REAL_PRECISION, ONLY : R8
      USE HOMPACK90_GLOBAL, ONLY: IPAR, PAR  ! for POLSYS1H only.
      REAL (KIND=R8), INTENT(IN):: A(:),X(:)
      REAL (KIND=R8), INTENT(IN OUT):: LAMBDA
      REAL (KIND=R8), INTENT(OUT):: V(:)
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  POLSYS1H , and should be used verbatim with  POLSYS1H .  If the user is
C calling  FIXP??  or   STEP??  directly, he must supply appropriate
C replacement code here.
      INTERFACE
        SUBROUTINE HFUNP(N,A,LAMBDA,X)
        USE REAL_PRECISION
        INTEGER, INTENT(IN):: N
        REAL (KIND=R8), INTENT(IN):: A(2*N),LAMBDA,X(2*N)
        END SUBROUTINE HFUNP
      END INTERFACE
      INTEGER:: J,NPOL
C Force predicted point to have  LAMBDA .GE. 0  .
      IF (LAMBDA .LT. 0.0) LAMBDA=0.0
      NPOL=IPAR(1)
      CALL HFUNP(NPOL,A,LAMBDA,X)
      DO J=1,2*NPOL
        V(J)=PAR(IPAR(3 + (4-1)) + (J-1))
      END DO
C
      RETURN
      END SUBROUTINE RHO

		
      SUBROUTINE RHOA(A,LAMBDA,X)
      USE REAL_PRECISION, ONLY : R8
      REAL (KIND=R8), INTENT(OUT):: A(:)
      REAL (KIND=R8), INTENT(IN):: LAMBDA,X(:)
C
C Calculate and return in  A  the vector Z such that
C  RHO(Z,LAMBDA,X) = 0 .
C
      RETURN
      END SUBROUTINE RHOA

		
      SUBROUTINE RHOJAC(A,LAMBDA,X,V,K)
      USE REAL_PRECISION, ONLY : R8
      USE HOMPACK90_GLOBAL, ONLY: IPAR, PAR  ! for POLSYS1H only.
      REAL (KIND=R8), INTENT(IN):: A(:),X(:)
      REAL (KIND=R8), INTENT(IN OUT):: LAMBDA
      REAL (KIND=R8), INTENT(OUT):: V(:)
      INTEGER, INTENT(IN):: K
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  POLSYS1H , and should be used verbatim with  POLSYS1H .  If the user is
C calling  FIXP??  or   STEP??  directly, he must supply appropriate
C replacement code here.
      INTERFACE
        SUBROUTINE HFUNP(N,A,LAMBDA,X)
        USE REAL_PRECISION
        INTEGER, INTENT(IN):: N
        REAL (KIND=R8), INTENT(IN):: A(2*N),LAMBDA,X(2*N)
        END SUBROUTINE HFUNP
      END INTERFACE
      INTEGER:: J,NPOL,N2
      NPOL=IPAR(1)
      N2=2*NPOL
      IF (K .EQ. 1) THEN
C Force predicted point to have  LAMBDA .GE. 0  .
        IF (LAMBDA .LT. 0.0) LAMBDA=0.0
        CALL HFUNP(NPOL,A,LAMBDA,X)
        DO J=1,N2
          V(J)=PAR(IPAR(3 + (6-1)) + (J-1))
        END DO
        RETURN
      ELSE
        DO J=1,N2
          V(J)=PAR(IPAR(3 + (5-1)) + (J-1) + N2*(K-2))
        END DO
      ENDIF
C
      RETURN
      END SUBROUTINE RHOJAC

		
      SUBROUTINE FJACS(X)
      USE REAL_PRECISION, ONLY : R8
      USE HOMPACK90_GLOBAL
      REAL (KIND=R8), DIMENSION(:), INTENT(IN):: X
C
C If MODE = 1,
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 QRSPARSE.  LENQR is the
C length of QRSPARSE, and ROWPOS contains the indices of the diagonal
C elements of the Jacobian matrix within QRSPARSE.  ROWPOS(N+1) and
C ROWPOS(N+2) are set by subroutine FODEDS.  The allocatable array COLPOS
C is not used by this storage format.
C
C If MODE = 2,
C evaluate the N x N Jacobian matrix of F(X) at X, and return the result
C in sparse row storage format in QRSPARSE.  LENQR is the length of
C QRSPARSE, ROWPOS contains the indices of where each row begins within
C QRSPARSE, and COLPOS (of length LENQR) contains the column indices of
C the corresponding elements in QRSPARSE.  Even if zero, the diagonal
C elements of the Jacobian matrix must be stored in QRSPARSE.
C
      RETURN
      END SUBROUTINE FJACS

		
      SUBROUTINE RHOJS(A,LAMBDA,X)
      USE REAL_PRECISION, ONLY : R8
      USE HOMPACK90_GLOBAL
      REAL (KIND=R8), INTENT(IN):: A(:),LAMBDA,X(:)
C
C If MODE = 1,
C evaluate the N X N symmetric Jacobian matrix [D RHO/DX] at
C (A,X,LAMBDA), and return the result in packed skyline storage format in
C QRSPARSE.  LENQR is the length of QRSPARSE, and ROWPOS contains the
C indices of the diagonal elements of [D RHO/DX] within QRSPARSE.  PP
C contains -[D RHO/D LAMBDA] evaluated at (A,X,LAMBDA).  Note the minus
C sign in the definition of PP.  The allocatable array COLPOS is not used
C in this storage format.
C
C If MODE = 2,
C evaluate the N X (N+1) Jacobian matrix [D RHO/DX, D RHO/DLAMBDA] at
C (A,X,LAMBDA), and return the result in sparse row storage format in
C QRSPARSE.  LENQR is the length of QRSPARSE, ROWPOS contains the indices
C of where each row begins within QRSPARSE, and COLPOS (of length LENQR)
C contains the column indices of the corresponding elements in QRSPARSE.
C Even if zero, the diagonal elements of the Jacobian matrix must be
C stored in QRSPARSE.  The allocatable array PP is not used in this
C storage format.
C
      RETURN
      END SUBROUTINE RHOJS
SHAR_EOF
fi # end of overwriting check
if test -f 'driver3.f'
then
	echo shar: will not over-write existing file "'driver3.f'"
else
cat << \SHAR_EOF > 'driver3.f'
C  MAIN PROGRAM TO TEST FIXPQS, FIXPNS, AND FIXPDS;
C
C       THIS PROGRAM TESTS THE HOMPACK ROUTINES FIXPQS, FIXPNS, AND
C       FIXPDS.
C
C       THE OUTPUT FROM THIS ROUTINE SHOULD BE AS FOLLOWS, WITH THE
C       EXECUTION TIMES CORRESPONDING TO A DEC AXP 3000/600.
C
C       TESTING FIXPQS WITH STORAGE MODE = 1
C
C LAMBDA = 1.00000000  FLAG = 1      33 JACOBIAN EVALUATIONS
C EXECUTION TIME(SECS) =     0.119    ARC LENGTH =     1.274
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 WITH STORAGE MODE = 1
C
C LAMBDA = 1.00000000  FLAG = 1      20 JACOBIAN EVALUATIONS
C EXECUTION TIME(SECS) =     0.013    ARC LENGTH =     1.275
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 WITH STORAGE MODE = 1
C
C LAMBDA = 1.00000000  FLAG = 1      70 JACOBIAN EVALUATIONS
C EXECUTION TIME(SECS) =     0.031    ARC LENGTH =     1.281
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 FIXPQS WITH STORAGE MODE = 2
C
C LAMBDA = 1.00000000  FLAG = 1      33 JACOBIAN EVALUATIONS
C EXECUTION TIME(SECS) =     0.015    ARC LENGTH =     1.274
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 WITH STORAGE MODE = 2
C
C LAMBDA = 1.00000000  FLAG = 1      20 JACOBIAN EVALUATIONS
C EXECUTION TIME(SECS) =     0.011    ARC LENGTH =     1.275
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 WITH STORAGE MODE = 2
C
C LAMBDA = 1.00000000  FLAG = 1      70 JACOBIAN EVALUATIONS
C EXECUTION TIME(SECS) =     0.022    ARC LENGTH =     1.281
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
      MODULE SWITCH
C
C  ROWSET  IS USED TO INITIALIZE SPARSE MATRIX DATA STRUCTURES ONLY
C  ONCE, AFTER THEY ARE ALLOCATED.
C
      LOGICAL::  ROWSET
      END MODULE SWITCH
!
      PROGRAM TESTS
      USE SWITCH
      USE REAL_PRECISION, ONLY : R8
      USE HOMPACK90, ONLY : FIXPDS, FIXPNS, FIXPQS
      IMPLICIT NONE
      INTEGER, PARAMETER:: N=8, NDIMA=8
      REAL (KIND=R8):: A(N),ANSAE,ANSRE,ARCAE,ARCRE,
     &  ARCLEN,DTIME,SSPAR(8),Y(N+1)
      INTEGER:: IFLAG,II,J,LENQR,MODE,NFE,NP1,TIMENEW(8),
     &  TIMEOLD(8),TRACE
      CHARACTER (LEN=6):: NAME
! If using a subroutine library of the HOMPACK90 subroutines rather than
! the MODULE HOMPACK90 (as above), then the following INTERFACE
! statements are necessary.
!     INTERFACE
!       SUBROUTINE FIXPDS(N,Y,IFLAG,ARCTOL,EPS,TRACE,A,NDIMA,
!    &    NFE,ARCLEN,MODE,LENQR)
!       USE REAL_PRECISION
!       INTEGER, INTENT(IN)::LENQR,MODE,N,NDIMA,TRACE
!       REAL (KIND=R8), DIMENSION(:), INTENT(IN OUT)::A,Y
!       INTEGER, INTENT(IN OUT)::IFLAG
!       REAL (KIND=R8), INTENT(IN OUT)::ARCTOL,EPS
!       INTEGER, INTENT(OUT)::NFE
!       REAL (KIND=R8), INTENT(OUT)::ARCLEN
!       END SUBROUTINE FIXPDS
C
!       SUBROUTINE FIXPNS(N,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE,A,
!    &    NFE,ARCLEN,MODE,LENQR,SSPAR)
!       USE REAL_PRECISION
!       INTEGER, INTENT(IN)::LENQR,MODE,N,TRACE
!       REAL (KIND=R8), DIMENSION(:), INTENT(IN OUT)::A,Y
!       INTEGER, INTENT(IN OUT)::IFLAG
!       REAL (KIND=R8), INTENT(IN OUT)::ANSAE,ANSRE,ARCAE,ARCRE,
!    &    SSPAR(8)
!       INTEGER, INTENT(OUT)::NFE
!       REAL (KIND=R8), INTENT(OUT)::ARCLEN
!       END SUBROUTINE FIXPNS
C
!       SUBROUTINE FIXPQS(N,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE,A,
!    &    NFE,ARCLEN,MODE,LENQR,SSPAR)
!       USE REAL_PRECISION
!       INTEGER, INTENT(IN)::LENQR,MODE,N,TRACE
!       REAL (KIND=R8), DIMENSION(:), INTENT(IN OUT)::A,Y
!       INTEGER, INTENT(IN OUT)::IFLAG
!       REAL (KIND=R8), INTENT(IN OUT)::ANSAE,ANSRE,ARCAE,ARCRE,
!    &    SSPAR(4)
!       INTEGER, INTENT(OUT)::NFE
!       REAL (KIND=R8), INTENT(OUT)::ARCLEN
!       END SUBROUTINE FIXPQS
!     END INTERFACE
C
C TEST EACH OF THE THREE ALGORITHMS WITH BOTH STORAGE MODES.
      DO MODE=1,2
        SELECT CASE (MODE)
          CASE(1)
            LENQR=18
          CASE(2)
            LENQR=36
        END SELECT
      DO II=1,3
C
C DEFINE ARGUMENTS FOR CALL TO HOMPACK PROCEDURE.
C
         NP1=N+1
         ARCRE=0.5D-4
         ARCAE=0.5D-4
         ANSRE=1.0D-12
         ANSAE=1.0D-12
         TRACE=0
         SSPAR=0.0
         IFLAG=-MODE
         Y(1:N)=0.5_R8
         IF(IFLAG .EQ. -2) A=Y(1:N)
         ROWSET = .FALSE.
C
C GET CURRENT DATE AND TIME.
C
         CALL DATE_AND_TIME(VALUES=TIMEOLD)
C
C CALL TO HOMPACK ROUTINE.
C
        IF (II .EQ. 1) THEN
          NAME='FIXPQS'
          CALL FIXPQS(N,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE,A,
     &       NFE,ARCLEN,MODE,LENQR,SSPAR)
        ELSE IF (II .EQ. 2) THEN
          NAME='FIXPNS'
          CALL FIXPNS(N,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE,A,
     &       NFE,ARCLEN,MODE,LENQR,SSPAR)
        ELSE
          NAME='FIXPDS'
          CALL FIXPDS(N,Y,IFLAG,ARCRE,ANSRE,TRACE,A,NDIMA,NFE,
     &      ARCLEN,MODE,LENQR)
        END IF
C
C CALCULATE EXECUTION TIME.
C
        CALL DATE_AND_TIME(VALUES=TIMENEW)
        IF (TIMENEW(8) .LT. TIMEOLD(8)) THEN
          TIMENEW(8)=TIMENEW(8)+1000
          TIMENEW(7)=TIMENEW(7)-1
        ENDIF
        IF (TIMENEW(7) .LT. TIMEOLD(7)) THEN
          TIMENEW(7)=TIMENEW(7)+60
          TIMENEW(6)=TIMENEW(6)-1
        ENDIF
        IF (TIMENEW(6) .LT. TIMEOLD(6)) THEN
          TIMENEW(6)=TIMENEW(6)+60
          TIMENEW(5)=TIMENEW(5)-1
        ENDIF
        IF (TIMENEW(5) .LT. TIMEOLD(5)) TIMENEW(5)=TIMENEW(5)+24
        DTIME=DOT_PRODUCT(TIMENEW(5:8)-TIMEOLD(5:8),
     &    (/3600000,60000,1000,1/) )/1000.0
C
        WRITE (6,45) NAME, MODE
45      FORMAT (//,7X,'TESTING',1X,A6,' WITH STORAGE MODE =',I2)
        WRITE (6,50) Y(NP1),IFLAG,NFE,DTIME,ARCLEN,(Y(J),J=1,N)
50      FORMAT(/' LAMBDA =',F11.8,'  FLAG =',I2,I8,' JACOBIAN ',
     &    'EVALUATIONS',/,1X,'EXECUTION TIME(SECS) =',F10.3,4X,
     &    'ARC LENGTH =',F10.3/(1X,4ES16.8))
      END DO
      END DO
      STOP
      END PROGRAM TESTS
!
! SAMPLE USER WRITTEN HOMOTOPY SUBROUTINES FOR TESTING FIXP*S.
!
      SUBROUTINE F(X,V)
C***********************************************************************
C
C SUBROUTINE F(X,V) COMPUTES F AT THE POINT X, RETURNING THE VALUE IN V.
C
C***********************************************************************
      USE REAL_PRECISION, ONLY : R8
      IMPLICIT NONE
      REAL (KIND=R8), INTENT(IN):: X(:)
      REAL (KIND=R8), INTENT(OUT):: V(:)
       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 F
C
      SUBROUTINE FJACS(X)
C******************************************************************
C
C SUBROUTINE FJACS(X) COMPUTES THE JACOBIAN MATRIX OF F AT THE POINT
C X, RETURNING THE JACOBIAN MATRIX IN PACKED SKYLINE FORM (MODE=1)
C IN THE ARRAYS  QRSPARSE  AND  ROWPOS .
C
C*****************************************************************
      USE REAL_PRECISION, ONLY : R8
      USE HOMPACK90_GLOBAL, ONLY: QRSPARSE, ROWPOS, COLPOS
      USE SWITCH
      REAL (KIND=R8), INTENT(IN):: X(:)
C
C If MODE = 1,
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 QRSPARSE.  LENQR is the
C length of QRSPARSE, and ROWPOS contains the indices of the diagonal
C elements of the Jacobian matrix within QRSPARSE.  ROWPOS(N+1) and
C ROWPOS(N+2) are set by subroutine FODEDS.  The allocatable array COLPOS
C is not used by this storage format.
C
C If MODE = 2,
C evaluate the N x N Jacobian matrix of F(X) at X, and return the result
C in sparse row storage format in QRSPARSE.  LENQR is the length of
C QRSPARSE, ROWPOS contains the indices of where each row begins within
C QRSPARSE, and COLPOS (of length LENQR) contains the column indices of
C the corresponding elements in QRSPARSE.  Even if zero, the diagonal
C elements of the Jacobian matrix must be stored in QRSPARSE.
C
      INTEGER:: N
      N=SIZE(X)
      IF (.NOT. ROWSET) THEN
        ROWSET=.TRUE.
        ROWPOS(1:N+1) = (/ 1,2,4,7,8,12,13,14,19 /)
      END IF
      QRSPARSE(1)=3.0*X(1)**2+2.0
      QRSPARSE(2)=4.0*X(2)**3*X(5)+3.0
      QRSPARSE(3)=6.0*X(3)
      QRSPARSE(4)=X(5)+4.0
      QRSPARSE(5)=6.0*X(1)
      QRSPARSE(6)=6.0*X(2)
      QRSPARSE(7)=3.0*X(4)**2*X(8)+2.0
      QRSPARSE(8)=X(8)+3.0
      QRSPARSE(9)=0.0
      QRSPARSE(10)=X(3)
      QRSPARSE(11)=X(2)**4
      QRSPARSE(12)=X(8)+4.0
      QRSPARSE(13)=2.0*X(7)*X(8)**3+2.0
      QRSPARSE(14)=2.0*X(7)**3*X(8)+3.0
      QRSPARSE(15)=3.0*X(7)**2*X(8)**2
      QRSPARSE(16)=X(6)
      QRSPARSE(17)=X(5)
      QRSPARSE(18)=X(4)**3
      RETURN
      END SUBROUTINE FJACS
C
      SUBROUTINE RHO(A,LAMBDA,X,V)
      USE REAL_PRECISION, ONLY : R8
      REAL (KIND=R8), INTENT(IN):: A(:),X(:)
      REAL (KIND=R8), INTENT(IN OUT):: LAMBDA
      REAL (KIND=R8), INTENT(OUT):: V(:)
      INTERFACE
        SUBROUTINE F(X,V)
        USE REAL_PRECISION
        REAL (KIND=R8), DIMENSION(:), INTENT(IN):: X
        REAL (KIND=R8), DIMENSION(:), INTENT(OUT):: V
        END SUBROUTINE F
      END INTERFACE
C
C   EVALUATE  RHO(A,LAMBDA,X)  AND RETURN IN THE VECTOR  V .
C
      INTEGER:: N
      N=SIZE(X)
      CALL F(X(1:N), V(1:N))
      V(1:N) = LAMBDA*V(1:N) + (1.0 - LAMBDA)*(X(1:N) - A(1:N))
C
      RETURN
      END SUBROUTINE RHO
C
      SUBROUTINE RHOA(A,LAMBDA,X)
      USE REAL_PRECISION, ONLY : R8
      REAL (KIND=R8), INTENT(OUT):: A(:)
      REAL (KIND=R8), INTENT(IN):: LAMBDA,X(:)
      INTERFACE
        SUBROUTINE F(X,V)
        USE REAL_PRECISION
        REAL (KIND=R8), DIMENSION(:), INTENT(IN):: X
        REAL (KIND=R8), DIMENSION(:), INTENT(OUT):: V
        END SUBROUTINE F
      END INTERFACE
C
C   CALCULATE AND RETURN IN  A  THE VECTOR Z SUCH THAT
C   RHO(Z,LAMBDA,X) = 0 .
C   N=NDIMA FOR THIS TEST PROBLEM.
C
      INTEGER:: N
      N=SIZE(X)
      CALL F(X(1:N),A(1:N))
      A(1:N)=LAMBDA*A(1:N)/(1.0 - LAMBDA) + X(1:N)
      RETURN
      END SUBROUTINE RHOA
C
      SUBROUTINE RHOJS(A,LAMBDA,X)
C*****************************************************************
C
C Subroutine RHOJS(A,LAMBDA,X) computes the Jacobian matrix of
C rho(a,x,lambda) = lambda*F(x) + (1 - lambda)*(x - a) at the 
C point (A,X,LAMBDA), returning the Jacobian matrix in sparse row
C storage format (MODE = 2) in the arrays QRSPARSE, ROWPOS, and
C COLPOS.
C
C*****************************************************************
      USE REAL_PRECISION, ONLY : R8
      USE HOMPACK90_GLOBAL, ONLY: QRSPARSE, ROWPOS, COLPOS
      USE SWITCH
      REAL (KIND=R8), INTENT(IN):: A(:),LAMBDA,X(:)
      INTERFACE
        SUBROUTINE F(X,V)
        USE REAL_PRECISION
        REAL (KIND=R8), DIMENSION(:), INTENT(IN):: X
        REAL (KIND=R8), DIMENSION(:), INTENT(OUT):: V
        END SUBROUTINE F
      END INTERFACE
C
C If MODE = 1,
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 QRSPARSE.  LENQR is the
C length of QRSPARSE, and ROWPOS contains the indices of the diagonal
C elements of the Jacobian matrix within QRSPARSE.  ROWPOS(N+1) and
C ROWPOS(N+2) are set by subroutine FODEDS.  The allocatable array COLPOS
C is not used by this storage format.
C
C If MODE = 2,
C evaluate the N x N Jacobian matrix of F(X) at X, and return the result
C in sparse row storage format in QRSPARSE.  LENQR is the length of
C QRSPARSE, ROWPOS contains the indices of where each row begins within
C QRSPARSE, and COLPOS (of length LENQR) contains the column indices of
C the corresponding elements in QRSPARSE.  Even if zero, the diagonal
C elements of the Jacobian matrix must be stored in QRSPARSE.
C
C---------------------------------------------------------------------
C    [QRSPARSE] = [ LAMBDA*DF(X) + (1 - LAMBDA)*I | F(X) - X + A ] .  
C---------------------------------------------------------------------
C
C  LOCAL VARIABLES
C
      INTEGER, PARAMETER:: N=8
      INTEGER:: J, JPOS, ELEM(N) = (/4,9,14,18,24,27,30,36/)
      REAL (KIND=R8):: DRHODL(N)
C
      IF (.NOT. ROWSET) THEN  
        ROWSET=.TRUE.
        ROWPOS(1:N+1) = (/ 1,5,10,15,19,25,28,31,37 /)
        COLPOS(1:36) = (/1,2,3,9,1,2,3,5,9,1,2,3,5,9,4,5,8,9,
     &                   2,3,4,5,8,9,6,8,9,7,8,9,4,5,6,7,8,9/)                
      END IF
C
      QRSPARSE = 0.0
C   ROW 1.
      QRSPARSE(1)=3.0*X(1)**2+2.0
      QRSPARSE(2)=6.0*X(3)
      QRSPARSE(3)=6.0*X(2)
C   ROW 2.
      QRSPARSE(5)=6.0*X(3)
      QRSPARSE(6)=4.0*X(2)**3*X(5)+3.0
      QRSPARSE(7)=6.0*X(1)
      QRSPARSE(8)=X(2)**4
C   ROW 3.
      QRSPARSE(10)=6.0*X(2)
      QRSPARSE(11)=6.0*X(1)
      QRSPARSE(12)=X(5)+4.0
      QRSPARSE(13)=X(3)
C   ROW 4.
      QRSPARSE(15)=3.0*X(4)**2*X(8)+2.0
      QRSPARSE(16)=0.0
      QRSPARSE(17)=X(4)**3
C   ROW 5.
      QRSPARSE(19)=X(2)**4
      QRSPARSE(20)=X(3)
      QRSPARSE(21)=0.0
      QRSPARSE(22)=X(8)+3.0
      QRSPARSE(23)=X(5)
C   ROW 6.
      QRSPARSE(25)=X(8)+4.0
      QRSPARSE(26)=X(6)
      COLPOS(25)=6
      COLPOS(26)=8
      COLPOS(27)=9
C   ROW 7.
      QRSPARSE(28)=2.0*X(7)*X(8)**3+2.0
      QRSPARSE(29)=3.0*X(7)**2*X(8)**2
C   ROW 8.
      QRSPARSE(31)=X(4)**3
      QRSPARSE(32)=X(5)
      QRSPARSE(33)=X(6)
      QRSPARSE(34)=3.0*X(7)**2*X(8)**2
      QRSPARSE(35)=2.0*X(7)**3*X(8)+3.0
C
      QRSPARSE=LAMBDA*QRSPARSE
C
C   FIND INDEX JPOS OF DIAGONAL ELEMENT IN JTH ROW OF QR.
C
          DO J=1,N
            JPOS=ROWPOS(J)
            DO
              IF (COLPOS(JPOS) .EQ. J) EXIT
              JPOS=JPOS+1
            END DO
            QRSPARSE(JPOS) = QRSPARSE(JPOS) + 1.0 - LAMBDA
          END DO
C
C   INITIALIZE (N+1)ST COLUMN.
C
      CALL F(X(1:N),DRHODL(1:N))
      DRHODL = DRHODL - X(1:N) + A(1:N)
      QRSPARSE(ELEM) = DRHODL(1:8)
C
      RETURN
      END SUBROUTINE RHOJS
C **********************************************************************
C
C THE REST OF THESE SUBROUTINES ARE NOT USED BY PROGRAM TESTS, AND ARE
C INCLUDED HERE SIMPLY FOR COMPLETENESS AND AS TEMPLATES FOR THEIR USE.
C
      SUBROUTINE FJAC(X,V,K)
      USE REAL_PRECISION, ONLY : R8
      REAL (KIND=R8), INTENT(IN):: X(:)
      REAL (KIND=R8), INTENT(OUT):: V(:)
      INTEGER, INTENT(IN):: K
C
C RETURN IN  V  THE KTH COLUMN OF THE JACOBIAN MATRIX OF
C F(X) EVALUATED AT  X .
C
      V(1)=X(1) ! INTENT(OUT) VARIABLE MUST BE DEFINED.
      RETURN
      END SUBROUTINE FJAC
C
      SUBROUTINE RHOJAC(A,LAMBDA,X,V,K)
      USE REAL_PRECISION, ONLY : R8
      USE HOMPACK90_GLOBAL, ONLY: IPAR, PAR
      REAL (KIND=R8), INTENT(IN):: A(:),X(:)
      REAL (KIND=R8), INTENT(IN OUT):: LAMBDA
      REAL (KIND=R8), INTENT(OUT):: V(:)
      INTEGER, INTENT(IN):: K
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 POLSYS1H , AND SHOULD BE USED VERBATIM WITH  POLSYS1H .  IF THE USER IS
C CALLING  FIXP??  OR   STEP??  DIRECTLY, HE MUST SUPPLY APPROPRIATE
C REPLACEMENT CODE HERE.
      INTERFACE
        SUBROUTINE HFUNP(N,A,LAMBDA,X)
        USE REAL_PRECISION
        INTEGER, INTENT(IN):: N
        REAL (KIND=R8), INTENT(IN):: A(2*N),LAMBDA,X(2*N)
        END SUBROUTINE HFUNP
      END INTERFACE
      INTEGER:: J,NPOL,N2
      NPOL=IPAR(1)
      N2=2*NPOL
      IF (K .EQ. 1) THEN
C FORCE PREDICTED POINT TO HAVE  LAMBDA .GE. 0  .
        IF (LAMBDA .LT. 0.0) LAMBDA=0.0
!       CALL HFUNP(NPOL,A,LAMBDA,X)
        DO J=1,N2
          V(J)=PAR(IPAR(3 + (6-1)) + (J-1))
        END DO
        RETURN
      ELSE
        DO J=1,N2
          V(J)=PAR(IPAR(3 + (5-1)) + (J-1) + N2*(K-2))
        END DO
      ENDIF
C
      RETURN
      END SUBROUTINE RHOJAC
SHAR_EOF
fi # end of overwriting check
if test -f 'driver2.f'
then
	echo shar: will not over-write existing file "'driver2.f'"
else
cat << \SHAR_EOF > 'driver2.f'
C MAIN ROUTINE TO TEST POLSYS1H.
C
C THIS ROUTINE REQUIRES ONE INPUT FILE, DATA2 .
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 (READ FROM THE FILE 'DATA2'):
C ' TWO QUADRICS, NO SOLUTIONS AT INFINITY, TWO REAL SOLUTIONS.'
C &PROBLEM  
C       IFLGHM = 1
C       IFLGSC = 1
C       TOTDG  = 4
C       MAXT = 6
C       EPSBIG = 1.D-04
C       EPSSML = 1.D-14    
C       SSPAR(5) = 1.D+00    
C       NUMRR = 10
C       N = 2 /
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 (WRITTEN TO THE FILE 'OUTHP.DAT'):
C
!     POLSYS1H TEST ROUTINE 7/7/95
!
! TWO QUADRICS, NO SOLUTIONS AT INFINITY, TWO REAL SOLUTIONS.            
!
! IF IFLGHM=1, HOMOGENEOUS; IF IFLGHM=0, INHOMOGENEOUS; IFLGHM= 1
!
! IF IFLGSC=1, SCLGNP USED; IF IFLGSC=0, NO SCALING; IFLGSC=    1
!
! TOTDG=    4          MAXT=    6
!
! EPSBIG, EPSSML =  1.000000000000000E-04  1.000000000000000E-14
!
! SSPAR(5) =  1.000000000000000E+00
!
! NUMBER OF EQUATIONS =    2
!
! NUMBER OF RECALLS WHEN IFLAG=3:   10
!
!
!  ****** COEFFICIENT TABLEAU ******
!
!  NUMT( 1) =    6
!  KDEG( 1, 1, 1) =    2
!  KDEG( 1, 2, 1) =    0
!  COEF( 1, 1) =  -9.800000000000000E-04
!  KDEG( 1, 1, 2) =    0
!  KDEG( 1, 2, 2) =    2
!  COEF( 1, 2) =   9.780000000000000E+05
!  KDEG( 1, 1, 3) =    1
!  KDEG( 1, 2, 3) =    1
!  COEF( 1, 3) =  -9.800000000000001E+00
!  KDEG( 1, 1, 4) =    1
!  KDEG( 1, 2, 4) =    0
!  COEF( 1, 4) =  -2.350000000000000E+02
!  KDEG( 1, 1, 5) =    0
!  KDEG( 1, 2, 5) =    1
!  COEF( 1, 5) =   8.890000000000000E+04
!  KDEG( 1, 1, 6) =    0
!  KDEG( 1, 2, 6) =    0
!  COEF( 1, 6) =  -1.000000000000000E+00
!
!  NUMT( 2) =    6
!  KDEG( 2, 1, 1) =    2
!  KDEG( 2, 2, 1) =    0
!  COEF( 2, 1) =  -1.000000000000000E-02
!  KDEG( 2, 1, 2) =    0
!  KDEG( 2, 2, 2) =    2
!  COEF( 2, 2) =  -9.840000000000000E-01
!  KDEG( 2, 1, 3) =    1
!  KDEG( 2, 2, 3) =    1
!  COEF( 2, 3) =  -2.970000000000000E+01
!  KDEG( 2, 1, 4) =    1
!  KDEG( 2, 2, 4) =    0
!  COEF( 2, 4) =   9.870000000000000E-03
!  KDEG( 2, 1, 5) =    0
!  KDEG( 2, 2, 5) =    1
!  COEF( 2, 5) =  -1.240000000000000E-01
!  KDEG( 2, 1, 6) =    0
!  KDEG( 2, 2, 6) =    0
!  COEF( 2, 6) =  -2.500000000000000E-01
!
!
!
!  IFLG1 =   11
!
!  PATH NUMBER =    1
!
!  FINAL VALUES FOR PATH
!
!  ARCLEN =   1.005533190562901E+01
!  NFE =   53
!  IFLG2 =  1
! REAL, FINITE SOLUTION
!  LAMBDA =  1.000000000000003E+00
! X( 1) =  2.342338519591276E+03  8.841149143431121E-13
! X( 2) = -7.883448240941412E-01 -9.356862757018485E-16
!
! X( 3) = -9.493594594086552E-03 -1.064475509002627E-03
!
!
!  PATH NUMBER =    2
!
!  FINAL VALUES FOR PATH
!
!  ARCLEN =   1.721129286057142E+00
!  NFE =   37
!  IFLG2 =  1
! COMPLEX, FINITE SOLUTION
!  LAMBDA =  1.000000000000006E+00
! X( 1) =  1.614785792344189E-02  1.684969554988811E+00
! X( 2) =  2.679947396144760E-04  4.428029939736605E-03
!
! X( 3) = -3.819489729424030E-01  3.720689434572830E-01
!
!
!  PATH NUMBER =    3
!
!  FINAL VALUES FOR PATH
!
!  ARCLEN =   2.023295279367267E+00
!  NFE =   35
!  IFLG2 =  1
! COMPLEX, FINITE SOLUTION
!  LAMBDA =  1.000000000000000E+00
! X( 1) =  1.614785792343521E-02 -1.684969554988812E+00
! X( 2) =  2.679947396144598E-04 -4.428029939736611E-03
!
! X( 3) = -3.293704938476598E-01  5.566197755230126E-01
!
!
!  PATH NUMBER =    4
!
!  FINAL VALUES FOR PATH
!
!  ARCLEN =   4.163266156958467E+00
!  NFE =   46
!  IFLG2 =  1
! REAL, FINITE SOLUTION
!  LAMBDA =  9.999999999999998E-01
! X( 1) =  9.089212296153869E-02  1.153793567884107E-16
! X( 2) = -9.114970981974997E-02  1.887399041592030E-17
!
! X( 3) = -5.736733957279616E-02  1.362436637092185E-01
!
!
! 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 POLSYS1H INPUT.
C                        3. CALLS POLSYS1H.
C                        4. WRITES POLSYS1H 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
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
C THIS TEST CODE HAS DIMENSIONS SET AS FOLLOWS:
C
C NN=10, MMAXT=30, TTOTDG=1024
C
      PROGRAM TESTP
      USE REAL_PRECISION, ONLY : R8
      USE HOMPACK90, ONLY : POLSYS1H
      INTEGER, PARAMETER:: NN=10,MMAXT=30,TTOTDG=1024
      INTEGER:: IFLG1,IFLG2(TTOTDG),IFLGHM,IFLGSC,ITOTIT,J,K,
     &  KDEG(NN,NN+1,MMAXT),L,M,MAXT,N,NFE(TTOTDG),NP1,NT,
     &  NUMRR,NUMT(NN),TOTDG
      REAL (KIND=R8):: ARCLEN(TTOTDG),COEF(NN,MMAXT),EPSBIG,EPSSML,
     &  LAMBDA(TTOTDG),ROOTS(2,NN+1,TTOTDG),SSPAR(8)
      CHARACTER (LEN=72):: TITLE
! If using a subroutine library of the HOMPACK90 subroutines rather than
! the MODULE HOMPACK90 (as above), then the following INTERFACE
! statements are necessary.
!     INTERFACE
!       SUBROUTINE POLSYS1H(N,NUMT,COEF,KDEG,IFLG1,IFLG2,EPSBIG,EPSSML,
!    &     SSPAR,NUMRR,LAMBDA,ROOTS,ARCLEN,NFE)
!       USE HOMOTOPY
!       USE REAL_PRECISION
!       INTEGER, INTENT(IN):: N,NUMT(:),KDEG(:,:,:),NUMRR
!       REAL (KIND=R8), INTENT(IN):: COEF(:,:),EPSBIG,EPSSML
!       INTEGER, INTENT(IN OUT):: IFLG1,IFLG2(:)
!       REAL (KIND=R8), INTENT(IN OUT):: SSPAR(8)
!       REAL (KIND=R8), INTENT(OUT):: LAMBDA(:),ROOTS(:,:,:),ARCLEN(:)
!       INTEGER, INTENT(OUT):: NFE(:)
!       END SUBROUTINE POLSYS1H
!     END INTERFACE
C
      NAMELIST /PROBLEM/ IFLGHM,IFLGSC,TOTDG,MAXT,N,
     &  EPSBIG,EPSSML,SSPAR,NUMRR
C
      OPEN (UNIT=7,FILE='DATA2',ACTION='READ',POSITION='REWIND',
     &  DELIM='APOSTROPHE',STATUS='OLD')
      OPEN (UNIT=6,FILE='RES2.OUT',ACTION='WRITE',
     &  DELIM='APOSTROPHE',STATUS='REPLACE')
C
      SSPAR(1:8) = 0.0
      READ (7,*) TITLE
      WRITE (6,10) TITLE
  10  FORMAT(5X,'POLSYS1H TEST ROUTINE 7/7/95',//,A72)
C
      READ (7, NML=PROBLEM)
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=',I5)
      WRITE (6,104) TOTDG,MAXT
 104  FORMAT(/,' TOTDG=',I5,10X,'MAXT=',I5)
      WRITE (6,106) EPSBIG,EPSSML,SSPAR(5),N,NUMRR
 106  FORMAT(/,' EPSBIG, EPSSML =',2ES22.14,
     &       //,' SSPAR(5) =',ES22.14,
     &       //,' NUMBER OF EQUATIONS =',I5,
     &       //,' 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
      WRITE(6,200)
 200  FORMAT(//,'  ****** COEFFICIENT TABLEAU ******')
      KDEG = 0  !SET UNUSED DEGREES TO ZERO
      EQN: DO J=1,N
        READ (7,1000) NUMT(J)
        WRITE (6,210) J,NUMT(J)
 210    FORMAT(/,'  NUMT(',I2,') =',I5)
        NT=NUMT(J)
        TERMS: DO K=1,NT
          VARS: DO 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)
          END DO VARS
          READ (7,2000) COEF(J,K)
          WRITE (6,230) J,K,COEF(J,K)
 230      FORMAT('  COEF(',I2,',',I2,') =',ES22.14)
        END DO TERMS
      END DO EQN
      WRITE (6,FMT="(//)")
C
      IFLG1=10*IFLGHM+IFLGSC
      DO M=1,TOTDG
        IFLG2(M)=-2
      END DO
      CALL POLSYS1H(N,NUMT(1:N),COEF(1:N,1:MAXT),
     &  KDEG(1:N,1:N+1,1:MAXT),IFLG1,IFLG2(1:TOTDG),EPSBIG,EPSSML,
     &  SSPAR,NUMRR,LAMBDA(1:TOTDG),ROOTS(1:2,1:N+1,1:TOTDG),
     &  ARCLEN(1:TOTDG),NFE(1:TOTDG))
C
      WRITE (6,240) IFLG1
 240  FORMAT('  IFLG1 =',I5,/)
      ITOTIT = SUM(NFE(1:TOTDG))
      DO M=1,TOTDG
        WRITE (6,260) M
 260    FORMAT('  PATH NUMBER =',I5,//'  FINAL VALUES FOR PATH'/)
        WRITE (6,280) ARCLEN(M)
 280    FORMAT('  ARCLEN =',ES22.14)
        WRITE (6,290) NFE(M)
 290    FORMAT('  NFE =',I5)
        WRITE (6,300) IFLG2(M)
 300    FORMAT('  IFLG2 =',I3)
C
C   DESIGNATE SOLUTIONS "REAL" OR "COMPLEX"
C
        IF (ANY(ABS(ROOTS(2,1:N,M)) .GE. 1.0E-4)) THEN
          WRITE (6,779,ADVANCE='NO')
 779      FORMAT(' COMPLEX, ')
        ELSE
          WRITE (6,780,ADVANCE='NO')
 780      FORMAT(' REAL, ')
        END IF
C
C   DESIGNATE SOLUTION "FINITE" OR "INFINITE"
C
        IF (SUM(ABS(ROOTS(1:2,NP1,M))) .LT. 1.0E-6) THEN
          WRITE (6,781)
 781      FORMAT('INFINITE SOLUTION')
        ELSE
          WRITE (6,782)
 782      FORMAT('FINITE SOLUTION')
        END IF
C
        WRITE (6,320) LAMBDA(M),(J,(ROOTS(L,J,M),L=1,2),J=1,N)
 320    FORMAT('  LAMBDA =',ES22.14,/,(' X(',I2,') =',2ES22.14))
        WRITE (6,330) NP1,ROOTS(1:2,NP1,M)
 330    FORMAT(/,' X(',I2,') =',2ES22.14,//)
      END DO
      WRITE (6,400) ITOTIT
 400  FORMAT(' TOTAL NFE OVER ALL PATHS = ',I10)
      STOP
 1000 FORMAT(I5)
 2000 FORMAT(ES22.14)
      END PROGRAM TESTP
!
! HOMOTOPY subroutines for the polynomial system driver POLSYS1H.
! These subroutines should be used verbatim with POLSYS1H for solving
! polynomial systems of equations.  The polynomial coefficients, defined
! as input to POLSYS1H, are accessed by the routines here via the global
! arrays in HOMPACK90_GLOBAL.
!
C ###################################################################
C ONLY THE SUBROUTINES RHO AND RHOJAC ARE USED BY THE POLYNOMIAL
C SYSTEM DRIVER POLSYS1H.  ALL THE OTHER ROUTINES HERE ARE PROVIDED
C SIMPLY AS TEMPLATES.
C ###################################################################
!
      SUBROUTINE F(X,V)
      USE REAL_PRECISION, ONLY : R8
      REAL (KIND=R8), INTENT(IN):: X(:)
      REAL (KIND=R8), INTENT(OUT):: V(:)
C
C EVALUATE  F(X)  AND RETURN IN THE VECTOR  V .
C
      V(1)=X(1) ! INTENT(OUT) VARIABLE MUST BE DEFINED.
      RETURN
      END SUBROUTINE F

		
      SUBROUTINE FJAC(X,V,K)
      USE REAL_PRECISION, ONLY : R8
      REAL (KIND=R8), INTENT(IN):: X(:)
      REAL (KIND=R8), INTENT(OUT):: V(:)
      INTEGER, INTENT(IN):: K
C
C RETURN IN  V  THE KTH COLUMN OF THE JACOBIAN MATRIX OF
C F(X) EVALUATED AT  X .
C
      V(1)=X(1) ! INTENT(OUT) VARIABLE MUST BE DEFINED.
      RETURN
      END SUBROUTINE FJAC

		
      SUBROUTINE RHO(A,LAMBDA,X,V)
      USE REAL_PRECISION, ONLY : R8
      USE HOMPACK90_GLOBAL, ONLY: IPAR, PAR
      REAL (KIND=R8), INTENT(IN):: A(:),X(:)
      REAL (KIND=R8), INTENT(IN OUT):: LAMBDA
      REAL (KIND=R8), INTENT(OUT):: V(:)
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  POLSYS1H , AND SHOULD BE USED VERBATIM WITH  POLSYS1H .  IF THE USER IS
C CALLING  FIXP??  OR   STEP??  DIRECTLY, HE MUST SUPPLY APPROPRIATE
C REPLACEMENT CODE HERE.
      INTERFACE
        SUBROUTINE HFUNP(N,A,LAMBDA,X)
        USE REAL_PRECISION
        INTEGER, INTENT(IN):: N
        REAL (KIND=R8), INTENT(IN):: A(2*N),LAMBDA,X(2*N)
        END SUBROUTINE HFUNP
      END INTERFACE
      INTEGER:: J,NPOL
C FORCE PREDICTED POINT TO HAVE  LAMBDA .GE. 0  .
      IF (LAMBDA .LT. 0.0) LAMBDA=0.0
      NPOL=IPAR(1)
      CALL HFUNP(NPOL,A,LAMBDA,X)
      DO J=1,2*NPOL
        V(J)=PAR(IPAR(3 + (4-1)) + (J-1))
      END DO
C
      RETURN
      END SUBROUTINE RHO

		
      SUBROUTINE RHOA(A,LAMBDA,X)
      USE REAL_PRECISION, ONLY : R8
      REAL (KIND=R8), INTENT(OUT):: A(:)
      REAL (KIND=R8), INTENT(IN):: LAMBDA,X(:)
C
C CALCULATE AND RETURN IN  A  THE VECTOR Z SUCH THAT
C  RHO(Z,LAMBDA,X) = 0 .
C
      A(1)=LAMBDA ! INTENT(OUT) VARIABLE MUST BE DEFINED.
      RETURN
      END SUBROUTINE RHOA

		
      SUBROUTINE RHOJAC(A,LAMBDA,X,V,K)
      USE REAL_PRECISION, ONLY : R8
      USE HOMPACK90_GLOBAL, ONLY: IPAR, PAR
      REAL (KIND=R8), INTENT(IN):: A(:),X(:)
      REAL (KIND=R8), INTENT(IN OUT):: LAMBDA
      REAL (KIND=R8), INTENT(OUT):: V(:)
      INTEGER, INTENT(IN):: K
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  POLSYS1H , AND SHOULD BE USED VERBATIM WITH  POLSYS1H .  IF THE USER IS
C CALLING  FIXP??  OR   STEP??  DIRECTLY, HE MUST SUPPLY APPROPRIATE
C REPLACEMENT CODE HERE.
      INTERFACE
        SUBROUTINE HFUNP(N,A,LAMBDA,X)
        USE REAL_PRECISION
        INTEGER, INTENT(IN):: N
        REAL (KIND=R8), INTENT(IN):: A(2*N),LAMBDA,X(2*N)
        END SUBROUTINE HFUNP
      END INTERFACE
      INTEGER:: J,NPOL,N2
      NPOL=IPAR(1)
      N2=2*NPOL
      IF (K .EQ. 1) THEN
C FORCE PREDICTED POINT TO HAVE  LAMBDA .GE. 0  .
        IF (LAMBDA .LT. 0.0) LAMBDA=0.0
        CALL HFUNP(NPOL,A,LAMBDA,X)
        DO J=1,N2
          V(J)=PAR(IPAR(3 + (6-1)) + (J-1))
        END DO
        RETURN
      ELSE
        DO J=1,N2
          V(J)=PAR(IPAR(3 + (5-1)) + (J-1) + N2*(K-2))
        END DO
      ENDIF
C
      RETURN
      END SUBROUTINE RHOJAC

		
      SUBROUTINE FJACS(X)
      USE REAL_PRECISION, ONLY : R8
      USE HOMPACK90_GLOBAL, ONLY: QRSPARSE, ROWPOS, COLPOS
      REAL (KIND=R8), INTENT(IN):: X(:)
C
C If MODE = 1,
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 QRSPARSE.  LENQR is the
C length of QRSPARSE, and ROWPOS contains the indices of the diagonal
C elements of the Jacobian matrix within QRSPARSE.  ROWPOS(N+1) and
C ROWPOS(N+2) are set by subroutine FODEDS.  The allocatable array COLPOS
C is not used by this storage format.
C
C If MODE = 2,
C evaluate the N x N Jacobian matrix of F(X) at X, and return the result
C in sparse row storage format in QRSPARSE.  LENQR is the length of
C QRSPARSE, ROWPOS contains the indices of where each row begins within
C QRSPARSE, and COLPOS (of length LENQR) contains the column indices of
C the corresponding elements in QRSPARSE.  Even if zero, the diagonal
C elements of the Jacobian matrix must be stored in QRSPARSE.
C
      RETURN
      END SUBROUTINE FJACS

		
      SUBROUTINE RHOJS(A,LAMBDA,X)
      USE REAL_PRECISION, ONLY : R8
      USE HOMPACK90_GLOBAL, ONLY: QRSPARSE, ROWPOS, COLPOS
      REAL (KIND=R8), INTENT(IN):: A(:),LAMBDA,X(:)
C
C If MODE = 1,
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 QRSPARSE.  LENQR is the
C length of QRSPARSE, and ROWPOS contains the indices of the diagonal
C elements of the Jacobian matrix within QRSPARSE.  ROWPOS(N+1) and
C ROWPOS(N+2) are set by subroutine FODEDS.  The allocatable array COLPOS
C is not used by this storage format.
C
C If MODE = 2,
C evaluate the N x N Jacobian matrix of F(X) at X, and return the result
C in sparse row storage format in QRSPARSE.  LENQR is the length of
C QRSPARSE, ROWPOS contains the indices of where each row begins within
C QRSPARSE, and COLPOS (of length LENQR) contains the column indices of
C the corresponding elements in QRSPARSE.  Even if zero, the diagonal
C elements of the Jacobian matrix must be stored in QRSPARSE.
C
      RETURN
      END SUBROUTINE RHOJS
SHAR_EOF
fi # end of overwriting check
if test -f 'driver1.f'
then
	echo shar: will not over-write existing file "'driver1.f'"
else
cat << \SHAR_EOF > 'driver1.f'
C  MAIN PROGRAM TO TEST FIXPQF, FIXPNF, FIXPDF, STEPNX, AND ROOTNX.
C       BROWN'S FUNCTION, ZERO FINDING.
C
C       THIS PROGRAM TESTS THE HOMPACK ROUTINES FIXPQF, FIXPNF,
C       FIXPDF, STEPNX, AND ROOTNX.
C
C       THE OUTPUT FROM THIS ROUTINE SHOULD BE AS FOLLOWS, WITH THE
C       EXECUTION TIMES CORRESPONDING TO A DEC AXP 3000/600.
C
C       TESTING FIXPQF
C
C LAMBDA = 1.00000000  FLAG = 1       6 JACOBIAN EVALUATIONS
C EXECUTION TIME(SECS) =     0.106    ARCLEN =     2.693
C   1.00000000E+00  1.00000000E+00  1.00000000E+00  1.00000000E+00
C   1.00000000E+00
C
C
C       TESTING FIXPNF
C
C LAMBDA = 1.00000000  FLAG = 1      19 JACOBIAN EVALUATIONS
C EXECUTION TIME(SECS) =     0.005    ARCLEN =     2.676
C   1.00000000E+00  1.00000000E+00  1.00000000E+00  1.00000000E+00
C   1.00000000E+00
C
C
C       TESTING FIXPDF
C
C LAMBDA = 1.00000000  FLAG = 1      71 JACOBIAN EVALUATIONS
C EXECUTION TIME(SECS) =     0.016    ARCLEN =     2.712
C   1.00000000E+00  1.00000000E+00  1.00000000E+00  1.00000000E+00
C   1.00000000E+00
C
C  
C       TESTING STEPNX AND ROOTNX
C  
C LAMBDA = 1.00000000  FLAG = -1      80 JACOBIAN EVALUATIONS
C EXECUTION TIME(SECS) =     0.020    ARCLEN =     2.711
C   1.00000000E+00  1.00000000E+00  1.00000000E+00  1.00000000E+00
C   1.00000000E+00
C
C
      PROGRAM TESTF
      USE REAL_PRECISION, ONLY : R8
      USE HOMPACK90, ONLY : FIXPDF, FIXPNF, FIXPQF
      IMPLICIT NONE
      INTEGER, PARAMETER:: N=5, NDIMA=5
      REAL (KIND=R8):: A(N),ANSAE,ANSRE,ARCAE,ARCRE,
     &  ARCLEN,DTIME,SSPAR(8),Y(N+1)
      INTEGER:: IFLAG,II,J,NFE,NP1,TIMENEW(8),TIMEOLD(8),TRACE
      CHARACTER (LEN=6) NAME
! If using a subroutine library of the HOMPACK90 subroutines rather than
! the MODULE HOMPACK90 (as above), then the following INTERFACE
! statements are necessary.
!     INTERFACE
!       SUBROUTINE FIXPDF(N,Y,IFLAG,ARCTOL,EPS,TRACE,A,NDIMA,
!    &    NFE,ARCLEN)
!       USE REAL_PRECISION
!       INTEGER, INTENT(IN)::N,NDIMA,TRACE
!       REAL (KIND=R8), DIMENSION(:), INTENT(IN OUT)::A,Y
!       INTEGER, INTENT(IN OUT)::IFLAG
!       REAL (KIND=R8), INTENT(IN OUT)::ARCTOL,EPS
!       INTEGER, INTENT(OUT)::NFE
!       REAL (KIND=R8), INTENT(OUT)::ARCLEN
!       END SUBROUTINE FIXPDF
C
!       SUBROUTINE FIXPNF(N,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE,A,
!    &    SSPAR,NFE,ARCLEN,POLY_SWITCH)
!       USE REAL_PRECISION
!       INTEGER, INTENT(IN)::N,TRACE
!       REAL (KIND=R8), DIMENSION(:), INTENT(IN OUT)::A,Y
!       INTEGER, INTENT(IN OUT)::IFLAG
!       REAL (KIND=R8), INTENT(IN OUT)::ANSAE,ANSRE,ARCAE,ARCRE,
!    &    SSPAR(8)
!       INTEGER, INTENT(OUT)::NFE
!       REAL (KIND=R8), INTENT(OUT)::ARCLEN
!       LOGICAL, INTENT(IN), OPTIONAL::POLY_SWITCH
!      END SUBROUTINE FIXPNF
C
!       SUBROUTINE FIXPQF(N,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE,A,
!    &    SSPAR,NFE,ARCLEN)
!       USE REAL_PRECISION
!       INTEGER, INTENT(IN)::N,TRACE
!       REAL (KIND=R8), DIMENSION(:), INTENT(IN OUT)::A,Y
!       INTEGER, INTENT(IN OUT)::IFLAG
!       REAL (KIND=R8), INTENT(IN OUT)::ANSAE,ANSRE,ARCAE,ARCRE,
!    &    SSPAR(4)
!       INTEGER, INTENT(OUT)::NFE
!       REAL (KIND=R8), INTENT(OUT)::ARCLEN
!      END SUBROUTINE FIXPQF
!     END INTERFACE
C
C TEST EACH OF THE THREE ALGORITHMS.
C
      DO II=1,3
C
C DEFINE ARGUMENTS FOR CALL TO HOMPACK PROCEDURE.
C
         NP1=N+1
         ARCRE=0.5D-4
         ARCAE=0.5D-4
         ANSRE=1.0D-10
         ANSAE=1.0D-10
         TRACE=0
         SSPAR=0.0
         IFLAG=-1
         Y(2:NP1)=0.0
C
C GET CURRENT DATE AND TIME.
C
        CALL DATE_AND_TIME(VALUES=TIMEOLD)
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,
     &       SSPAR,NFE,ARCLEN)
        ELSE IF (II .EQ. 2) THEN
          NAME='FIXPNF'
          CALL FIXPNF(N,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE,A,
     &       SSPAR,NFE,ARCLEN)
        ELSE
          NAME='FIXPDF'
          CALL FIXPDF(N,Y,IFLAG,ARCRE,ANSRE,TRACE,A,NDIMA,NFE,ARCLEN)
        END IF
C
C CALCULATE EXECUTION TIME.
C
        CALL DATE_AND_TIME(VALUES=TIMENEW)
        IF (TIMENEW(8) .LT. TIMEOLD(8)) THEN
          TIMENEW(8)=TIMENEW(8)+1000
          TIMENEW(7)=TIMENEW(7)-1
        ENDIF
        IF (TIMENEW(7) .LT. TIMEOLD(7)) THEN
          TIMENEW(7)=TIMENEW(7)+60
          TIMENEW(6)=TIMENEW(6)-1
        ENDIF
        IF (TIMENEW(6) .LT. TIMEOLD(6)) THEN
          TIMENEW(6)=TIMENEW(6)+60
          TIMENEW(5)=TIMENEW(5)-1
        ENDIF
        IF (TIMENEW(5) .LT. TIMEOLD(5)) TIMENEW(5)=TIMENEW(5)+24
        DTIME=DOT_PRODUCT(TIMENEW(5:8)-TIMEOLD(5:8),
     &    (/3600000,60000,1000,1/) )/1000.0
C
        WRITE (6,45) NAME
45      FORMAT (//,7X,'TESTING',1X,A6)
        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.3,4X,
     &    'ARCLEN =',F10.3/(1X,4ES16.8))
      END DO
C
C TEST REVERSE CALL SUBROUTINES  STEPNX  AND  ROOTNX  ON THE SAME
C PROBLEM.
C
      CALL MAINX
      STOP
      END PROGRAM TESTF
!
! SAMPLE USER WRITTEN HOMOTOPY SUBROUTINES FOR TESTING FIXP*F.
!
      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********************************************************************
      USE REAL_PRECISION, ONLY : R8
      IMPLICIT NONE
      REAL (KIND=R8), INTENT(IN):: X(:)
      REAL (KIND=R8), INTENT(OUT):: V(:)
      INTEGER:: N
      N=SIZE(X)
      V(1)=PRODUCT(X) - 1.0
      V(2:N)=SUM(X) - (N+1) + X(2:N)
      RETURN
      END SUBROUTINE F
      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********************************************************************
      USE REAL_PRECISION, ONLY : R8
      REAL (KIND=R8), INTENT(IN):: X(:)
      REAL (KIND=R8), INTENT(OUT):: V(:)
      INTEGER, INTENT(IN):: K
      INTEGER:: J,N
      REAL (KIND=R8):: PROD
C
      N=SIZE(X)
      PROD=1.0
      DO J=1,K-1
       PROD=PROD*X(J)
      END DO
      DO J=K+1,N
       PROD=PROD*X(J)
      END DO
      V(1)=PROD
      V(2:N)=1.0
      IF (K .GT. 1) V(K)=V(K)+1.0
      RETURN
      END SUBROUTINE FJAC
C **********************************************************************
C
C THE REST OF THESE SUBROUTINES ARE NOT USED BY PROGRAM TESTF, AND ARE
C INCLUDED HERE SIMPLY FOR COMPLETENESS AND AS TEMPLATES FOR THEIR USE.
C
      SUBROUTINE RHO(A,LAMBDA,X,V)
      USE REAL_PRECISION, ONLY : R8
      USE HOMPACK90_GLOBAL
      REAL (KIND=R8), INTENT(IN):: A(:),X(:)
      REAL (KIND=R8), INTENT(IN OUT):: LAMBDA
      REAL (KIND=R8), INTENT(OUT):: V(:)
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  POLSYS1H , AND SHOULD BE USED VERBATIM WITH  POLSYS1H .  IF THE USER IS
C CALLING  FIXP??  OR   STEP??  DIRECTLY, HE MUST SUPPLY APPROPRIATE
C REPLACEMENT CODE HERE.
      INTERFACE
        SUBROUTINE HFUNP(N,A,LAMBDA,X)
        USE REAL_PRECISION
        INTEGER, INTENT(IN):: N
        REAL (KIND=R8), INTENT(IN):: A(2*N),LAMBDA,X(2*N)
        END SUBROUTINE HFUNP
      END INTERFACE
      INTEGER:: J,NPOL
C FORCE PREDICTED POINT TO HAVE  LAMBDA .GE. 0  .
      IF (LAMBDA .LT. 0.0) LAMBDA=0.0
      NPOL=IPAR(1)
!     CALL HFUNP(NPOL,A,LAMBDA,X)
      DO J=1,2*NPOL
        V(J)=PAR(IPAR(3 + (4-1)) + (J-1))
      END DO
C
      RETURN
      END SUBROUTINE RHO

		
      SUBROUTINE RHOA(A,LAMBDA,X)
      USE REAL_PRECISION, ONLY : R8
      REAL (KIND=R8), INTENT(OUT):: A(:)
      REAL (KIND=R8), INTENT(IN):: LAMBDA,X(:)
C
C CALCULATE AND RETURN IN  A  THE VECTOR Z SUCH THAT
C  RHO(Z,LAMBDA,X) = 0 .
C
      A(1)=LAMBDA ! INTENT(OUT) VARIABLE MUST BE DEFINED.
      RETURN
      END SUBROUTINE RHOA

		
      SUBROUTINE RHOJAC(A,LAMBDA,X,V,K)
      USE REAL_PRECISION, ONLY : R8
      USE HOMPACK90_GLOBAL
      REAL (KIND=R8), INTENT(IN):: A(:),X(:)
      REAL (KIND=R8), INTENT(IN OUT):: LAMBDA
      REAL (KIND=R8), INTENT(OUT):: V(:)
      INTEGER, INTENT(IN):: K
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  POLSYS1H , AND SHOULD BE USED VERBATIM WITH  POLSYS1H .  IF THE USER IS
C CALLING  FIXP??  OR   STEP??  DIRECTLY, HE MUST SUPPLY APPROPRIATE
C REPLACEMENT CODE HERE.
      INTERFACE
        SUBROUTINE HFUNP(N,A,LAMBDA,X)
        USE REAL_PRECISION
        INTEGER, INTENT(IN):: N
        REAL (KIND=R8), INTENT(IN):: A(2*N),LAMBDA,X(2*N)
        END SUBROUTINE HFUNP
      END INTERFACE
      INTEGER:: J,NPOL,N2
      NPOL=IPAR(1)
      N2=2*NPOL
      IF (K .EQ. 1) THEN
C FORCE PREDICTED POINT TO HAVE  LAMBDA .GE. 0  .
        IF (LAMBDA .LT. 0.0) LAMBDA=0.0
!       CALL HFUNP(NPOL,A,LAMBDA,X)
        DO J=1,N2
          V(J)=PAR(IPAR(3 + (6-1)) + (J-1))
        END DO
        RETURN
      ELSE
        DO J=1,N2
          V(J)=PAR(IPAR(3 + (5-1)) + (J-1) + N2*(K-2))
        END DO
      ENDIF
C
      RETURN
      END SUBROUTINE RHOJAC

		
      SUBROUTINE FJACS(X)
      USE REAL_PRECISION, ONLY : R8
      USE HOMPACK90_GLOBAL
      REAL (KIND=R8), INTENT(IN):: X(:)
C
C If MODE = 1,
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 QRSPARSE.  LENQR is the
C length of QRSPARSE, and ROWPOS contains the indices of the diagonal
C elements of the Jacobian matrix within QRSPARSE.  ROWPOS(N+1) and
C ROWPOS(N+2) are set by subroutine FODEDS.  The allocatable array COLPOS
C is not used by this storage format.
C
C If MODE = 2,
C evaluate the N x N Jacobian matrix of F(X) at X, and return the result
C in sparse row storage format in QRSPARSE.  LENQR is the length of
C QRSPARSE, ROWPOS contains the indices of where each row begins within
C QRSPARSE, and COLPOS (of length LENQR) contains the column indices of
C the corresponding elements in QRSPARSE.  Even if zero, the diagonal
C elements of the Jacobian matrix must be stored in QRSPARSE.
C
      RETURN
      END SUBROUTINE FJACS

		
      SUBROUTINE RHOJS(A,LAMBDA,X)
      USE REAL_PRECISION, ONLY : R8
      USE HOMPACK90_GLOBAL
      REAL (KIND=R8), INTENT(IN):: A(:),LAMBDA,X(:)
C
C If MODE = 1,
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 QRSPARSE.  LENQR is the
C length of QRSPARSE, and ROWPOS contains the indices of the diagonal
C elements of the Jacobian matrix within QRSPARSE.  ROWPOS(N+1) and
C ROWPOS(N+2) are set by subroutine FODEDS.  The allocatable array COLPOS
C is not used by this storage format.
C
C If MODE = 2,
C evaluate the N x N Jacobian matrix of F(X) at X, and return the result
C in sparse row storage format in QRSPARSE.  LENQR is the length of
C QRSPARSE, ROWPOS contains the indices of where each row begins within
C QRSPARSE, and COLPOS (of length LENQR) contains the column indices of
C the corresponding elements in QRSPARSE.  Even if zero, the diagonal
C elements of the Jacobian matrix must be stored in QRSPARSE.
C
      RETURN
      END SUBROUTINE RHOJS
C **********************************************************************
C
C  SUBROUTINE TO TEST THE REVERSE CALL SUBROUTINES  STEPNX  AND
C  ROOTNX.  THE TEST PROBLEM IS BROWN'S FUNCTION, ZERO FINDING.
C  THE OUTPUT IS SIMILAR TO THAT FROM THE TEST OF  FIXPNF, EXCEPT WITH
C  MORE JACOBIAN EVALUATIONS SINCE THE UNDEFINED FUNCTION OPTION OF
C  STEPNX  IS USED TO FORCE SMALLER STEPS.
C
      SUBROUTINE MAINX
      USE REAL_PRECISION, ONLY : R8
      USE HOMOTOPY
      IMPLICIT NONE
      INTEGER, PARAMETER:: N=5, NDIMA=5
      REAL (KIND=R8):: A(NDIMA),ABSERR,ALPHA(3*N+3),
     &  ANSAE,ANSRE,ARCAE,ARCRE,ARCLEN,DTIME,GOFW,H,HOLD,
     &  QR(N,N+2),RELERR,RHOLEN,S,SSPAR(8),TZ(N+1),W(N+1),
     &  WP(N+1),Y(N+1),YOLD(N+1),YOLDS(N+1),YP(N+1),YPOLD(N+1)
      INTEGER:: IFLAG,ITER=0,J,NFE,NFEC=0,NP1,PIVOT(N+1),
     &  TIMENEW(8),TIMEOLD(8),TRACE
      LOGICAL:: CRASH, START
C
      INTERFACE
        SUBROUTINE ROOTNX(N,NFE,IFLAG,RELERR,ABSERR,Y,YP,YOLD,
     &   YPOLD,A,GOFW,TZ,W,WP)
        USE HOMOTOPY
        USE REAL_PRECISION
        INTEGER, INTENT(IN):: N
        INTEGER, INTENT(IN OUT):: NFE,IFLAG
        REAL (KIND=R8), INTENT(IN):: RELERR,ABSERR
        REAL (KIND=R8), DIMENSION(:), INTENT(IN):: A
        REAL (KIND=R8), INTENT(IN OUT):: GOFW
        REAL (KIND=R8), DIMENSION(:), INTENT(IN OUT):: Y,YP,YOLD,YPOLD,
     &    TZ,W,WP
        END SUBROUTINE ROOTNX
        SUBROUTINE STEPNX(N,NFE,IFLAG,START,CRASH,HOLD,H,RELERR,
     &    ABSERR,S,Y,YP,YOLD,YPOLD,A,TZ,W,WP,RHOLEN,SSPAR)
        USE HOMOTOPY
        USE REAL_PRECISION
        INTEGER, INTENT(IN):: N
        INTEGER, INTENT(IN OUT):: NFE,IFLAG
        LOGICAL, INTENT(IN OUT):: START,CRASH
        REAL (KIND=R8), INTENT(IN OUT):: HOLD,H,RELERR,ABSERR,S,RHOLEN,
     &    SSPAR(8)
        REAL (KIND=R8), DIMENSION(:), INTENT(IN):: A
        REAL (KIND=R8), DIMENSION(:), INTENT(IN OUT):: Y,YP,YOLD,YPOLD,
     &    TZ,W,WP
        REAL (KIND=R8), DIMENSION(:), ALLOCATABLE, SAVE:: Z0,Z1
        END SUBROUTINE STEPNX
        SUBROUTINE TANGNF(RHOLEN,Y,YP,YPOLD,A,QR,ALPHA,TZ,PIVOT,
     &    NFE,N,IFLAG)
        USE REAL_PRECISION
        REAL (KIND=R8):: RHOLEN
        INTEGER:: IFLAG,N,NFE
        REAL (KIND=R8):: A(:),Y(:),YP(N+1),YPOLD(N+1)
        REAL (KIND=R8):: ALPHA(3*N+3),QR(N,N+2),TZ(N+1)
        INTEGER:: PIVOT(N+1)
        END SUBROUTINE TANGNF
      END INTERFACE
C
C DEFINE ARGUMENTS FOR CALL TO HOMPACK PROCEDURE.
C
      NP1=N+1
      NFE=0
      ARCRE=0.5D-4
      ARCAE=0.5D-4
      ANSRE=1.0D-10
      ANSAE=1.0D-10
      ABSERR=ARCAE; RELERR=ARCRE
      TRACE=0
      SSPAR=0.0
      IFLAG=-1
      A=0.0
      Y(1:NP1)=0.0
      YP(1)=1.0;  YP(2:NP1)=0.0
      YOLD=Y;  YPOLD=YP
      START=.TRUE.
      CRASH=.FALSE.
      HOLD=1.0
      H=.1
      S=0.0
C
C GET CURRENT DATE AND TIME.
C
      CALL DATE_AND_TIME(VALUES=TIMEOLD)
C
C TRACK CURVE TILL LAMBDA > 1.0 .
C
      TRACK: DO WHILE (Y(1) < 1.0_R8)
        CALL STEPNX (N,NFE,IFLAG,START,CRASH,HOLD,H,RELERR,
     &       ABSERR,S,Y,YP,YOLD,YPOLD,A,TZ,W,WP,RHOLEN,SSPAR)
        IF (CRASH) CYCLE TRACK
        SELECT CASE (IFLAG)
          CASE (-2:0)
            IF (TRACE .GT. 0) THEN
              ITER=ITER+1
              WRITE (TRACE,11) ITER,NFE,S,Y(1),Y(2:NP1)
 11           FORMAT(/' STEP',I5,3X,'NFE =',I5,3X,'ARC LENGTH =',
     &        F9.4,3X,'LAMBDA =',F7.4,5X,'X VECTOR:'/(1X,6ES12.4))
            ENDIF
            CYCLE TRACK
          CASE (-12:-10)   ! TANGENT VECTOR
            IF (H > .1_R8) THEN
              IFLAG = IFLAG - 100
              CYCLE TRACK
            END IF
            RHOLEN=0.0
            CALL TANGNF(RHOLEN,W,WP,YPOLD,A,QR,ALPHA,TZ,PIVOT,
     &      NFEC,N,IFLAG)
          CASE (-32:-20)   ! TANGENT VECTOR AND NEWTON STEP
            IF (H > .1_R8) THEN
              IFLAG = IFLAG - 100
              CYCLE TRACK
            END IF
            RHOLEN=-1.0
            CALL TANGNF(RHOLEN,W,WP,YPOLD,A,QR,ALPHA,TZ,PIVOT,
     &      NFEC,N,IFLAG)
          CASE (4,6,7)
            WRITE (6,13) IFLAG
 13         FORMAT(/' FATAL ERROR OCCURRED DURING TRACKING WITH',
     &             ' FLAG =',I2,//)
            STOP
        END SELECT
      END DO TRACK
C
C CLEAN UP WORKING STORAGE.
      IFLAG=IFLAG - 40
      CALL STEPNX (N,NFE,IFLAG,START,CRASH,HOLD,H,RELERR,
     &     ABSERR,S,Y,YP,YOLD,YPOLD,A,TZ,W,WP,RHOLEN,SSPAR)
C SAVE  YOLD  FOR ARC LENGTH CALCULATION LATER.
      YOLDS = YOLD
C
C FIND POINT ON HOMOTOPY ZERO CURVE SATISFYING
C   G(Y(S)) = LAMBDA(S) - 1 = 0 .
C
      ABSERR=ANSAE
      RELERR=ANSRE
      END_GAME: DO
        CALL ROOTNX(N,NFE,IFLAG,RELERR,ABSERR,Y,YP,YOLD,
     &       YPOLD,A,GOFW,TZ,W,WP)
        SELECT CASE (IFLAG)
          CASE (-42:-10)   ! G(W)
            GOFW = W(1) - 1.0
          CASE (-52:-50)   ! TANGENT VECTOR AND NEWTON STEP
            RHOLEN=-1.0
            CALL TANGNF(RHOLEN,W,WP,YPOLD,A,QR,ALPHA,TZ,PIVOT,
     &      NFEC,N,IFLAG)
          CASE (-2:0, 4, 6, 7)
            EXIT END_GAME
        END SELECT
      END DO END_GAME
C CALCULATE FINAL ARC LENGTH.
      W = Y - YOLDS
      ARCLEN = S - HOLD + SQRT(DOT_PRODUCT(W,W))
C
C CALCULATE EXECUTION TIME.
C
      CALL DATE_AND_TIME(VALUES=TIMENEW)
      IF (TIMENEW(8) .LT. TIMEOLD(8)) THEN
        TIMENEW(8)=TIMENEW(8)+1000
        TIMENEW(7)=TIMENEW(7)-1
      ENDIF
      IF (TIMENEW(7) .LT. TIMEOLD(7)) THEN
        TIMENEW(7)=TIMENEW(7)+60
        TIMENEW(6)=TIMENEW(6)-1
      ENDIF
      IF (TIMENEW(6) .LT. TIMEOLD(6)) THEN
        TIMENEW(6)=TIMENEW(6)+60
        TIMENEW(5)=TIMENEW(5)-1
      ENDIF
      IF (TIMENEW(5) .LT. TIMEOLD(5)) TIMENEW(5)=TIMENEW(5)+24
      DTIME=DOT_PRODUCT(TIMENEW(5:8)-TIMEOLD(5:8),
     &    (/3600000,60000,1000,1/) )/1000.0
C
      WRITE (6,45)
45    FORMAT (//,7X,'TESTING STEPNX AND ROOTNX')
      WRITE (6,50) Y(1),IFLAG,NFE,DTIME,ARCLEN,(Y(J),J=2,NP1)
50    FORMAT(/' LAMBDA =',F11.8,'  FLAG =',I3,I8,' JACOBIAN ',
     &   'EVALUATIONS',/,1X,'EXECUTION TIME(SECS) =',F10.3,4X,
     &   'ARCLEN =',F10.3/(1X,4ES16.8))
      RETURN
      END SUBROUTINE MAINX
SHAR_EOF
fi # end of overwriting check
if test -f 'RES3'
then
	echo shar: will not over-write existing file "'RES3'"
else
cat << \SHAR_EOF > 'RES3'

		

		
       TESTING FIXPQS WITH STORAGE MODE = 1

		
 LAMBDA = 1.00000000  FLAG = 1      33 JACOBIAN EVALUATIONS
 EXECUTION TIME(SECS) =     0.108    ARC LENGTH =     1.274
   4.00864019E-01  2.65454893E-01  8.40421103E-02  4.83042527E-01
   3.01797132E-01  2.32508994E-01  4.96639853E-01  3.00908894E-01

		

		
       TESTING FIXPNS WITH STORAGE MODE = 1

		
 LAMBDA = 1.00000000  FLAG = 1      20 JACOBIAN EVALUATIONS
 EXECUTION TIME(SECS) =     0.012    ARC LENGTH =     1.275
   4.00864019E-01  2.65454893E-01  8.40421103E-02  4.83042527E-01
   3.01797132E-01  2.32508994E-01  4.96639853E-01  3.00908894E-01

		

		
       TESTING FIXPDS WITH STORAGE MODE = 1

		
 LAMBDA = 1.00000000  FLAG = 1      70 JACOBIAN EVALUATIONS
 EXECUTION TIME(SECS) =     0.022    ARC LENGTH =     1.281
   4.00864019E-01  2.65454893E-01  8.40421103E-02  4.83042527E-01
   3.01797132E-01  2.32508994E-01  4.96639853E-01  3.00908894E-01

		

		
       TESTING FIXPQS WITH STORAGE MODE = 2

		
 LAMBDA = 1.00000000  FLAG = 1      33 JACOBIAN EVALUATIONS
 EXECUTION TIME(SECS) =     0.015    ARC LENGTH =     1.274
   4.00864019E-01  2.65454893E-01  8.40421103E-02  4.83042527E-01
   3.01797132E-01  2.32508994E-01  4.96639853E-01  3.00908894E-01

		

		
       TESTING FIXPNS WITH STORAGE MODE = 2

		
 LAMBDA = 1.00000000  FLAG = 1      20 JACOBIAN EVALUATIONS
 EXECUTION TIME(SECS) =     0.011    ARC LENGTH =     1.275
   4.00864019E-01  2.65454893E-01  8.40421103E-02  4.83042527E-01
   3.01797132E-01  2.32508994E-01  4.96639853E-01  3.00908894E-01

		

		
       TESTING FIXPDS WITH STORAGE MODE = 2

		
 LAMBDA = 1.00000000  FLAG = 1      70 JACOBIAN EVALUATIONS
 EXECUTION TIME(SECS) =     0.020    ARC LENGTH =     1.281
   4.00864019E-01  2.65454893E-01  8.40421103E-02  4.83042527E-01
   3.01797132E-01  2.32508994E-01  4.96639853E-01  3.00908894E-01
SHAR_EOF
fi # end of overwriting check
if test -f 'RES2'
then
	echo shar: will not over-write existing file "'RES2'"
else
cat << \SHAR_EOF > 'RES2'
     POLSYS1H TEST ROUTINE 7/7/95

		
 TWO QUADRICS, NO SOLUTIONS AT INFINITY, TWO REAL SOLUTIONS.            

		
 IF IFLGHM=1, HOMOGENEOUS; IF IFLGHM=0, INHOMOGENEOUS; IFLGHM= 1

		
 IF IFLGSC=1, SCLGNP USED; IF IFLGSC=0, NO SCALING; IFLGSC=    1

		
 TOTDG=    4          MAXT=    6

		
 EPSBIG, EPSSML =  1.00000000000000E-04  1.00000000000000E-14

		
 SSPAR(5) =  1.00000000000000E+00

		
 NUMBER OF EQUATIONS =    2

		
 NUMBER OF RECALLS WHEN IFLAG=3:   10

		

		
  ****** COEFFICIENT TABLEAU ******

		
  NUMT( 1) =    6
  KDEG( 1, 1, 1) =    2
  KDEG( 1, 2, 1) =    0
  COEF( 1, 1) = -9.80000000000000E-04
  KDEG( 1, 1, 2) =    0
  KDEG( 1, 2, 2) =    2
  COEF( 1, 2) =  9.78000000000000E+05
  KDEG( 1, 1, 3) =    1
  KDEG( 1, 2, 3) =    1
  COEF( 1, 3) = -9.80000000000000E+00
  KDEG( 1, 1, 4) =    1
  KDEG( 1, 2, 4) =    0
  COEF( 1, 4) = -2.35000000000000E+02
  KDEG( 1, 1, 5) =    0
  KDEG( 1, 2, 5) =    1
  COEF( 1, 5) =  8.89000000000000E+04
  KDEG( 1, 1, 6) =    0
  KDEG( 1, 2, 6) =    0
  COEF( 1, 6) = -1.00000000000000E+00

		
  NUMT( 2) =    6
  KDEG( 2, 1, 1) =    2
  KDEG( 2, 2, 1) =    0
  COEF( 2, 1) = -1.00000000000000E-02
  KDEG( 2, 1, 2) =    0
  KDEG( 2, 2, 2) =    2
  COEF( 2, 2) = -9.84000000000000E-01
  KDEG( 2, 1, 3) =    1
  KDEG( 2, 2, 3) =    1
  COEF( 2, 3) = -2.97000000000000E+01
  KDEG( 2, 1, 4) =    1
  KDEG( 2, 2, 4) =    0
  COEF( 2, 4) =  9.87000000000000E-03
  KDEG( 2, 1, 5) =    0
  KDEG( 2, 2, 5) =    1
  COEF( 2, 5) = -1.24000000000000E-01
  KDEG( 2, 1, 6) =    0
  KDEG( 2, 2, 6) =    0
  COEF( 2, 6) = -2.50000000000000E-01

		

		

		
  IFLG1 =   11

		
  PATH NUMBER =    1

		
  FINAL VALUES FOR PATH

		
  ARCLEN =  1.00553319056290E+01
  NFE =   53
  IFLG2 =  1
 REAL, FINITE SOLUTION
  LAMBDA =  1.00000000000000E+00
 X( 1) =  2.34233851959128E+03  1.49779467841657E-11
 X( 2) = -7.88344824094141E-01 -5.56115428011477E-15

		
 X( 3) = -9.49359459408655E-03 -1.06447550900257E-03

		

		
  PATH NUMBER =    2

		
  FINAL VALUES FOR PATH

		
  ARCLEN =  1.72112928605711E+00
  NFE =   37
  IFLG2 =  1
 COMPLEX, FINITE SOLUTION
  LAMBDA =  1.00000000000001E+00
 X( 1) =  1.61478579234419E-02  1.68496955498881E+00
 X( 2) =  2.67994739614476E-04  4.42802993973660E-03

		
 X( 3) = -3.81948972942403E-01  3.72068943457283E-01

		

		
  PATH NUMBER =    3

		
  FINAL VALUES FOR PATH

		
  ARCLEN =  2.02329527936743E+00
  NFE =   35
  IFLG2 =  1
 COMPLEX, FINITE SOLUTION
  LAMBDA =  1.00000000000000E+00
 X( 1) =  1.61478579234355E-02 -1.68496955498881E+00
 X( 2) =  2.67994739614460E-04 -4.42802993973661E-03

		
 X( 3) = -3.29370493847660E-01  5.56619775523013E-01

		

		
  PATH NUMBER =    4

		
  FINAL VALUES FOR PATH

		
  ARCLEN =  4.16326615695899E+00
  NFE =   46
  IFLG2 =  1
 REAL, FINITE SOLUTION
  LAMBDA =  1.00000000000000E+00
 X( 1) =  9.08921229615388E-02  1.90036587651500E-16
 X( 2) = -9.11497098197499E-02  4.71849760398007E-18

		
 X( 3) = -5.73673395727962E-02  1.36243663709219E-01

		

		
 TOTAL NFE OVER ALL PATHS =        171
SHAR_EOF
fi # end of overwriting check
if test -f 'RES1'
then
	echo shar: will not over-write existing file "'RES1'"
else
cat << \SHAR_EOF > 'RES1'

		

		
       TESTING FIXPQF

		
 LAMBDA = 1.00000000  FLAG = 1       6 JACOBIAN EVALUATIONS
 EXECUTION TIME(SECS) =     0.117    ARCLEN =     2.693
   1.00000000E+00  1.00000000E+00  1.00000000E+00  1.00000000E+00
   1.00000000E+00

		

		
       TESTING FIXPNF

		
 LAMBDA = 1.00000000  FLAG = 1      19 JACOBIAN EVALUATIONS
 EXECUTION TIME(SECS) =     0.004    ARCLEN =     2.676
   1.00000000E+00  1.00000000E+00  1.00000000E+00  1.00000000E+00
   1.00000000E+00

		

		
       TESTING FIXPDF

		
 LAMBDA = 1.00000000  FLAG = 1      71 JACOBIAN EVALUATIONS
 EXECUTION TIME(SECS) =     0.011    ARCLEN =     2.712
   1.00000000E+00  1.00000000E+00  1.00000000E+00  1.00000000E+00
   1.00000000E+00

		

		
       TESTING STEPNX AND ROOTNX

		
 LAMBDA = 1.00000000  FLAG = -1      80 JACOBIAN EVALUATIONS
 EXECUTION TIME(SECS) =     0.011    ARCLEN =     2.711
   1.00000000E+00  1.00000000E+00  1.00000000E+00  1.00000000E+00
   1.00000000E+00
SHAR_EOF
fi # end of overwriting check
if test -f 'DATA2'
then
	echo shar: will not over-write existing file "'DATA2'"
else
cat << \SHAR_EOF > 'DATA2'
' TWO QUADRICS, NO SOLUTIONS AT INFINITY, TWO REAL SOLUTIONS.'
&PROBLEM  
      IFLGHM = 1
      IFLGSC = 1
      TOTDG  = 4
      MAXT = 6
      EPSBIG = 1.D-04
      EPSSML = 1.D-14    
      SSPAR(5) = 1.D+00    
      NUMRR = 10
      N = 2 /
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
SHAR_EOF
fi # end of overwriting check
cd ..
if test ! -d 'Info'
then
	mkdir 'Info'
fi
cd 'Info'
if test -f 'depend'
then
	echo shar: will not over-write existing file "'depend'"
else
cat << \SHAR_EOF > 'depend'
blas1/dcopy.f
blas1/ddot.f
blas3/dgemm.f
blas2/dgemv.f
blas2/dger.f
blas1/dnrm2.f
blas1/dscal.f
blas1/dswap.f
blas2/dtpmv.f
blas2/dtpsv.f
blas3/dtrmm.f
blas2/dtrmv.f
blas2/dtrsv.f
blas1/idamax.f
lapack/dgeqpf.f
lapack/dgeqr2.f
lapack/dgeqrf.f
lapack/dlaic1.f
lapack/dlamch.f
lapack/dlamc1.f
lapack/dlamc2.f
lapack/dlamc3.f
lapack/dlamc4.f
lapack/dlamc5.f
lapack/dlapy2.f
lapack/dlarf.f
lapack/dlarfb.f
lapack/dlarfg.f
lapack/dlarft.f
lapack/dorg2r.f
lapack/dorgqr.f
lapack/dorm2r.f
lapack/dormqr.f
lapack/ilaenv.f
lapack/lsame.f
lapack/xerbla.f
SHAR_EOF
fi # end of overwriting check
cd ..
if test ! -d 'Src'
then
	mkdir 'Src'
fi
cd 'Src'
if test -f 'lapack.f'
then
	echo shar: will not over-write existing file "'lapack.f'"
else
cat << \SHAR_EOF > 'lapack.f'
      SUBROUTINE DGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO )
*
*  -- LAPACK test routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     March 31, 1993
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
*     ..
*     .. Array Arguments ..
      INTEGER            JPVT( * )
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DGEQPF computes a QR factorization with column pivoting of a
*  real M-by-N matrix A: A*P = Q*R.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrix A. M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix A. N >= 0
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the M-by-N matrix A.
*          On exit, the upper triangle of the array contains the
*          min(M,N)-by-N upper triangular matrix R; the elements
*          below the diagonal, together with the array TAU,
*          represent the orthogonal matrix Q as a product of
*          min(m,n) elementary reflectors.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A. LDA >= max(1,M).
*
*  JPVT    (input/output) INTEGER array, dimension (N)
*          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
*          to the front of A*P (a leading column); if JPVT(i) = 0,
*          the i-th column of A is a free column.
*          On exit, if JPVT(i) = k, then the i-th column of A*P
*          was the k-th column of A.
*
*  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
*          The scalar factors of the elementary reflectors.
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*
*  Further Details
*  ===============
*
*  The matrix Q is represented as a product of elementary reflectors
*
*     Q = H(1) H(2) . . . H(n)
*
*  Each H(i) has the form
*
*     H = I - tau * v * v'
*
*  where tau is a real scalar, and v is a real vector with
*  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i).
*
*  The matrix P is represented in jpvt as follows: If
*     jpvt(j) = i
*  then the jth column of P is the ith canonical unit vector.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, ITEMP, J, MA, MN, PVT
      DOUBLE PRECISION   AII, TEMP, TEMP2
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGEQR2, DLARF, DLARFG, DORM2R, DSWAP, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, SQRT
*     ..
*     .. External Functions ..
      INTEGER            IDAMAX
      DOUBLE PRECISION   DNRM2
      EXTERNAL           IDAMAX, DNRM2
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments
*
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGEQPF', -INFO )
         RETURN
      END IF
*
      MN = MIN( M, N )
*
*     Move initial columns up front
*
      ITEMP = 1
      DO 10 I = 1, N
         IF( JPVT( I ).NE.0 ) THEN
            IF( I.NE.ITEMP ) THEN
               CALL DSWAP( M, A( 1, I ), 1, A( 1, ITEMP ), 1 )
               JPVT( I ) = JPVT( ITEMP )
               JPVT( ITEMP ) = I
            ELSE
               JPVT( I ) = I
            END IF
            ITEMP = ITEMP + 1
         ELSE
            JPVT( I ) = I
         END IF
   10 CONTINUE
      ITEMP = ITEMP - 1
*
*     Compute the QR factorization and update remaining columns
*
      IF( ITEMP.GT.0 ) THEN
         MA = MIN( ITEMP, M )
         CALL DGEQR2( M, MA, A, LDA, TAU, WORK, INFO )
         IF( MA.LT.N ) THEN
            CALL DORM2R( 'Left', 'Transpose', M, N-MA, MA, A, LDA, TAU,
     $                   A( 1, MA+1 ), LDA, WORK, INFO )
         END IF
      END IF
*
      IF( ITEMP.LT.MN ) THEN
*
*        Initialize partial column norms. The first n elements of
*        work store the exact column norms.
*
         DO 20 I = ITEMP + 1, N
            WORK( I ) = DNRM2( M-ITEMP, A( ITEMP+1, I ), 1 )
            WORK( N+I ) = WORK( I )
   20    CONTINUE
*
*        Compute factorization
*
         DO 40 I = ITEMP + 1, MN
*
*           Determine ith pivot column and swap if necessary
*
            PVT = ( I-1 ) + IDAMAX( N-I+1, WORK( I ), 1 )
*
            IF( PVT.NE.I ) THEN
               CALL DSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 )
               ITEMP = JPVT( PVT )
               JPVT( PVT ) = JPVT( I )
               JPVT( I ) = ITEMP
               WORK( PVT ) = WORK( I )
               WORK( N+PVT ) = WORK( N+I )
            END IF
*
*           Generate elementary reflector H(i)
*
            IF( I.LT.M ) THEN
               CALL DLARFG( M-I+1, A( I, I ), A( I+1, I ), 1, TAU( I ) )
            ELSE
               CALL DLARFG( 1, A( M, M ), A( M, M ), 1, TAU( M ) )
            END IF
*
            IF( I.LT.N ) THEN
*
*              Apply H(i) to A(i:m,i+1:n) from the left
*
               AII = A( I, I )
               A( I, I ) = ONE
               CALL DLARF( 'LEFT', M-I+1, N-I, A( I, I ), 1, TAU( I ),
     $                     A( I, I+1 ), LDA, WORK( 2*N+1 ) )
               A( I, I ) = AII
            END IF
*
*           Update partial column norms
*
            DO 30 J = I + 1, N
               IF( WORK( J ).NE.ZERO ) THEN
                  TEMP = ONE - ( ABS( A( I, J ) ) / WORK( J ) )**2
                  TEMP = MAX( TEMP, ZERO )
                  TEMP2 = ONE + 0.05D0*TEMP*
     $                    ( WORK( J ) / WORK( N+J ) )**2
                  IF( TEMP2.EQ.ONE ) THEN
                     IF( M-I.GT.0 ) THEN
                        WORK( J ) = DNRM2( M-I, A( I+1, J ), 1 )
                        WORK( N+J ) = WORK( J )
                     ELSE
                        WORK( J ) = ZERO
                        WORK( N+J ) = ZERO
                     END IF
                  ELSE
                     WORK( J ) = WORK( J )*SQRT( TEMP )
                  END IF
               END IF
   30       CONTINUE
*
   40    CONTINUE
      END IF
      RETURN
*
*     End of DGEQPF
*
      END
      SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO )
*
*  -- LAPACK routine (version 1.1) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DGEQR2 computes a QR factorization of a real m by n matrix A:
*  A = Q * R.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrix A.  M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix A.  N >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the m by n matrix A.
*          On exit, the elements on and above the diagonal of the array
*          contain the min(m,n) by n upper trapezoidal matrix R (R is
*          upper triangular if m >= n); the elements below the diagonal,
*          with the array TAU, represent the orthogonal matrix Q as a
*          product of elementary reflectors (see Further Details).
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,M).
*
*  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
*          The scalar factors of the elementary reflectors (see Further
*          Details).
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (N)
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: if INFO = -i, the i-th argument had an illegal value
*
*  Further Details
*  ===============
*
*  The matrix Q is represented as a product of elementary reflectors
*
*     Q = H(1) H(2) . . . H(k), where k = min(m,n).
*
*  Each H(i) has the form
*
*     H(i) = I - tau * v * v'
*
*  where tau is a real scalar, and v is a real vector with
*  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
*  and tau in TAU(i).
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, K
      DOUBLE PRECISION   AII
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLARF, DLARFG, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments
*
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGEQR2', -INFO )
         RETURN
      END IF
*
      K = MIN( M, N )
*
      DO 10 I = 1, K
*
*        Generate elementary reflector H(i) to annihilate A(i+1:m,i)
*
         CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1,
     $                TAU( I ) )
         IF( I.LT.N ) THEN
*
*           Apply H(i) to A(i:m,i+1:n) from the left
*
            AII = A( I, I )
            A( I, I ) = ONE
            CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
     $                  A( I, I+1 ), LDA, WORK )
            A( I, I ) = AII
         END IF
   10 CONTINUE
      RETURN
*
*     End of DGEQR2
*
      END
      SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
*
*  -- LAPACK routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     September 30, 1994
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LWORK, M, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( LWORK )
*     ..
*
*  Purpose
*  =======
*
*  DGEQRF computes a QR factorization of a real M-by-N matrix A:
*  A = Q * R.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrix A.  M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix A.  N >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the M-by-N matrix A.
*          On exit, the elements on and above the diagonal of the array
*          contain the min(M,N)-by-N upper trapezoidal matrix R (R is
*          upper triangular if m >= n); the elements below the diagonal,
*          with the array TAU, represent the orthogonal matrix Q as a
*          product of min(m,n) elementary reflectors (see Further
*          Details).
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,M).
*
*  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
*          The scalar factors of the elementary reflectors (see Further
*          Details).
*
*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
*  LWORK   (input) INTEGER
*          The dimension of the array WORK.  LWORK >= max(1,N).
*          For optimum performance LWORK >= N*NB, where NB is
*          the optimal blocksize.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*
*  Further Details
*  ===============
*
*  The matrix Q is represented as a product of elementary reflectors
*
*     Q = H(1) H(2) . . . H(k), where k = min(m,n).
*
*  Each H(i) has the form
*
*     H(i) = I - tau * v * v'
*
*  where tau is a real scalar, and v is a real vector with
*  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
*  and tau in TAU(i).
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I, IB, IINFO, IWS, K, LDWORK, NB, NBMIN, NX
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGEQR2, DLARFB, DLARFT, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments
*
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      ELSE IF( LWORK.LT.MAX( 1, N ) ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGEQRF', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      K = MIN( M, N )
      IF( K.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
*
*     Determine the block size.
*
      NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
      NBMIN = 2
      NX = 0
      IWS = N
      IF( NB.GT.1 .AND. NB.LT.K ) THEN
*
*        Determine when to cross over from blocked to unblocked code.
*
         NX = MAX( 0, ILAENV( 3, 'DGEQRF', ' ', M, N, -1, -1 ) )
         IF( NX.LT.K ) THEN
*
*           Determine if workspace is large enough for blocked code.
*
            LDWORK = N
            IWS = LDWORK*NB
            IF( LWORK.LT.IWS ) THEN
*
*              Not enough workspace to use optimal NB:  reduce NB and
*              determine the minimum value of NB.
*
               NB = LWORK / LDWORK
               NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', M, N, -1,
     $                 -1 ) )
            END IF
         END IF
      END IF
*
      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
*
*        Use blocked code initially
*
         DO 10 I = 1, K - NX, NB
            IB = MIN( K-I+1, NB )
*
*           Compute the QR factorization of the current block
*           A(i:m,i:i+ib-1)
*
            CALL DGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK,
     $                   IINFO )
            IF( I+IB.LE.N ) THEN
*
*              Form the triangular factor of the block reflector
*              H = H(i) H(i+1) . . . H(i+ib-1)
*
               CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB,
     $                      A( I, I ), LDA, TAU( I ), WORK, LDWORK )
*
*              Apply H' to A(i:m,i+ib:n) from the left
*
               CALL DLARFB( 'Left', 'Transpose', 'Forward',
     $                      'Columnwise', M-I+1, N-I-IB+1, IB,
     $                      A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ),
     $                      LDA, WORK( IB+1 ), LDWORK )
            END IF
   10    CONTINUE
      ELSE
         I = 1
      END IF
*
*     Use unblocked code to factor the last or only block.
*
      IF( I.LE.K )
     $   CALL DGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
     $                IINFO )
*
      WORK( 1 ) = IWS
      RETURN
*
*     End of DGEQRF
*
      END
      SUBROUTINE DLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C )
*
*  -- LAPACK auxiliary routine (version 1.1) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     October 31, 1992
*
*     .. Scalar Arguments ..
      INTEGER            J, JOB
      DOUBLE PRECISION   C, GAMMA, S, SEST, SESTPR
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   W( J ), X( J )
*     ..
*
*  Purpose
*  =======
*
*  DLAIC1 applies one step of incremental condition estimation in
*  its simplest version:
*
*  Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j
*  lower triangular matrix L, such that
*           twonorm(L*x) = sest
*  Then DLAIC1 computes sestpr, s, c such that
*  the vector
*                  [ s*x ]
*           xhat = [  c  ]
*  is an approximate singular vector of
*                  [ L     0  ]
*           Lhat = [ w' gamma ]
*  in the sense that
*           twonorm(Lhat*xhat) = sestpr.
*
*  Depending on JOB, an estimate for the largest or smallest singular
*  value is computed.
*
*  Note that [s c]' and sestpr**2 is an eigenpair of the system
*
*      diag(sest*sest, 0) + [alpha  gamma] * [ alpha ]
*                                            [ gamma ]
*
*  where  alpha =  x'*w.
*
*  Arguments
*  =========
*
*  JOB     (input) INTEGER
*          = 1: an estimate for the largest singular value is computed.
*          = 2: an estimate for the smallest singular value is computed.
*
*  J       (input) INTEGER
*          Length of X and W
*
*  X       (input) DOUBLE PRECISION array, dimension (J)
*          The j-vector x.
*
*  SEST    (input) DOUBLE PRECISION
*          Estimated singular value of j by j matrix L
*
*  W       (input) DOUBLE PRECISION array, dimension (J)
*          The j-vector w.
*
*  GAMMA   (input) DOUBLE PRECISION
*          The diagonal element gamma.
*
*  SEDTPR  (output) DOUBLE PRECISION
*          Estimated singular value of (j+1) by (j+1) matrix Lhat.
*
*  S       (output) DOUBLE PRECISION
*          Sine needed in forming xhat.
*
*  C       (output) DOUBLE PRECISION
*          Cosine needed in forming xhat.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
      DOUBLE PRECISION   HALF, FOUR
      PARAMETER          ( HALF = 0.5D0, FOUR = 4.0D0 )
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION   ABSALP, ABSEST, ABSGAM, ALPHA, B, COSINE, EPS,
     $                   NORMA, S1, S2, SINE, T, TEST, TMP, ZETA1, ZETA2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SIGN, SQRT
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DDOT, DLAMCH
      EXTERNAL           DDOT, DLAMCH
*     ..
*     .. Executable Statements ..
*
      EPS = DLAMCH( 'Epsilon' )
      ALPHA = DDOT( J, X, 1, W, 1 )
*
      ABSALP = ABS( ALPHA )
      ABSGAM = ABS( GAMMA )
      ABSEST = ABS( SEST )
*
      IF( JOB.EQ.1 ) THEN
*
*        Estimating largest singular value
*
*        special cases
*
         IF( SEST.EQ.ZERO ) THEN
            S1 = MAX( ABSGAM, ABSALP )
            IF( S1.EQ.ZERO ) THEN
               S = ZERO
               C = ONE
               SESTPR = ZERO
            ELSE
               S = ALPHA / S1
               C = GAMMA / S1
               TMP = SQRT( S*S+C*C )
               S = S / TMP
               C = C / TMP
               SESTPR = S1*TMP
            END IF
            RETURN
         ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN
            S = ONE
            C = ZERO
            TMP = MAX( ABSEST, ABSALP )
            S1 = ABSEST / TMP
            S2 = ABSALP / TMP
            SESTPR = TMP*SQRT( S1*S1+S2*S2 )
            RETURN
         ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN
            S1 = ABSGAM
            S2 = ABSEST
            IF( S1.LE.S2 ) THEN
               S = ONE
               C = ZERO
               SESTPR = S2
            ELSE
               S = ZERO
               C = ONE
               SESTPR = S1
            END IF
            RETURN
         ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN
            S1 = ABSGAM
            S2 = ABSALP
            IF( S1.LE.S2 ) THEN
               TMP = S1 / S2
               S = SQRT( ONE+TMP*TMP )
               SESTPR = S2*S
               C = ( GAMMA / S2 ) / S
               S = SIGN( ONE, ALPHA ) / S
            ELSE
               TMP = S2 / S1
               C = SQRT( ONE+TMP*TMP )
               SESTPR = S1*C
               S = ( ALPHA / S1 ) / C
               C = SIGN( ONE, GAMMA ) / C
            END IF
            RETURN
         ELSE
*
*           normal case
*
            ZETA1 = ALPHA / ABSEST
            ZETA2 = GAMMA / ABSEST
*
            B = ( ONE-ZETA1*ZETA1-ZETA2*ZETA2 )*HALF
            C = ZETA1*ZETA1
            IF( B.GT.ZERO ) THEN
               T = C / ( B+SQRT( B*B+C ) )
            ELSE
               T = SQRT( B*B+C ) - B
            END IF
*
            SINE = -ZETA1 / T
            COSINE = -ZETA2 / ( ONE+T )
            TMP = SQRT( SINE*SINE+COSINE*COSINE )
            S = SINE / TMP
            C = COSINE / TMP
            SESTPR = SQRT( T+ONE )*ABSEST
            RETURN
         END IF
*
      ELSE IF( JOB.EQ.2 ) THEN
*
*        Estimating smallest singular value
*
*        special cases
*
         IF( SEST.EQ.ZERO ) THEN
            SESTPR = ZERO
            IF( MAX( ABSGAM, ABSALP ).EQ.ZERO ) THEN
               SINE = ONE
               COSINE = ZERO
            ELSE
               SINE = -GAMMA
               COSINE = ALPHA
            END IF
            S1 = MAX( ABS( SINE ), ABS( COSINE ) )
            S = SINE / S1
            C = COSINE / S1
            TMP = SQRT( S*S+C*C )
            S = S / TMP
            C = C / TMP
            RETURN
         ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN
            S = ZERO
            C = ONE
            SESTPR = ABSGAM
            RETURN
         ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN
            S1 = ABSGAM
            S2 = ABSEST
            IF( S1.LE.S2 ) THEN
               S = ZERO
               C = ONE
               SESTPR = S1
            ELSE
               S = ONE
               C = ZERO
               SESTPR = S2
            END IF
            RETURN
         ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN
            S1 = ABSGAM
            S2 = ABSALP
            IF( S1.LE.S2 ) THEN
               TMP = S1 / S2
               C = SQRT( ONE+TMP*TMP )
               SESTPR = ABSEST*( TMP / C )
               S = -( GAMMA / S2 ) / C
               C = SIGN( ONE, ALPHA ) / C
            ELSE
               TMP = S2 / S1
               S = SQRT( ONE+TMP*TMP )
               SESTPR = ABSEST / S
               C = ( ALPHA / S1 ) / S
               S = -SIGN( ONE, GAMMA ) / S
            END IF
            RETURN
         ELSE
*
*           normal case
*
            ZETA1 = ALPHA / ABSEST
            ZETA2 = GAMMA / ABSEST
*
            NORMA = MAX( ONE+ZETA1*ZETA1+ABS( ZETA1*ZETA2 ),
     $              ABS( ZETA1*ZETA2 )+ZETA2*ZETA2 )
*
*           See if root is closer to zero or to ONE
*
            TEST = ONE + TWO*( ZETA1-ZETA2 )*( ZETA1+ZETA2 )
            IF( TEST.GE.ZERO ) THEN
*
*              root is close to zero, compute directly
*
               B = ( ZETA1*ZETA1+ZETA2*ZETA2+ONE )*HALF
               C = ZETA2*ZETA2
               T = C / ( B+SQRT( ABS( B*B-C ) ) )
               SINE = ZETA1 / ( ONE-T )
               COSINE = -ZETA2 / T
               SESTPR = SQRT( T+FOUR*EPS*EPS*NORMA )*ABSEST
            ELSE
*
*              root is closer to ONE, shift by that amount
*
               B = ( ZETA2*ZETA2+ZETA1*ZETA1-ONE )*HALF
               C = ZETA1*ZETA1
               IF( B.GE.ZERO ) THEN
                  T = -C / ( B+SQRT( B*B+C ) )
               ELSE
                  T = B - SQRT( B*B+C )
               END IF
               SINE = -ZETA1 / T
               COSINE = -ZETA2 / ( ONE+T )
               SESTPR = SQRT( ONE+T+FOUR*EPS*EPS*NORMA )*ABSEST
            END IF
            TMP = SQRT( SINE*SINE+COSINE*COSINE )
            S = SINE / TMP
            C = COSINE / TMP
            RETURN
*
         END IF
      END IF
      RETURN
*
*     End of DLAIC1
*
      END
      DOUBLE PRECISION FUNCTION DLAMCH( CMACH )
*
*  -- LAPACK auxiliary routine (version 1.1) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     October 31, 1992
*
*     .. Scalar Arguments ..
      CHARACTER          CMACH
*     ..
*
*  Purpose
*  =======
*
*  DLAMCH determines double precision machine parameters.
*
*  Arguments
*  =========
*
*  CMACH   (input) CHARACTER*1
*          Specifies the value to be returned by DLAMCH:
*          = 'E' or 'e',   DLAMCH := eps
*          = 'S' or 's ,   DLAMCH := sfmin
*          = 'B' or 'b',   DLAMCH := base
*          = 'P' or 'p',   DLAMCH := eps*base
*          = 'N' or 'n',   DLAMCH := t
*          = 'R' or 'r',   DLAMCH := rnd
*          = 'M' or 'm',   DLAMCH := emin
*          = 'U' or 'u',   DLAMCH := rmin
*          = 'L' or 'l',   DLAMCH := emax
*          = 'O' or 'o',   DLAMCH := rmax
*
*          where
*
*          eps   = relative machine precision
*          sfmin = safe minimum, such that 1/sfmin does not overflow
*          base  = base of the machine
*          prec  = eps*base
*          t     = number of (base) digits in the mantissa
*          rnd   = 1.0 when rounding occurs in addition, 0.0 otherwise
*          emin  = minimum exponent before (gradual) underflow
*          rmin  = underflow threshold - base**(emin-1)
*          emax  = largest exponent before overflow
*          rmax  = overflow threshold  - (base**emax)*(1-eps)
*
* =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            FIRST, LRND
      INTEGER            BETA, IMAX, IMIN, IT
      DOUBLE PRECISION   BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN,
     $                   RND, SFMIN, SMALL, T
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLAMC2
*     ..
*     .. Save statement ..
      SAVE               FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN,
     $                   EMAX, RMAX, PREC
*     ..
*     .. Data statements ..
      DATA               FIRST / .TRUE. /
*     ..
*     .. Executable Statements ..
*
      IF( FIRST ) THEN
         FIRST = .FALSE.
         CALL DLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX )
         BASE = BETA
         T = IT
         IF( LRND ) THEN
            RND = ONE
            EPS = ( BASE**( 1-IT ) ) / 2
         ELSE
            RND = ZERO
            EPS = BASE**( 1-IT )
         END IF
         PREC = EPS*BASE
         EMIN = IMIN
         EMAX = IMAX
         SFMIN = RMIN
         SMALL = ONE / RMAX
         IF( SMALL.GE.SFMIN ) THEN
*
*           Use SMALL plus a bit, to avoid the possibility of rounding
*           causing overflow when computing  1/sfmin.
*
            SFMIN = SMALL*( ONE+EPS )
         END IF
      END IF
*
      IF( LSAME( CMACH, 'E' ) ) THEN
         RMACH = EPS
      ELSE IF( LSAME( CMACH, 'S' ) ) THEN
         RMACH = SFMIN
      ELSE IF( LSAME( CMACH, 'B' ) ) THEN
         RMACH = BASE
      ELSE IF( LSAME( CMACH, 'P' ) ) THEN
         RMACH = PREC
      ELSE IF( LSAME( CMACH, 'N' ) ) THEN
         RMACH = T
      ELSE IF( LSAME( CMACH, 'R' ) ) THEN
         RMACH = RND
      ELSE IF( LSAME( CMACH, 'M' ) ) THEN
         RMACH = EMIN
      ELSE IF( LSAME( CMACH, 'U' ) ) THEN
         RMACH = RMIN
      ELSE IF( LSAME( CMACH, 'L' ) ) THEN
         RMACH = EMAX
      ELSE IF( LSAME( CMACH, 'O' ) ) THEN
         RMACH = RMAX
      END IF
*
      DLAMCH = RMACH
      RETURN
*
*     End of DLAMCH
*
      END
*
************************************************************************
*
      SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 )
*
*  -- LAPACK auxiliary routine (version 1.1) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     October 31, 1992
*
*     .. Scalar Arguments ..
      LOGICAL            IEEE1, RND
      INTEGER            BETA, T
*     ..
*
*  Purpose
*  =======
*
*  DLAMC1 determines the machine parameters given by BETA, T, RND, and
*  IEEE1.
*
*  Arguments
*  =========
*
*  BETA    (output) INTEGER
*          The base of the machine.
*
*  T       (output) INTEGER
*          The number of ( BETA ) digits in the mantissa.
*
*  RND     (output) LOGICAL
*          Specifies whether proper rounding  ( RND = .TRUE. )  or
*          chopping  ( RND = .FALSE. )  occurs in addition. This may not
*          be a reliable guide to the way in which the machine performs
*          its arithmetic.
*
*  IEEE1   (output) LOGICAL
*          Specifies whether rounding appears to be done in the IEEE
*          'round to nearest' style.
*
*  Further Details
*  ===============
*
*  The routine is based on the routine  ENVRON  by Malcolm and
*  incorporates suggestions by Gentleman and Marovich. See
*
*     Malcolm M. A. (1972) Algorithms to reveal properties of
*        floating-point arithmetic. Comms. of the ACM, 15, 949-951.
*
*     Gentleman W. M. and Marovich S. B. (1974) More on algorithms
*        that reveal properties of floating point arithmetic units.
*        Comms. of the ACM, 17, 276-277.
*
* =====================================================================
*
*     .. Local Scalars ..
      LOGICAL            FIRST, LIEEE1, LRND
      INTEGER            LBETA, LT
      DOUBLE PRECISION   A, B, C, F, ONE, QTR, SAVEC, T1, T2
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMC3
      EXTERNAL           DLAMC3
*     ..
*     .. Save statement ..
      SAVE               FIRST, LIEEE1, LBETA, LRND, LT
*     ..
*     .. Data statements ..
      DATA               FIRST / .TRUE. /
*     ..
*     .. Executable Statements ..
*
      IF( FIRST ) THEN
         FIRST = .FALSE.
         ONE = 1
*
*        LBETA,  LIEEE1,  LT and  LRND  are the  local values  of  BETA,
*        IEEE1, T and RND.
*
*        Throughout this routine  we use the function  DLAMC3  to ensure
*        that relevant values are  stored and not held in registers,  or
*        are not affected by optimizers.
*
*        Compute  a = 2.0**m  with the  smallest positive integer m such
*        that
*
*           fl( a + 1.0 ) = a.
*
         A = 1
         C = 1
*
*+       WHILE( C.EQ.ONE )LOOP
   10    CONTINUE
         IF( C.EQ.ONE ) THEN
            A = 2*A
            C = DLAMC3( A, ONE )
            C = DLAMC3( C, -A )
            GO TO 10
         END IF
*+       END WHILE
*
*        Now compute  b = 2.0**m  with the smallest positive integer m
*        such that
*
*           fl( a + b ) .gt. a.
*
         B = 1
         C = DLAMC3( A, B )
*
*+       WHILE( C.EQ.A )LOOP
   20    CONTINUE
         IF( C.EQ.A ) THEN
            B = 2*B
            C = DLAMC3( A, B )
            GO TO 20
         END IF
*+       END WHILE
*
*        Now compute the base.  a and c  are neighbouring floating point
*        numbers  in the  interval  ( beta**t, beta**( t + 1 ) )  and so
*        their difference is beta. Adding 0.25 to c is to ensure that it
*        is truncated to beta and not ( beta - 1 ).
*
         QTR = ONE / 4
         SAVEC = C
         C = DLAMC3( C, -A )
         LBETA = C + QTR
*
*        Now determine whether rounding or chopping occurs,  by adding a
*        bit  less  than  beta/2  and a  bit  more  than  beta/2  to  a.
*
         B = LBETA
         F = DLAMC3( B / 2, -B / 100 )
         C = DLAMC3( F, A )
         IF( C.EQ.A ) THEN
            LRND = .TRUE.
         ELSE
            LRND = .FALSE.
         END IF
         F = DLAMC3( B / 2, B / 100 )
         C = DLAMC3( F, A )
         IF( ( LRND ) .AND. ( C.EQ.A ) )
     $      LRND = .FALSE.
*
*        Try and decide whether rounding is done in the  IEEE  'round to
*        nearest' style. B/2 is half a unit in the last place of the two
*        numbers A and SAVEC. Furthermore, A is even, i.e. has last  bit
*        zero, and SAVEC is odd. Thus adding B/2 to A should not  change
*        A, but adding B/2 to SAVEC should change SAVEC.
*
         T1 = DLAMC3( B / 2, A )
         T2 = DLAMC3( B / 2, SAVEC )
         LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND
*
*        Now find  the  mantissa, t.  It should  be the  integer part of
*        log to the base beta of a,  however it is safer to determine  t
*        by powering.  So we find t as the smallest positive integer for
*        which
*
*           fl( beta**t + 1.0 ) = 1.0.
*
         LT = 0
         A = 1
         C = 1
*
*+       WHILE( C.EQ.ONE )LOOP
   30    CONTINUE
         IF( C.EQ.ONE ) THEN
            LT = LT + 1
            A = A*LBETA
            C = DLAMC3( A, ONE )
            C = DLAMC3( C, -A )
            GO TO 30
         END IF
*+       END WHILE
*
      END IF
*
      BETA = LBETA
      T = LT
      RND = LRND
      IEEE1 = LIEEE1
      RETURN
*
*     End of DLAMC1
*
      END
*
************************************************************************
*
      SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX )
*
*  -- LAPACK auxiliary routine (version 1.1) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     October 31, 1992
*
*     .. Scalar Arguments ..
      LOGICAL            RND
      INTEGER            BETA, EMAX, EMIN, T
      DOUBLE PRECISION   EPS, RMAX, RMIN
*     ..
*
*  Purpose
*  =======
*
*  DLAMC2 determines the machine parameters specified in its argument
*  list.
*
*  Arguments
*  =========
*
*  BETA    (output) INTEGER
*          The base of the machine.
*
*  T       (output) INTEGER
*          The number of ( BETA ) digits in the mantissa.
*
*  RND     (output) LOGICAL
*          Specifies whether proper rounding  ( RND = .TRUE. )  or
*          chopping  ( RND = .FALSE. )  occurs in addition. This may not
*          be a reliable guide to the way in which the machine performs
*          its arithmetic.
*
*  EPS     (output) DOUBLE PRECISION
*          The smallest positive number such that
*
*             fl( 1.0 - EPS ) .LT. 1.0,
*
*          where fl denotes the computed value.
*
*  EMIN    (output) INTEGER
*          The minimum exponent before (gradual) underflow occurs.
*
*  RMIN    (output) DOUBLE PRECISION
*          The smallest normalized number for the machine, given by
*          BASE**( EMIN - 1 ), where  BASE  is the floating point value
*          of BETA.
*
*  EMAX    (output) INTEGER
*          The maximum exponent before overflow occurs.
*
*  RMAX    (output) DOUBLE PRECISION
*          The largest positive number for the machine, given by
*          BASE**EMAX * ( 1 - EPS ), where  BASE  is the floating point
*          value of BETA.
*
*  Further Details
*  ===============
*
*  The computation of  EPS  is based on a routine PARANOIA by
*  W. Kahan of the University of California at Berkeley.
*
* =====================================================================
*
*     .. Local Scalars ..
      LOGICAL            FIRST, IEEE, IWARN, LIEEE1, LRND
      INTEGER            GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT,
     $                   NGNMIN, NGPMIN
      DOUBLE PRECISION   A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE,
     $                   SIXTH, SMALL, THIRD, TWO, ZERO
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMC3
      EXTERNAL           DLAMC3
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLAMC1, DLAMC4, DLAMC5
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
*     ..
*     .. Save statement ..
      SAVE               FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX,
     $                   LRMIN, LT
*     ..
*     .. Data statements ..
      DATA               FIRST / .TRUE. / , IWARN / .FALSE. /
*     ..
*     .. Executable Statements ..
*
      IF( FIRST ) THEN
         FIRST = .FALSE.
         ZERO = 0
         ONE = 1
         TWO = 2
*
*        LBETA, LT, LRND, LEPS, LEMIN and LRMIN  are the local values of
*        BETA, T, RND, EPS, EMIN and RMIN.
*
*        Throughout this routine  we use the function  DLAMC3  to ensure
*        that relevant values are stored  and not held in registers,  or
*        are not affected by optimizers.
*
*        DLAMC1 returns the parameters  LBETA, LT, LRND and LIEEE1.
*
         CALL DLAMC1( LBETA, LT, LRND, LIEEE1 )
*
*        Start to find EPS.
*
         B = LBETA
         A = B**( -LT )
         LEPS = A
*
*        Try some tricks to see whether or not this is the correct  EPS.
*
         B = TWO / 3
         HALF = ONE / 2
         SIXTH = DLAMC3( B, -HALF )
         THIRD = DLAMC3( SIXTH, SIXTH )
         B = DLAMC3( THIRD, -HALF )
         B = DLAMC3( B, SIXTH )
         B = ABS( B )
         IF( B.LT.LEPS )
     $      B = LEPS
*
         LEPS = 1
*
*+       WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP
   10    CONTINUE
         IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN
            LEPS = B
            C = DLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) )
            C = DLAMC3( HALF, -C )
            B = DLAMC3( HALF, C )
            C = DLAMC3( HALF, -B )
            B = DLAMC3( HALF, C )
            GO TO 10
         END IF
*+       END WHILE
*
         IF( A.LT.LEPS )
     $      LEPS = A
*
*        Computation of EPS complete.
*
*        Now find  EMIN.  Let A = + or - 1, and + or - (1 + BASE**(-3)).
*        Keep dividing  A by BETA until (gradual) underflow occurs. This
*        is detected when we cannot recover the previous A.
*
         RBASE = ONE / LBETA
         SMALL = ONE
         DO 20 I = 1, 3
            SMALL = DLAMC3( SMALL*RBASE, ZERO )
   20    CONTINUE
         A = DLAMC3( ONE, SMALL )
         CALL DLAMC4( NGPMIN, ONE, LBETA )
         CALL DLAMC4( NGNMIN, -ONE, LBETA )
         CALL DLAMC4( GPMIN, A, LBETA )
         CALL DLAMC4( GNMIN, -A, LBETA )
         IEEE = .FALSE.
*
         IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN
            IF( NGPMIN.EQ.GPMIN ) THEN
               LEMIN = NGPMIN
*            ( Non twos-complement machines, no gradual underflow;
*              e.g.,  VAX )
            ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN
               LEMIN = NGPMIN - 1 + LT
               IEEE = .TRUE.
*            ( Non twos-complement machines, with gradual underflow;
*              e.g., IEEE standard followers )
            ELSE
               LEMIN = MIN( NGPMIN, GPMIN )
*            ( A guess; no known machine )
               IWARN = .TRUE.
            END IF
*
         ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN
            IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN
               LEMIN = MAX( NGPMIN, NGNMIN )
*            ( Twos-complement machines, no gradual underflow;
*              e.g., CYBER 205 )
            ELSE
               LEMIN = MIN( NGPMIN, NGNMIN )
*            ( A guess; no known machine )
               IWARN = .TRUE.
            END IF
*
         ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND.
     $            ( GPMIN.EQ.GNMIN ) ) THEN
            IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN
               LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT
*            ( Twos-complement machines with gradual underflow;
*              no known machine )
            ELSE
               LEMIN = MIN( NGPMIN, NGNMIN )
*            ( A guess; no known machine )
               IWARN = .TRUE.
            END IF
*
         ELSE
            LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN )
*         ( A guess; no known machine )
            IWARN = .TRUE.
         END IF
***
* Comment out this if block if EMIN is ok
         IF( IWARN ) THEN
            FIRST = .TRUE.
            WRITE( 6, FMT = 9999 )LEMIN
         END IF
***
*
*        Assume IEEE arithmetic if we found denormalised  numbers above,
*        or if arithmetic seems to round in the  IEEE style,  determined
*        in routine DLAMC1. A true IEEE machine should have both  things
*        true; however, faulty machines may have one or the other.
*
         IEEE = IEEE .OR. LIEEE1
*
*        Compute  RMIN by successive division by  BETA. We could compute
*        RMIN as BASE**( EMIN - 1 ),  but some machines underflow during
*        this computation.
*
         LRMIN = 1
         DO 30 I = 1, 1 - LEMIN
            LRMIN = DLAMC3( LRMIN*RBASE, ZERO )
   30    CONTINUE
*
*        Finally, call DLAMC5 to compute EMAX and RMAX.
*
         CALL DLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX )
      END IF
*
      BETA = LBETA
      T = LT
      RND = LRND
      EPS = LEPS
      EMIN = LEMIN
      RMIN = LRMIN
      EMAX = LEMAX
      RMAX = LRMAX
*
      RETURN
*
 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-',
     $      '  EMIN = ', I8, /
     $      ' If, after inspection, the value EMIN looks',
     $      ' acceptable please comment out ',
     $      / ' the IF block as marked within the code of routine',
     $      ' DLAMC2,', / ' otherwise supply EMIN explicitly.', / )
*
*     End of DLAMC2
*
      END
*
************************************************************************
*
      DOUBLE PRECISION FUNCTION DLAMC3( A, B )
*
*  -- LAPACK auxiliary routine (version 1.1) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     October 31, 1992
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION   A, B
*     ..
*
*  Purpose
*  =======
*
*  DLAMC3  is intended to force  A  and  B  to be stored prior to doing
*  the addition of  A  and  B ,  for use in situations where optimizers
*  might hold one of these in a register.
*
*  Arguments
*  =========
*
*  A, B    (input) DOUBLE PRECISION
*          The values A and B.
*
* =====================================================================
*
*     .. Executable Statements ..
*
      DLAMC3 = A + B
*
      RETURN
*
*     End of DLAMC3
*
      END
*
************************************************************************
*
      SUBROUTINE DLAMC4( EMIN, START, BASE )
*
*  -- LAPACK auxiliary routine (version 1.1) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     October 31, 1992
*
*     .. Scalar Arguments ..
      INTEGER            BASE, EMIN
      DOUBLE PRECISION   START
*     ..
*
*  Purpose
*  =======
*
*  DLAMC4 is a service routine for DLAMC2.
*
*  Arguments
*  =========
*
*  EMIN    (output) EMIN
*          The minimum exponent before (gradual) underflow, computed by
*          setting A = START and dividing by BASE until the previous A
*          can not be recovered.
*
*  START   (input) DOUBLE PRECISION
*          The starting point for determining EMIN.
*
*  BASE    (input) INTEGER
*          The base of the machine.
*
* =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I
      DOUBLE PRECISION   A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMC3
      EXTERNAL           DLAMC3
*     ..
*     .. Executable Statements ..
*
      A = START
      ONE = 1
      RBASE = ONE / BASE
      ZERO = 0
      EMIN = 1
      B1 = DLAMC3( A*RBASE, ZERO )
      C1 = A
      C2 = A
      D1 = A
      D2 = A
*+    WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND.
*    $       ( D1.EQ.A ).AND.( D2.EQ.A )      )LOOP
   10 CONTINUE
      IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND.
     $    ( D2.EQ.A ) ) THEN
         EMIN = EMIN - 1
         A = B1
         B1 = DLAMC3( A / BASE, ZERO )
         C1 = DLAMC3( B1*BASE, ZERO )
         D1 = ZERO
         DO 20 I = 1, BASE
            D1 = D1 + B1
   20    CONTINUE
         B2 = DLAMC3( A*RBASE, ZERO )
         C2 = DLAMC3( B2 / RBASE, ZERO )
         D2 = ZERO
         DO 30 I = 1, BASE
            D2 = D2 + B2
   30    CONTINUE
         GO TO 10
      END IF
*+    END WHILE
*
      RETURN
*
*     End of DLAMC4
*
      END
*
************************************************************************
*
      SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX )
*
*  -- LAPACK auxiliary routine (version 1.1) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     October 31, 1992
*
*     .. Scalar Arguments ..
      LOGICAL            IEEE
      INTEGER            BETA, EMAX, EMIN, P
      DOUBLE PRECISION   RMAX
*     ..
*
*  Purpose
*  =======
*
*  DLAMC5 attempts to compute RMAX, the largest machine floating-point
*  number, without overflow.  It assumes that EMAX + abs(EMIN) sum
*  approximately to a power of 2.  It will fail on machines where this
*  assumption does not hold, for example, the Cyber 205 (EMIN = -28625,
*  EMAX = 28718).  It will also fail if the value supplied for EMIN is
*  too large (i.e. too close to zero), probably with overflow.
*
*  Arguments
*  =========
*
*  BETA    (input) INTEGER
*          The base of floating-point arithmetic.
*
*  P       (input) INTEGER
*          The number of base BETA digits in the mantissa of a
*          floating-point value.
*
*  EMIN    (input) INTEGER
*          The minimum exponent before (gradual) underflow.
*
*  IEEE    (input) LOGICAL
*          A logical flag specifying whether or not the arithmetic
*          system is thought to comply with the IEEE standard.
*
*  EMAX    (output) INTEGER
*          The largest exponent before overflow
*
*  RMAX    (output) DOUBLE PRECISION
*          The largest machine floating-point number.
*
* =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
*     ..
*     .. Local Scalars ..
      INTEGER            EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP
      DOUBLE PRECISION   OLDY, RECBAS, Y, Z
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMC3
      EXTERNAL           DLAMC3
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MOD
*     ..
*     .. Executable Statements ..
*
*     First compute LEXP and UEXP, two powers of 2 that bound
*     abs(EMIN). We then assume that EMAX + abs(EMIN) will sum
*     approximately to the bound that is closest to abs(EMIN).
*     (EMAX is the exponent of the required number RMAX).
*
      LEXP = 1
      EXBITS = 1
   10 CONTINUE
      TRY = LEXP*2
      IF( TRY.LE.( -EMIN ) ) THEN
         LEXP = TRY
         EXBITS = EXBITS + 1
         GO TO 10
      END IF
      IF( LEXP.EQ.-EMIN ) THEN
         UEXP = LEXP
      ELSE
         UEXP = TRY
         EXBITS = EXBITS + 1
      END IF
*
*     Now -LEXP is less than or equal to EMIN, and -UEXP is greater
*     than or equal to EMIN. EXBITS is the number of bits needed to
*     store the exponent.
*
      IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN
         EXPSUM = 2*LEXP
      ELSE
         EXPSUM = 2*UEXP
      END IF
*
*     EXPSUM is the exponent range, approximately equal to
*     EMAX - EMIN + 1 .
*
      EMAX = EXPSUM + EMIN - 1
      NBITS = 1 + EXBITS + P
*
*     NBITS is the total number of bits needed to store a
*     floating-point number.
*
      IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN
*
*        Either there are an odd number of bits used to store a
*        floating-point number, which is unlikely, or some bits are
*        not used in the representation of numbers, which is possible,
*        (e.g. Cray machines) or the mantissa has an implicit bit,
*        (e.g. IEEE machines, Dec Vax machines), which is perhaps the
*        most likely. We have to assume the last alternative.
*        If this is true, then we need to reduce EMAX by one because
*        there must be some way of representing zero in an implicit-bit
*        system. On machines like Cray, we are reducing EMAX by one
*        unnecessarily.
*
         EMAX = EMAX - 1
      END IF
*
      IF( IEEE ) THEN
*
*        Assume we are on an IEEE machine which reserves one exponent
*        for infinity and NaN.
*
         EMAX = EMAX - 1
      END IF
*
*     Now create RMAX, the largest machine number, which should
*     be equal to (1.0 - BETA**(-P)) * BETA**EMAX .
*
*     First compute 1.0 - BETA**(-P), being careful that the
*     result is less than 1.0 .
*
      RECBAS = ONE / BETA
      Z = BETA - ONE
      Y = ZERO
      DO 20 I = 1, P
         Z = Z*RECBAS
         IF( Y.LT.ONE )
     $      OLDY = Y
         Y = DLAMC3( Y, Z )
   20 CONTINUE
      IF( Y.GE.ONE )
     $   Y = OLDY
*
*     Now multiply by BETA**EMAX to get RMAX.
*
      DO 30 I = 1, EMAX
         Y = DLAMC3( Y*BETA, ZERO )
   30 CONTINUE
*
      RMAX = Y
      RETURN
*
*     End of DLAMC5
*
      END
      DOUBLE PRECISION FUNCTION DLAPY2( X, Y )
*
*  -- LAPACK auxiliary routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     October 31, 1992
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION   X, Y
*     ..
*
*  Purpose
*  =======
*
*  DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary
*  overflow.
*
*  Arguments
*  =========
*
*  X       (input) DOUBLE PRECISION
*  Y       (input) DOUBLE PRECISION
*          X and Y specify the values x and y.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D0 )
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION   W, XABS, YABS, Z
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, SQRT
*     ..
*     .. Executable Statements ..
*
      XABS = ABS( X )
      YABS = ABS( Y )
      W = MAX( XABS, YABS )
      Z = MIN( XABS, YABS )
      IF( Z.EQ.ZERO ) THEN
         DLAPY2 = W
      ELSE
         DLAPY2 = W*SQRT( ONE+( Z / W )**2 )
      END IF
      RETURN
*
*     End of DLAPY2
*
      END
      SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
*
*  -- LAPACK auxiliary routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      CHARACTER          SIDE
      INTEGER            INCV, LDC, M, N
      DOUBLE PRECISION   TAU
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   C( LDC, * ), V( * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DLARF applies a real elementary reflector H to a real m by n matrix
*  C, from either the left or the right. H is represented in the form
*
*        H = I - tau * v * v'
*
*  where tau is a real scalar and v is a real vector.
*
*  If tau = 0, then H is taken to be the unit matrix.
*
*  Arguments
*  =========
*
*  SIDE    (input) CHARACTER*1
*          = 'L': form  H * C
*          = 'R': form  C * H
*
*  M       (input) INTEGER
*          The number of rows of the matrix C.
*
*  N       (input) INTEGER
*          The number of columns of the matrix C.
*
*  V       (input) DOUBLE PRECISION array, dimension
*                     (1 + (M-1)*abs(INCV)) if SIDE = 'L'
*                  or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
*          The vector v in the representation of H. V is not used if
*          TAU = 0.
*
*  INCV    (input) INTEGER
*          The increment between elements of v. INCV <> 0.
*
*  TAU     (input) DOUBLE PRECISION
*          The value tau in the representation of H.
*
*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
*          On entry, the m by n matrix C.
*          On exit, C is overwritten by the matrix H * C if SIDE = 'L',
*          or C * H if SIDE = 'R'.
*
*  LDC     (input) INTEGER
*          The leading dimension of the array C. LDC >= max(1,M).
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension
*                         (N) if SIDE = 'L'
*                      or (M) if SIDE = 'R'
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGEMV, DGER
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. Executable Statements ..
*
      IF( LSAME( SIDE, 'L' ) ) THEN
*
*        Form  H * C
*
         IF( TAU.NE.ZERO ) THEN
*
*           w := C' * v
*
            CALL DGEMV( 'Transpose', M, N, ONE, C, LDC, V, INCV, ZERO,
     $                  WORK, 1 )
*
*           C := C - v * w'
*
            CALL DGER( M, N, -TAU, V, INCV, WORK, 1, C, LDC )
         END IF
      ELSE
*
*        Form  C * H
*
         IF( TAU.NE.ZERO ) THEN
*
*           w := C * v
*
            CALL DGEMV( 'No transpose', M, N, ONE, C, LDC, V, INCV,
     $                  ZERO, WORK, 1 )
*
*           C := C - w * v'
*
            CALL DGER( M, N, -TAU, WORK, 1, V, INCV, C, LDC )
         END IF
      END IF
      RETURN
*
*     End of DLARF
*
      END
      SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
     $                   T, LDT, C, LDC, WORK, LDWORK )
*
*  -- LAPACK auxiliary routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      CHARACTER          DIRECT, SIDE, STOREV, TRANS
      INTEGER            K, LDC, LDT, LDV, LDWORK, M, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   C( LDC, * ), T( LDT, * ), V( LDV, * ),
     $                   WORK( LDWORK, * )
*     ..
*
*  Purpose
*  =======
*
*  DLARFB applies a real block reflector H or its transpose H' to a
*  real m by n matrix C, from either the left or the right.
*
*  Arguments
*  =========
*
*  SIDE    (input) CHARACTER*1
*          = 'L': apply H or H' from the Left
*          = 'R': apply H or H' from the Right
*
*  TRANS   (input) CHARACTER*1
*          = 'N': apply H (No transpose)
*          = 'T': apply H' (Transpose)
*
*  DIRECT  (input) CHARACTER*1
*          Indicates how H is formed from a product of elementary
*          reflectors
*          = 'F': H = H(1) H(2) . . . H(k) (Forward)
*          = 'B': H = H(k) . . . H(2) H(1) (Backward)
*
*  STOREV  (input) CHARACTER*1
*          Indicates how the vectors which define the elementary
*          reflectors are stored:
*          = 'C': Columnwise
*          = 'R': Rowwise
*
*  M       (input) INTEGER
*          The number of rows of the matrix C.
*
*  N       (input) INTEGER
*          The number of columns of the matrix C.
*
*  K       (input) INTEGER
*          The order of the matrix T (= the number of elementary
*          reflectors whose product defines the block reflector).
*
*  V       (input) DOUBLE PRECISION array, dimension
*                                (LDV,K) if STOREV = 'C'
*                                (LDV,M) if STOREV = 'R' and SIDE = 'L'
*                                (LDV,N) if STOREV = 'R' and SIDE = 'R'
*          The matrix V. See further details.
*
*  LDV     (input) INTEGER
*          The leading dimension of the array V.
*          If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
*          if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
*          if STOREV = 'R', LDV >= K.
*
*  T       (input) DOUBLE PRECISION array, dimension (LDT,K)
*          The triangular k by k matrix T in the representation of the
*          block reflector.
*
*  LDT     (input) INTEGER
*          The leading dimension of the array T. LDT >= K.
*
*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
*          On entry, the m by n matrix C.
*          On exit, C is overwritten by H*C or H'*C or C*H or C*H'.
*
*  LDC     (input) INTEGER
*          The leading dimension of the array C. LDA >= max(1,M).
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (LDWORK,K)
*
*  LDWORK  (input) INTEGER
*          The leading dimension of the array WORK.
*          If SIDE = 'L', LDWORK >= max(1,N);
*          if SIDE = 'R', LDWORK >= max(1,M).
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      CHARACTER          TRANST
      INTEGER            I, J
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEMM, DTRMM
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
      IF( M.LE.0 .OR. N.LE.0 )
     $   RETURN
*
      IF( LSAME( TRANS, 'N' ) ) THEN
         TRANST = 'T'
      ELSE
         TRANST = 'N'
      END IF
*
      IF( LSAME( STOREV, 'C' ) ) THEN
*
         IF( LSAME( DIRECT, 'F' ) ) THEN
*
*           Let  V =  ( V1 )    (first K rows)
*                     ( V2 )
*           where  V1  is unit lower triangular.
*
            IF( LSAME( SIDE, 'L' ) ) THEN
*
*              Form  H * C  or  H' * C  where  C = ( C1 )
*                                                  ( C2 )
*
*              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)
*
*              W := C1'
*
               DO 10 J = 1, K
                  CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
   10          CONTINUE
*
*              W := W * V1
*
               CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
     $                     K, ONE, V, LDV, WORK, LDWORK )
               IF( M.GT.K ) THEN
*
*                 W := W + C2'*V2
*
                  CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K,
     $                        ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV,
     $                        ONE, WORK, LDWORK )
               END IF
*
*              W := W * T'  or  W * T
*
               CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
     $                     ONE, T, LDT, WORK, LDWORK )
*
*              C := C - V * W'
*
               IF( M.GT.K ) THEN
*
*                 C2 := C2 - V2 * W'
*
                  CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K,
     $                        -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE,
     $                        C( K+1, 1 ), LDC )
               END IF
*
*              W := W * V1'
*
               CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
     $                     ONE, V, LDV, WORK, LDWORK )
*
*              C1 := C1 - W'
*
               DO 30 J = 1, K
                  DO 20 I = 1, N
                     C( J, I ) = C( J, I ) - WORK( I, J )
   20             CONTINUE
   30          CONTINUE
*
            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
*              Form  C * H  or  C * H'  where  C = ( C1  C2 )
*
*              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
*
*              W := C1
*
               DO 40 J = 1, K
                  CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
   40          CONTINUE
*
*              W := W * V1
*
               CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
     $                     K, ONE, V, LDV, WORK, LDWORK )
               IF( N.GT.K ) THEN
*
*                 W := W + C2 * V2
*
                  CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K,
     $                        ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
     $                        ONE, WORK, LDWORK )
               END IF
*
*              W := W * T  or  W * T'
*
               CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
     $                     ONE, T, LDT, WORK, LDWORK )
*
*              C := C - W * V'
*
               IF( N.GT.K ) THEN
*
*                 C2 := C2 - W * V2'
*
                  CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K,
     $                        -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE,
     $                        C( 1, K+1 ), LDC )
               END IF
*
*              W := W * V1'
*
               CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K,
     $                     ONE, V, LDV, WORK, LDWORK )
*
*              C1 := C1 - W
*
               DO 60 J = 1, K
                  DO 50 I = 1, M
                     C( I, J ) = C( I, J ) - WORK( I, J )
   50             CONTINUE
   60          CONTINUE
            END IF
*
         ELSE
*
*           Let  V =  ( V1 )
*                     ( V2 )    (last K rows)
*           where  V2  is unit upper triangular.
*
            IF( LSAME( SIDE, 'L' ) ) THEN
*
*              Form  H * C  or  H' * C  where  C = ( C1 )
*                                                  ( C2 )
*
*              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)
*
*              W := C2'
*
               DO 70 J = 1, K
                  CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
   70          CONTINUE
*
*              W := W * V2
*
               CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
     $                     K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
               IF( M.GT.K ) THEN
*
*                 W := W + C1'*V1
*
                  CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K,
     $                        ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
               END IF
*
*              W := W * T'  or  W * T
*
               CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
     $                     ONE, T, LDT, WORK, LDWORK )
*
*              C := C - V * W'
*
               IF( M.GT.K ) THEN
*
*                 C1 := C1 - V1 * W'
*
                  CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K,
     $                        -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC )
               END IF
*
*              W := W * V2'
*
               CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
     $                     ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
*
*              C2 := C2 - W'
*
               DO 90 J = 1, K
                  DO 80 I = 1, N
                     C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
   80             CONTINUE
   90          CONTINUE
*
            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
*              Form  C * H  or  C * H'  where  C = ( C1  C2 )
*
*              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
*
*              W := C2
*
               DO 100 J = 1, K
                  CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
  100          CONTINUE
*
*              W := W * V2
*
               CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
     $                     K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
               IF( N.GT.K ) THEN
*
*                 W := W + C1 * V1
*
                  CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K,
     $                        ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
               END IF
*
*              W := W * T  or  W * T'
*
               CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
     $                     ONE, T, LDT, WORK, LDWORK )
*
*              C := C - W * V'
*
               IF( N.GT.K ) THEN
*
*                 C1 := C1 - W * V1'
*
                  CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K,
     $                        -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
               END IF
*
*              W := W * V2'
*
               CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K,
     $                     ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
*
*              C2 := C2 - W
*
               DO 120 J = 1, K
                  DO 110 I = 1, M
                     C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
  110             CONTINUE
  120          CONTINUE
            END IF
         END IF
*
      ELSE IF( LSAME( STOREV, 'R' ) ) THEN
*
         IF( LSAME( DIRECT, 'F' ) ) THEN
*
*           Let  V =  ( V1  V2 )    (V1: first K columns)
*           where  V1  is unit upper triangular.
*
            IF( LSAME( SIDE, 'L' ) ) THEN
*
*              Form  H * C  or  H' * C  where  C = ( C1 )
*                                                  ( C2 )
*
*              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)
*
*              W := C1'
*
               DO 130 J = 1, K
                  CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
  130          CONTINUE
*
*              W := W * V1'
*
               CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
     $                     ONE, V, LDV, WORK, LDWORK )
               IF( M.GT.K ) THEN
*
*                 W := W + C2'*V2'
*
                  CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
     $                        C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE,
     $                        WORK, LDWORK )
               END IF
*
*              W := W * T'  or  W * T
*
               CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
     $                     ONE, T, LDT, WORK, LDWORK )
*
*              C := C - V' * W'
*
               IF( M.GT.K ) THEN
*
*                 C2 := C2 - V2' * W'
*
                  CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE,
     $                        V( 1, K+1 ), LDV, WORK, LDWORK, ONE,
     $                        C( K+1, 1 ), LDC )
               END IF
*
*              W := W * V1
*
               CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
     $                     K, ONE, V, LDV, WORK, LDWORK )
*
*              C1 := C1 - W'
*
               DO 150 J = 1, K
                  DO 140 I = 1, N
                     C( J, I ) = C( J, I ) - WORK( I, J )
  140             CONTINUE
  150          CONTINUE
*
            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
*              Form  C * H  or  C * H'  where  C = ( C1  C2 )
*
*              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)
*
*              W := C1
*
               DO 160 J = 1, K
                  CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
  160          CONTINUE
*
*              W := W * V1'
*
               CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K,
     $                     ONE, V, LDV, WORK, LDWORK )
               IF( N.GT.K ) THEN
*
*                 W := W + C2 * V2'
*
                  CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K,
     $                        ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV,
     $                        ONE, WORK, LDWORK )
               END IF
*
*              W := W * T  or  W * T'
*
               CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
     $                     ONE, T, LDT, WORK, LDWORK )
*
*              C := C - W * V
*
               IF( N.GT.K ) THEN
*
*                 C2 := C2 - W * V2
*
                  CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K,
     $                        -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE,
     $                        C( 1, K+1 ), LDC )
               END IF
*
*              W := W * V1
*
               CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
     $                     K, ONE, V, LDV, WORK, LDWORK )
*
*              C1 := C1 - W
*
               DO 180 J = 1, K
                  DO 170 I = 1, M
                     C( I, J ) = C( I, J ) - WORK( I, J )
  170             CONTINUE
  180          CONTINUE
*
            END IF
*
         ELSE
*
*           Let  V =  ( V1  V2 )    (V2: last K columns)
*           where  V2  is unit lower triangular.
*
            IF( LSAME( SIDE, 'L' ) ) THEN
*
*              Form  H * C  or  H' * C  where  C = ( C1 )
*                                                  ( C2 )
*
*              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)
*
*              W := C2'
*
               DO 190 J = 1, K
                  CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
  190          CONTINUE
*
*              W := W * V2'
*
               CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
     $                     ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
               IF( M.GT.K ) THEN
*
*                 W := W + C1'*V1'
*
                  CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
     $                        C, LDC, V, LDV, ONE, WORK, LDWORK )
               END IF
*
*              W := W * T'  or  W * T
*
               CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
     $                     ONE, T, LDT, WORK, LDWORK )
*
*              C := C - V' * W'
*
               IF( M.GT.K ) THEN
*
*                 C1 := C1 - V1' * W'
*
                  CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE,
     $                        V, LDV, WORK, LDWORK, ONE, C, LDC )
               END IF
*
*              W := W * V2
*
               CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
     $                     K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
*
*              C2 := C2 - W'
*
               DO 210 J = 1, K
                  DO 200 I = 1, N
                     C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
  200             CONTINUE
  210          CONTINUE
*
            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
*
*              Form  C * H  or  C * H'  where  C = ( C1  C2 )
*
*              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)
*
*              W := C2
*
               DO 220 J = 1, K
                  CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
  220          CONTINUE
*
*              W := W * V2'
*
               CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K,
     $                     ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
               IF( N.GT.K ) THEN
*
*                 W := W + C1 * V1'
*
                  CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K,
     $                        ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
               END IF
*
*              W := W * T  or  W * T'
*
               CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
     $                     ONE, T, LDT, WORK, LDWORK )
*
*              C := C - W * V
*
               IF( N.GT.K ) THEN
*
*                 C1 := C1 - W * V1
*
                  CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K,
     $                        -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
               END IF
*
*              W := W * V2
*
               CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
     $                     K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
*
*              C1 := C1 - W
*
               DO 240 J = 1, K
                  DO 230 I = 1, M
                     C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
  230             CONTINUE
  240          CONTINUE
*
            END IF
*
         END IF
      END IF
*
      RETURN
*
*     End of DLARFB
*
      END
      SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU )
*
*  -- LAPACK auxiliary routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     September 30, 1994
*
*     .. Scalar Arguments ..
      INTEGER            INCX, N
      DOUBLE PRECISION   ALPHA, TAU
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   X( * )
*     ..
*
*  Purpose
*  =======
*
*  DLARFG generates a real elementary reflector H of order n, such
*  that
*
*        H * ( alpha ) = ( beta ),   H' * H = I.
*            (   x   )   (   0  )
*
*  where alpha and beta are scalars, and x is an (n-1)-element real
*  vector. H is represented in the form
*
*        H = I - tau * ( 1 ) * ( 1 v' ) ,
*                      ( v )
*
*  where tau is a real scalar and v is a real (n-1)-element
*  vector.
*
*  If the elements of x are all zero, then tau = 0 and H is taken to be
*  the unit matrix.
*
*  Otherwise  1 <= tau <= 2.
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The order of the elementary reflector.
*
*  ALPHA   (input/output) DOUBLE PRECISION
*          On entry, the value alpha.
*          On exit, it is overwritten with the value beta.
*
*  X       (input/output) DOUBLE PRECISION array, dimension
*                         (1+(N-2)*abs(INCX))
*          On entry, the vector x.
*          On exit, it is overwritten with the vector v.
*
*  INCX    (input) INTEGER
*          The increment between elements of X. INCX > 0.
*
*  TAU     (output) DOUBLE PRECISION
*          The value tau.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            J, KNT
      DOUBLE PRECISION   BETA, RSAFMN, SAFMIN, XNORM
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH, DLAPY2, DNRM2
      EXTERNAL           DLAMCH, DLAPY2, DNRM2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, SIGN
*     ..
*     .. External Subroutines ..
      EXTERNAL           DSCAL
*     ..
*     .. Executable Statements ..
*
      IF( N.LE.1 ) THEN
         TAU = ZERO
         RETURN
      END IF
*
      XNORM = DNRM2( N-1, X, INCX )
*
      IF( XNORM.EQ.ZERO ) THEN
*
*        H  =  I
*
         TAU = ZERO
      ELSE
*
*        general case
*
         BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )
         SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' )
         IF( ABS( BETA ).LT.SAFMIN ) THEN
*
*           XNORM, BETA may be inaccurate; scale X and recompute them
*
            RSAFMN = ONE / SAFMIN
            KNT = 0
   10       CONTINUE
            KNT = KNT + 1
            CALL DSCAL( N-1, RSAFMN, X, INCX )
            BETA = BETA*RSAFMN
            ALPHA = ALPHA*RSAFMN
            IF( ABS( BETA ).LT.SAFMIN )
     $         GO TO 10
*
*           New BETA is at most 1, at least SAFMIN
*
            XNORM = DNRM2( N-1, X, INCX )
            BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )
            TAU = ( BETA-ALPHA ) / BETA
            CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX )
*
*           If ALPHA is subnormal, it may lose relative accuracy
*
            ALPHA = BETA
            DO 20 J = 1, KNT
               ALPHA = ALPHA*SAFMIN
   20       CONTINUE
         ELSE
            TAU = ( BETA-ALPHA ) / BETA
            CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX )
            ALPHA = BETA
         END IF
      END IF
*
      RETURN
*
*     End of DLARFG
*
      END
      SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
*
*  -- LAPACK auxiliary routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      CHARACTER          DIRECT, STOREV
      INTEGER            K, LDT, LDV, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   T( LDT, * ), TAU( * ), V( LDV, * )
*     ..
*
*  Purpose
*  =======
*
*  DLARFT forms the triangular factor T of a real block reflector H
*  of order n, which is defined as a product of k elementary reflectors.
*
*  If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
*
*  If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
*
*  If STOREV = 'C', the vector which defines the elementary reflector
*  H(i) is stored in the i-th column of the array V, and
*
*     H  =  I - V * T * V'
*
*  If STOREV = 'R', the vector which defines the elementary reflector
*  H(i) is stored in the i-th row of the array V, and
*
*     H  =  I - V' * T * V
*
*  Arguments
*  =========
*
*  DIRECT  (input) CHARACTER*1
*          Specifies the order in which the elementary reflectors are
*          multiplied to form the block reflector:
*          = 'F': H = H(1) H(2) . . . H(k) (Forward)
*          = 'B': H = H(k) . . . H(2) H(1) (Backward)
*
*  STOREV  (input) CHARACTER*1
*          Specifies how the vectors which define the elementary
*          reflectors are stored (see also Further Details):
*          = 'C': columnwise
*          = 'R': rowwise
*
*  N       (input) INTEGER
*          The order of the block reflector H. N >= 0.
*
*  K       (input) INTEGER
*          The order of the triangular factor T (= the number of
*          elementary reflectors). K >= 1.
*
*  V       (input/output) DOUBLE PRECISION array, dimension
*                               (LDV,K) if STOREV = 'C'
*                               (LDV,N) if STOREV = 'R'
*          The matrix V. See further details.
*
*  LDV     (input) INTEGER
*          The leading dimension of the array V.
*          If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
*
*  TAU     (input) DOUBLE PRECISION array, dimension (K)
*          TAU(i) must contain the scalar factor of the elementary
*          reflector H(i).
*
*  T       (output) DOUBLE PRECISION array, dimension (LDT,K)
*          The k by k triangular factor T of the block reflector.
*          If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
*          lower triangular. The rest of the array is not used.
*
*  LDT     (input) INTEGER
*          The leading dimension of the array T. LDT >= K.
*
*  Further Details
*  ===============
*
*  The shape of the matrix V and the storage of the vectors which define
*  the H(i) is best illustrated by the following example with n = 5 and
*  k = 3. The elements equal to 1 are not stored; the corresponding
*  array elements are modified but restored on exit. The rest of the
*  array is not used.
*
*  DIRECT = 'F' and STOREV = 'C':         DIRECT = 'F' and STOREV = 'R':
*
*               V = (  1       )                 V = (  1 v1 v1 v1 v1 )
*                   ( v1  1    )                     (     1 v2 v2 v2 )
*                   ( v1 v2  1 )                     (        1 v3 v3 )
*                   ( v1 v2 v3 )
*                   ( v1 v2 v3 )
*
*  DIRECT = 'B' and STOREV = 'C':         DIRECT = 'B' and STOREV = 'R':
*
*               V = ( v1 v2 v3 )                 V = ( v1 v1  1       )
*                   ( v1 v2 v3 )                     ( v2 v2 v2  1    )
*                   (  1 v2 v3 )                     ( v3 v3 v3 v3  1 )
*                   (     1 v3 )
*                   (        1 )
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, J
      DOUBLE PRECISION   VII
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGEMV, DTRMV
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
      IF( LSAME( DIRECT, 'F' ) ) THEN
         DO 20 I = 1, K
            IF( TAU( I ).EQ.ZERO ) THEN
*
*              H(i)  =  I
*
               DO 10 J = 1, I
                  T( J, I ) = ZERO
   10          CONTINUE
            ELSE
*
*              general case
*
               VII = V( I, I )
               V( I, I ) = ONE
               IF( LSAME( STOREV, 'C' ) ) THEN
*
*                 T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i)
*
                  CALL DGEMV( 'Transpose', N-I+1, I-1, -TAU( I ),
     $                        V( I, 1 ), LDV, V( I, I ), 1, ZERO,
     $                        T( 1, I ), 1 )
               ELSE
*
*                 T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)'
*
                  CALL DGEMV( 'No transpose', I-1, N-I+1, -TAU( I ),
     $                        V( 1, I ), LDV, V( I, I ), LDV, ZERO,
     $                        T( 1, I ), 1 )
               END IF
               V( I, I ) = VII
*
*              T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i)
*
               CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T,
     $                     LDT, T( 1, I ), 1 )
               T( I, I ) = TAU( I )
            END IF
   20    CONTINUE
      ELSE
         DO 40 I = K, 1, -1
            IF( TAU( I ).EQ.ZERO ) THEN
*
*              H(i)  =  I
*
               DO 30 J = I, K
                  T( J, I ) = ZERO
   30          CONTINUE
            ELSE
*
*              general case
*
               IF( I.LT.K ) THEN
                  IF( LSAME( STOREV, 'C' ) ) THEN
                     VII = V( N-K+I, I )
                     V( N-K+I, I ) = ONE
*
*                    T(i+1:k,i) :=
*                            - tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i)
*
                     CALL DGEMV( 'Transpose', N-K+I, K-I, -TAU( I ),
     $                           V( 1, I+1 ), LDV, V( 1, I ), 1, ZERO,
     $                           T( I+1, I ), 1 )
                     V( N-K+I, I ) = VII
                  ELSE
                     VII = V( I, N-K+I )
                     V( I, N-K+I ) = ONE
*
*                    T(i+1:k,i) :=
*                            - tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)'
*
                     CALL DGEMV( 'No transpose', K-I, N-K+I, -TAU( I ),
     $                           V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO,
     $                           T( I+1, I ), 1 )
                     V( I, N-K+I ) = VII
                  END IF
*
*                 T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i)
*
                  CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I,
     $                        T( I+1, I+1 ), LDT, T( I+1, I ), 1 )
               END IF
               T( I, I ) = TAU( I )
            END IF
   40    CONTINUE
      END IF
      RETURN
*
*     End of DLARFT
*
      END
      SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO )
*
*  -- LAPACK routine (version 1.1) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      INTEGER            INFO, K, LDA, M, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DORG2R generates an m by n real matrix Q with orthonormal columns,
*  which is defined as the first n columns of a product of k elementary
*  reflectors of order m
*
*        Q  =  H(1) H(2) . . . H(k)
*
*  as returned by DGEQRF.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrix Q. M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix Q. M >= N >= 0.
*
*  K       (input) INTEGER
*          The number of elementary reflectors whose product defines the
*          matrix Q. N >= K >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the i-th column must contain the vector which
*          defines the elementary reflector H(i), for i = 1,2,...,k, as
*          returned by DGEQRF in the first k columns of its array
*          argument A.
*          On exit, the m-by-n matrix Q.
*
*  LDA     (input) INTEGER
*          The first dimension of the array A. LDA >= max(1,M).
*
*  TAU     (input) DOUBLE PRECISION array, dimension (K)
*          TAU(i) must contain the scalar factor of the elementary
*          reflector H(i), as returned by DGEQRF.
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (N)
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: if INFO = -i, the i-th argument has an illegal value
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, J, L
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLARF, DSCAL, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments
*
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
         INFO = -2
      ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DORG2R', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.LE.0 )
     $   RETURN
*
*     Initialise columns k+1:n to columns of the unit matrix
*
      DO 20 J = K + 1, N
         DO 10 L = 1, M
            A( L, J ) = ZERO
   10    CONTINUE
         A( J, J ) = ONE
   20 CONTINUE
*
      DO 40 I = K, 1, -1
*
*        Apply H(i) to A(i:m,i:n) from the left
*
         IF( I.LT.N ) THEN
            A( I, I ) = ONE
            CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
     $                  A( I, I+1 ), LDA, WORK )
         END IF
         IF( I.LT.M )
     $      CALL DSCAL( M-I, -TAU( I ), A( I+1, I ), 1 )
         A( I, I ) = ONE - TAU( I )
*
*        Set A(1:i-1,i) to zero
*
         DO 30 L = 1, I - 1
            A( L, I ) = ZERO
   30    CONTINUE
   40 CONTINUE
      RETURN
*
*     End of DORG2R
*
      END
      SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
*  -- LAPACK routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     September 30, 1994
*
*     .. Scalar Arguments ..
      INTEGER            INFO, K, LDA, LWORK, M, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( LWORK )
*     ..
*
*  Purpose
*  =======
*
*  DORGQR generates an M-by-N real matrix Q with orthonormal columns,
*  which is defined as the first N columns of a product of K elementary
*  reflectors of order M
*
*        Q  =  H(1) H(2) . . . H(k)
*
*  as returned by DGEQRF.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrix Q. M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix Q. M >= N >= 0.
*
*  K       (input) INTEGER
*          The number of elementary reflectors whose product defines the
*          matrix Q. N >= K >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the i-th column must contain the vector which
*          defines the elementary reflector H(i), for i = 1,2,...,k, as
*          returned by DGEQRF in the first k columns of its array
*          argument A.
*          On exit, the M-by-N matrix Q.
*
*  LDA     (input) INTEGER
*          The first dimension of the array A. LDA >= max(1,M).
*
*  TAU     (input) DOUBLE PRECISION array, dimension (K)
*          TAU(i) must contain the scalar factor of the elementary
*          reflector H(i), as returned by DGEQRF.
*
*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
*  LWORK   (input) INTEGER
*          The dimension of the array WORK. LWORK >= max(1,N).
*          For optimum performance LWORK >= N*NB, where NB is the
*          optimal blocksize.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument has an illegal value
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, NB,
     $                   NBMIN, NX
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLARFB, DLARFT, DORG2R, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments
*
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
         INFO = -2
      ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -5
      ELSE IF( LWORK.LT.MAX( 1, N ) ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DORGQR', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.LE.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
*
*     Determine the block size.
*
      NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 )
      NBMIN = 2
      NX = 0
      IWS = N
      IF( NB.GT.1 .AND. NB.LT.K ) THEN
*
*        Determine when to cross over from blocked to unblocked code.
*
         NX = MAX( 0, ILAENV( 3, 'DORGQR', ' ', M, N, K, -1 ) )
         IF( NX.LT.K ) THEN
*
*           Determine if workspace is large enough for blocked code.
*
            LDWORK = N
            IWS = LDWORK*NB
            IF( LWORK.LT.IWS ) THEN
*
*              Not enough workspace to use optimal NB:  reduce NB and
*              determine the minimum value of NB.
*
               NB = LWORK / LDWORK
               NBMIN = MAX( 2, ILAENV( 2, 'DORGQR', ' ', M, N, K, -1 ) )
            END IF
         END IF
      END IF
*
      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
*
*        Use blocked code after the last block.
*        The first kk columns are handled by the block method.
*
         KI = ( ( K-NX-1 ) / NB )*NB
         KK = MIN( K, KI+NB )
*
*        Set A(1:kk,kk+1:n) to zero.
*
         DO 20 J = KK + 1, N
            DO 10 I = 1, KK
               A( I, J ) = ZERO
   10       CONTINUE
   20    CONTINUE
      ELSE
         KK = 0
      END IF
*
*     Use unblocked code for the last or only block.
*
      IF( KK.LT.N )
     $   CALL DORG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA,
     $                TAU( KK+1 ), WORK, IINFO )
*
      IF( KK.GT.0 ) THEN
*
*        Use blocked code
*
         DO 50 I = KI + 1, 1, -NB
            IB = MIN( NB, K-I+1 )
            IF( I+IB.LE.N ) THEN
*
*              Form the triangular factor of the block reflector
*              H = H(i) H(i+1) . . . H(i+ib-1)
*
               CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB,
     $                      A( I, I ), LDA, TAU( I ), WORK, LDWORK )
*
*              Apply H to A(i:m,i+ib:n) from the left
*
               CALL DLARFB( 'Left', 'No transpose', 'Forward',
     $                      'Columnwise', M-I+1, N-I-IB+1, IB,
     $                      A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ),
     $                      LDA, WORK( IB+1 ), LDWORK )
            END IF
*
*           Apply H to rows i:m of current block
*
            CALL DORG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK,
     $                   IINFO )
*
*           Set rows 1:i-1 of current block to zero
*
            DO 40 J = I, I + IB - 1
               DO 30 L = 1, I - 1
                  A( L, J ) = ZERO
   30          CONTINUE
   40       CONTINUE
   50    CONTINUE
      END IF
*
      WORK( 1 ) = IWS
      RETURN
*
*     End of DORGQR
*
      END
      SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
     $                   WORK, INFO )
*
*  -- LAPACK routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      CHARACTER          SIDE, TRANS
      INTEGER            INFO, K, LDA, LDC, M, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DORM2R overwrites the general real m by n matrix C with
*
*        Q * C  if SIDE = 'L' and TRANS = 'N', or
*
*        Q'* C  if SIDE = 'L' and TRANS = 'T', or
*
*        C * Q  if SIDE = 'R' and TRANS = 'N', or
*
*        C * Q' if SIDE = 'R' and TRANS = 'T',
*
*  where Q is a real orthogonal matrix defined as the product of k
*  elementary reflectors
*
*        Q = H(1) H(2) . . . H(k)
*
*  as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n
*  if SIDE = 'R'.
*
*  Arguments
*  =========
*
*  SIDE    (input) CHARACTER*1
*          = 'L': apply Q or Q' from the Left
*          = 'R': apply Q or Q' from the Right
*
*  TRANS   (input) CHARACTER*1
*          = 'N': apply Q  (No transpose)
*          = 'T': apply Q' (Transpose)
*
*  M       (input) INTEGER
*          The number of rows of the matrix C. M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix C. N >= 0.
*
*  K       (input) INTEGER
*          The number of elementary reflectors whose product defines
*          the matrix Q.
*          If SIDE = 'L', M >= K >= 0;
*          if SIDE = 'R', N >= K >= 0.
*
*  A       (input) DOUBLE PRECISION array, dimension (LDA,K)
*          The i-th column must contain the vector which defines the
*          elementary reflector H(i), for i = 1,2,...,k, as returned by
*          DGEQRF in the first k columns of its array argument A.
*          A is modified by the routine but restored on exit.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.
*          If SIDE = 'L', LDA >= max(1,M);
*          if SIDE = 'R', LDA >= max(1,N).
*
*  TAU     (input) DOUBLE PRECISION array, dimension (K)
*          TAU(i) must contain the scalar factor of the elementary
*          reflector H(i), as returned by DGEQRF.
*
*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
*          On entry, the m by n matrix C.
*          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
*
*  LDC     (input) INTEGER
*          The leading dimension of the array C. LDC >= max(1,M).
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension
*                                   (N) if SIDE = 'L',
*                                   (M) if SIDE = 'R'
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: if INFO = -i, the i-th argument had an illegal value
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            LEFT, NOTRAN
      INTEGER            I, I1, I2, I3, IC, JC, MI, NI, NQ
      DOUBLE PRECISION   AII
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLARF, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments
*
      INFO = 0
      LEFT = LSAME( SIDE, 'L' )
      NOTRAN = LSAME( TRANS, 'N' )
*
*     NQ is the order of Q
*
      IF( LEFT ) THEN
         NQ = M
      ELSE
         NQ = N
      END IF
      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
         INFO = -7
      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
         INFO = -10
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DORM2R', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
     $   RETURN
*
      IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) )
     $     THEN
         I1 = 1
         I2 = K
         I3 = 1
      ELSE
         I1 = K
         I2 = 1
         I3 = -1
      END IF
*
      IF( LEFT ) THEN
         NI = N
         JC = 1
      ELSE
         MI = M
         IC = 1
      END IF
*
      DO 10 I = I1, I2, I3
         IF( LEFT ) THEN
*
*           H(i) is applied to C(i:m,1:n)
*
            MI = M - I + 1
            IC = I
         ELSE
*
*           H(i) is applied to C(1:m,i:n)
*
            NI = N - I + 1
            JC = I
         END IF
*
*        Apply H(i)
*
         AII = A( I, I )
         A( I, I ) = ONE
         CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ),
     $               LDC, WORK )
         A( I, I ) = AII
   10 CONTINUE
      RETURN
*
*     End of DORM2R
*
      END
      SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
     $                   WORK, LWORK, INFO )
*
*  -- LAPACK routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     September 30, 1994
*
*     .. Scalar Arguments ..
      CHARACTER          SIDE, TRANS
      INTEGER            INFO, K, LDA, LDC, LWORK, M, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), TAU( * ),
     $                   WORK( LWORK )
*     ..
*
*  Purpose
*  =======
*
*  DORMQR overwrites the general real M-by-N matrix C with
*
*                  SIDE = 'L'     SIDE = 'R'
*  TRANS = 'N':      Q * C          C * Q
*  TRANS = 'T':      Q**T * C       C * Q**T
*
*  where Q is a real orthogonal matrix defined as the product of k
*  elementary reflectors
*
*        Q = H(1) H(2) . . . H(k)
*
*  as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N
*  if SIDE = 'R'.
*
*  Arguments
*  =========
*
*  SIDE    (input) CHARACTER*1
*          = 'L': apply Q or Q**T from the Left;
*          = 'R': apply Q or Q**T from the Right.
*
*  TRANS   (input) CHARACTER*1
*          = 'N':  No transpose, apply Q;
*          = 'T':  Transpose, apply Q**T.
*
*  M       (input) INTEGER
*          The number of rows of the matrix C. M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix C. N >= 0.
*
*  K       (input) INTEGER
*          The number of elementary reflectors whose product defines
*          the matrix Q.
*          If SIDE = 'L', M >= K >= 0;
*          if SIDE = 'R', N >= K >= 0.
*
*  A       (input) DOUBLE PRECISION array, dimension (LDA,K)
*          The i-th column must contain the vector which defines the
*          elementary reflector H(i), for i = 1,2,...,k, as returned by
*          DGEQRF in the first k columns of its array argument A.
*          A is modified by the routine but restored on exit.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.
*          If SIDE = 'L', LDA >= max(1,M);
*          if SIDE = 'R', LDA >= max(1,N).
*
*  TAU     (input) DOUBLE PRECISION array, dimension (K)
*          TAU(i) must contain the scalar factor of the elementary
*          reflector H(i), as returned by DGEQRF.
*
*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
*          On entry, the M-by-N matrix C.
*          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
*
*  LDC     (input) INTEGER
*          The leading dimension of the array C. LDC >= max(1,M).
*
*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
*  LWORK   (input) INTEGER
*          The dimension of the array WORK.
*          If SIDE = 'L', LWORK >= max(1,N);
*          if SIDE = 'R', LWORK >= max(1,M).
*          For optimum performance LWORK >= N*NB if SIDE = 'L', and
*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal
*          blocksize.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            NBMAX, LDT
      PARAMETER          ( NBMAX = 64, LDT = NBMAX+1 )
*     ..
*     .. Local Scalars ..
      LOGICAL            LEFT, NOTRAN
      INTEGER            I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK,
     $                   MI, NB, NBMIN, NI, NQ, NW
*     ..
*     .. Local Arrays ..
      DOUBLE PRECISION   T( LDT, NBMAX )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      EXTERNAL           LSAME, ILAENV
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLARFB, DLARFT, DORM2R, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments
*
      INFO = 0
      LEFT = LSAME( SIDE, 'L' )
      NOTRAN = LSAME( TRANS, 'N' )
*
*     NQ is the order of Q and NW is the minimum dimension of WORK
*
      IF( LEFT ) THEN
         NQ = M
         NW = N
      ELSE
         NQ = N
         NW = M
      END IF
      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
         INFO = -7
      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
         INFO = -10
      ELSE IF( LWORK.LT.MAX( 1, NW ) ) THEN
         INFO = -12
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DORMQR', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
*
*     Determine the block size.  NB may be at most NBMAX, where NBMAX
*     is used to define the local array T.
*
      NB = MIN( NBMAX, ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N, K,
     $     -1 ) )
      NBMIN = 2
      LDWORK = NW
      IF( NB.GT.1 .AND. NB.LT.K ) THEN
         IWS = NW*NB
         IF( LWORK.LT.IWS ) THEN
            NB = LWORK / LDWORK
            NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', SIDE // TRANS, M, N, K,
     $              -1 ) )
         END IF
      ELSE
         IWS = NW
      END IF
*
      IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
*
*        Use unblocked code
*
         CALL DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK,
     $                IINFO )
      ELSE
*
*        Use blocked code
*
         IF( ( LEFT .AND. .NOT.NOTRAN ) .OR.
     $       ( .NOT.LEFT .AND. NOTRAN ) ) THEN
            I1 = 1
            I2 = K
            I3 = NB
         ELSE
            I1 = ( ( K-1 ) / NB )*NB + 1
            I2 = 1
            I3 = -NB
         END IF
*
         IF( LEFT ) THEN
            NI = N
            JC = 1
         ELSE
            MI = M
            IC = 1
         END IF
*
         DO 10 I = I1, I2, I3
            IB = MIN( NB, K-I+1 )
*
*           Form the triangular factor of the block reflector
*           H = H(i) H(i+1) . . . H(i+ib-1)
*
            CALL DLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ),
     $                   LDA, TAU( I ), T, LDT )
            IF( LEFT ) THEN
*
*              H or H' is applied to C(i:m,1:n)
*
               MI = M - I + 1
               IC = I
            ELSE
*
*              H or H' is applied to C(1:m,i:n)
*
               NI = N - I + 1
               JC = I
            END IF
*
*           Apply H or H'
*
            CALL DLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI,
     $                   IB, A( I, I ), LDA, T, LDT, C( IC, JC ), LDC,
     $                   WORK, LDWORK )
   10    CONTINUE
      END IF
      WORK( 1 ) = IWS
      RETURN
*
*     End of DORMQR
*
      END
      INTEGER          FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3,
     $                 N4 )
*
*  -- LAPACK auxiliary routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     September 30, 1994
*
*     .. Scalar Arguments ..
      CHARACTER*( * )    NAME, OPTS
      INTEGER            ISPEC, N1, N2, N3, N4
*     ..
*
*  Purpose
*  =======
*
*  ILAENV is called from the LAPACK routines to choose problem-dependent
*  parameters for the local environment.  See ISPEC for a description of
*  the parameters.
*
*  This version provides a set of parameters which should give good,
*  but not optimal, performance on many of the currently available
*  computers.  Users are encouraged to modify this subroutine to set
*  the tuning parameters for their particular machine using the option
*  and problem size information in the arguments.
*
*  This routine will not function correctly if it is converted to all
*  lower case.  Converting it to all upper case is allowed.
*
*  Arguments
*  =========
*
*  ISPEC   (input) INTEGER
*          Specifies the parameter to be returned as the value of
*          ILAENV.
*          = 1: the optimal blocksize; if this value is 1, an unblocked
*               algorithm will give the best performance.
*          = 2: the minimum block size for which the block routine
*               should be used; if the usable block size is less than
*               this value, an unblocked routine should be used.
*          = 3: the crossover point (in a block routine, for N less
*               than this value, an unblocked routine should be used)
*          = 4: the number of shifts, used in the nonsymmetric
*               eigenvalue routines
*          = 5: the minimum column dimension for blocking to be used;
*               rectangular blocks must have dimension at least k by m,
*               where k is given by ILAENV(2,...) and m by ILAENV(5,...)
*          = 6: the crossover point for the SVD (when reducing an m by n
*               matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds
*               this value, a QR factorization is used first to reduce
*               the matrix to a triangular form.)
*          = 7: the number of processors
*          = 8: the crossover point for the multishift QR and QZ methods
*               for nonsymmetric eigenvalue problems.
*
*  NAME    (input) CHARACTER*(*)
*          The name of the calling subroutine, in either upper case or
*          lower case.
*
*  OPTS    (input) CHARACTER*(*)
*          The character options to the subroutine NAME, concatenated
*          into a single character string.  For example, UPLO = 'U',
*          TRANS = 'T', and DIAG = 'N' for a triangular routine would
*          be specified as OPTS = 'UTN'.
*
*  N1      (input) INTEGER
*  N2      (input) INTEGER
*  N3      (input) INTEGER
*  N4      (input) INTEGER
*          Problem dimensions for the subroutine NAME; these may not all
*          be required.
*
* (ILAENV) (output) INTEGER
*          >= 0: the value of the parameter specified by ISPEC
*          < 0:  if ILAENV = -k, the k-th argument had an illegal value.
*
*  Further Details
*  ===============
*
*  The following conventions have been used when calling ILAENV from the
*  LAPACK routines:
*  1)  OPTS is a concatenation of all of the character options to
*      subroutine NAME, in the same order that they appear in the
*      argument list for NAME, even if they are not used in determining
*      the value of the parameter specified by ISPEC.
*  2)  The problem dimensions N1, N2, N3, N4 are specified in the order
*      that they appear in the argument list for NAME.  N1 is used
*      first, N2 second, and so on, and unused problem dimensions are
*      passed a value of -1.
*  3)  The parameter value returned by ILAENV is checked for validity in
*      the calling subroutine.  For example, ILAENV is used to retrieve
*      the optimal blocksize for STRTRI as follows:
*
*      NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )
*      IF( NB.LE.1 ) NB = MAX( 1, N )
*
*  =====================================================================
*
*     .. Local Scalars ..
      LOGICAL            CNAME, SNAME
      CHARACTER*1        C1
      CHARACTER*2        C2, C4
      CHARACTER*3        C3
      CHARACTER*6        SUBNAM
      INTEGER            I, IC, IZ, NB, NBMIN, NX
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          CHAR, ICHAR, INT, MIN, REAL
*     ..
*     .. Executable Statements ..
*
      GO TO ( 100, 100, 100, 400, 500, 600, 700, 800 ) ISPEC
*
*     Invalid value for ISPEC
*
      ILAENV = -1
      RETURN
*
  100 CONTINUE
*
*     Convert NAME to upper case if the first character is lower case.
*
      ILAENV = 1
      SUBNAM = NAME
      IC = ICHAR( SUBNAM( 1:1 ) )
      IZ = ICHAR( 'Z' )
      IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN
*
*        ASCII character set
*
         IF( IC.GE.97 .AND. IC.LE.122 ) THEN
            SUBNAM( 1:1 ) = CHAR( IC-32 )
            DO 10 I = 2, 6
               IC = ICHAR( SUBNAM( I:I ) )
               IF( IC.GE.97 .AND. IC.LE.122 )
     $            SUBNAM( I:I ) = CHAR( IC-32 )
   10       CONTINUE
         END IF
*
      ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN
*
*        EBCDIC character set
*
         IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR.
     $       ( IC.GE.145 .AND. IC.LE.153 ) .OR.
     $       ( IC.GE.162 .AND. IC.LE.169 ) ) THEN
            SUBNAM( 1:1 ) = CHAR( IC+64 )
            DO 20 I = 2, 6
               IC = ICHAR( SUBNAM( I:I ) )
               IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR.
     $             ( IC.GE.145 .AND. IC.LE.153 ) .OR.
     $             ( IC.GE.162 .AND. IC.LE.169 ) )
     $            SUBNAM( I:I ) = CHAR( IC+64 )
   20       CONTINUE
         END IF
*
      ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN
*
*        Prime machines:  ASCII+128
*
         IF( IC.GE.225 .AND. IC.LE.250 ) THEN
            SUBNAM( 1:1 ) = CHAR( IC-32 )
            DO 30 I = 2, 6
               IC = ICHAR( SUBNAM( I:I ) )
               IF( IC.GE.225 .AND. IC.LE.250 )
     $            SUBNAM( I:I ) = CHAR( IC-32 )
   30       CONTINUE
         END IF
      END IF
*
      C1 = SUBNAM( 1:1 )
      SNAME = C1.EQ.'S' .OR. C1.EQ.'D'
      CNAME = C1.EQ.'C' .OR. C1.EQ.'Z'
      IF( .NOT.( CNAME .OR. SNAME ) )
     $   RETURN
      C2 = SUBNAM( 2:3 )
      C3 = SUBNAM( 4:6 )
      C4 = C3( 2:3 )
*
      GO TO ( 110, 200, 300 ) ISPEC
*
  110 CONTINUE
*
*     ISPEC = 1:  block size
*
*     In these examples, separate code is provided for setting NB for
*     real and complex.  We assume that NB will take the same value in
*     single or double precision.
*
      NB = 1
*
      IF( C2.EQ.'GE' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR.
     $            C3.EQ.'QLF' ) THEN
            IF( SNAME ) THEN
               NB = 32
            ELSE
               NB = 32
            END IF
         ELSE IF( C3.EQ.'HRD' ) THEN
            IF( SNAME ) THEN
               NB = 32
            ELSE
               NB = 32
            END IF
         ELSE IF( C3.EQ.'BRD' ) THEN
            IF( SNAME ) THEN
               NB = 32
            ELSE
               NB = 32
            END IF
         ELSE IF( C3.EQ.'TRI' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         END IF
      ELSE IF( C2.EQ.'PO' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         END IF
      ELSE IF( C2.EQ.'SY' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN
            NB = 1
         ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN
            NB = 64
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            NB = 64
         ELSE IF( C3.EQ.'TRD' ) THEN
            NB = 1
         ELSE IF( C3.EQ.'GST' ) THEN
            NB = 64
         END IF
      ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
     $          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
     $          C4.EQ.'BR' ) THEN
               NB = 32
            END IF
         ELSE IF( C3( 1:1 ).EQ.'M' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
     $          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
     $          C4.EQ.'BR' ) THEN
               NB = 32
            END IF
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
     $          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
     $          C4.EQ.'BR' ) THEN
               NB = 32
            END IF
         ELSE IF( C3( 1:1 ).EQ.'M' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
     $          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
     $          C4.EQ.'BR' ) THEN
               NB = 32
            END IF
         END IF
      ELSE IF( C2.EQ.'GB' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               IF( N4.LE.64 ) THEN
                  NB = 1
               ELSE
                  NB = 32
               END IF
            ELSE
               IF( N4.LE.64 ) THEN
                  NB = 1
               ELSE
                  NB = 32
               END IF
            END IF
         END IF
      ELSE IF( C2.EQ.'PB' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               IF( N2.LE.64 ) THEN
                  NB = 1
               ELSE
                  NB = 32
               END IF
            ELSE
               IF( N2.LE.64 ) THEN
                  NB = 1
               ELSE
                  NB = 32
               END IF
            END IF
         END IF
      ELSE IF( C2.EQ.'TR' ) THEN
         IF( C3.EQ.'TRI' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         END IF
      ELSE IF( C2.EQ.'LA' ) THEN
         IF( C3.EQ.'UUM' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         END IF
      ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN
         IF( C3.EQ.'EBZ' ) THEN
            NB = 1
         END IF
      END IF
      ILAENV = NB
      RETURN
*
  200 CONTINUE
*
*     ISPEC = 2:  minimum block size
*
      NBMIN = 2
      IF( C2.EQ.'GE' ) THEN
         IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR.
     $       C3.EQ.'QLF' ) THEN
            IF( SNAME ) THEN
               NBMIN = 2
            ELSE
               NBMIN = 2
            END IF
         ELSE IF( C3.EQ.'HRD' ) THEN
            IF( SNAME ) THEN
               NBMIN = 2
            ELSE
               NBMIN = 2
            END IF
         ELSE IF( C3.EQ.'BRD' ) THEN
            IF( SNAME ) THEN
               NBMIN = 2
            ELSE
               NBMIN = 2
            END IF
         ELSE IF( C3.EQ.'TRI' ) THEN
            IF( SNAME ) THEN
               NBMIN = 2
            ELSE
               NBMIN = 2
            END IF
         END IF
      ELSE IF( C2.EQ.'SY' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               NBMIN = 8
            ELSE
               NBMIN = 8
            END IF
         ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN
            NBMIN = 2
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
         IF( C3.EQ.'TRD' ) THEN
            NBMIN = 2
         END IF
      ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
     $          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
     $          C4.EQ.'BR' ) THEN
               NBMIN = 2
            END IF
         ELSE IF( C3( 1:1 ).EQ.'M' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
     $          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
     $          C4.EQ.'BR' ) THEN
               NBMIN = 2
            END IF
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
     $          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
     $          C4.EQ.'BR' ) THEN
               NBMIN = 2
            END IF
         ELSE IF( C3( 1:1 ).EQ.'M' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
     $          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
     $          C4.EQ.'BR' ) THEN
               NBMIN = 2
            END IF
         END IF
      END IF
      ILAENV = NBMIN
      RETURN
*
  300 CONTINUE
*
*     ISPEC = 3:  crossover point
*
      NX = 0
      IF( C2.EQ.'GE' ) THEN
         IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR.
     $       C3.EQ.'QLF' ) THEN
            IF( SNAME ) THEN
               NX = 128
            ELSE
               NX = 128
            END IF
         ELSE IF( C3.EQ.'HRD' ) THEN
            IF( SNAME ) THEN
               NX = 128
            ELSE
               NX = 128
            END IF
         ELSE IF( C3.EQ.'BRD' ) THEN
            IF( SNAME ) THEN
               NX = 128
            ELSE
               NX = 128
            END IF
         END IF
      ELSE IF( C2.EQ.'SY' ) THEN
         IF( SNAME .AND. C3.EQ.'TRD' ) THEN
            NX = 1
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
         IF( C3.EQ.'TRD' ) THEN
            NX = 1
         END IF
      ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
     $          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
     $          C4.EQ.'BR' ) THEN
               NX = 128
            END IF
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
     $          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
     $          C4.EQ.'BR' ) THEN
               NX = 128
            END IF
         END IF
      END IF
      ILAENV = NX
      RETURN
*
  400 CONTINUE
*
*     ISPEC = 4:  number of shifts (used by xHSEQR)
*
      ILAENV = 6
      RETURN
*
  500 CONTINUE
*
*     ISPEC = 5:  minimum column dimension (not used)
*
      ILAENV = 2
      RETURN
*
  600 CONTINUE 
*
*     ISPEC = 6:  crossover point for SVD (used by xGELSS and xGESVD)
*
      ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 )
      RETURN
*
  700 CONTINUE
*
*     ISPEC = 7:  number of processors (not used)
*
      ILAENV = 1
      RETURN
*
  800 CONTINUE
*
*     ISPEC = 8:  crossover point for multishift (used by xHSEQR)
*
      ILAENV = 50
      RETURN
*
*     End of ILAENV
*
      END
      LOGICAL          FUNCTION LSAME( CA, CB )
*
*  -- LAPACK auxiliary routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     January 31, 1994
*
*     .. Scalar Arguments ..
      CHARACTER          CA, CB
*     ..
*
*  Purpose
*  =======
*
*  LSAME returns .TRUE. if CA is the same letter as CB regardless of
*  case.
*
*  Arguments
*  =========
*
*  CA      (input) CHARACTER*1
*  CB      (input) CHARACTER*1
*          CA and CB specify the single characters to be compared.
*
* =====================================================================
*
*     .. Intrinsic Functions ..
      INTRINSIC          ICHAR
*     ..
*     .. Local Scalars ..
      INTEGER            INTA, INTB, ZCODE
*     ..
*     .. Executable Statements ..
*
*     Test if the characters are equal
*
      LSAME = CA.EQ.CB
      IF( LSAME )
     $   RETURN
*
*     Now test for equivalence if both characters are alphabetic.
*
      ZCODE = ICHAR( 'Z' )
*
*     Use 'Z' rather than 'A' so that ASCII can be detected on Prime
*     machines, on which ICHAR returns a value with bit 8 set.
*     ICHAR('A') on Prime machines returns 193 which is the same as
*     ICHAR('A') on an EBCDIC machine.
*
      INTA = ICHAR( CA )
      INTB = ICHAR( CB )
*
      IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN
*
*        ASCII is assumed - ZCODE is the ASCII code of either lower or
*        upper case 'Z'.
*
         IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32
         IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32
*
      ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN
*
*        EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or
*        upper case 'Z'.
*
         IF( INTA.GE.129 .AND. INTA.LE.137 .OR.
     $       INTA.GE.145 .AND. INTA.LE.153 .OR.
     $       INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64
         IF( INTB.GE.129 .AND. INTB.LE.137 .OR.
     $       INTB.GE.145 .AND. INTB.LE.153 .OR.
     $       INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64
*
      ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN
*
*        ASCII is assumed, on Prime machines - ZCODE is the ASCII code
*        plus 128 of either lower or upper case 'Z'.
*
         IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32
         IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32
      END IF
      LSAME = INTA.EQ.INTB
*
*     RETURN
*
*     End of LSAME
*
      END
      SUBROUTINE XERBLA( SRNAME, INFO )
*
*  -- LAPACK auxiliary routine (preliminary version) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     February 29, 1992
*
*     .. Scalar Arguments ..
      CHARACTER*6        SRNAME
      INTEGER            INFO
*     ..
*
*  Purpose
*  =======
*
*  XERBLA  is an error handler for the LAPACK routines.
*  It is called by an LAPACK routine if an input parameter has an
*  invalid value.  A message is printed and execution stops.
*
*  Installers may consider modifying the STOP statement in order to
*  call system-specific exception-handling facilities.
*
*  Arguments
*  =========
*
*  SRNAME  (input) CHARACTER*6
*          The name of the routine which called XERBLA.
*
*  INFO    (input) INTEGER
*          The position of the invalid parameter in the parameter list
*          of the calling routine.
*
*
      WRITE( *, FMT = 9999 )SRNAME, INFO
*
      STOP
*
 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ',
     $      'an illegal value' )
*
*     End of XERBLA
*
      END
SHAR_EOF
fi # end of overwriting check
if test -f 'hompack90.f'
then
	echo shar: will not over-write existing file "'hompack90.f'"
else
cat << \SHAR_EOF > 'hompack90.f'
      MODULE REAL_PRECISION
! This is for 64-bit arithmetic.
      INTEGER, PARAMETER:: R8=SELECTED_REAL_KIND(13)
      END MODULE REAL_PRECISION

		

		
!  This module provides global allocatable arrays used for the sparse
!  matrix data structures, and by the polynomial system solver.  The
!  MODULE HOMOTOPY uses this module.
!
      MODULE HOMPACK90_GLOBAL
      USE REAL_PRECISION
      INTEGER, DIMENSION(:), ALLOCATABLE:: COLPOS, IPAR, ROWPOS
      REAL (KIND=R8), DIMENSION(:), ALLOCATABLE:: PAR, PP, QRSPARSE
      END MODULE HOMPACK90_GLOBAL

		

		
      MODULE HOMOTOPY       ! Interfaces for user written subroutines.
      USE REAL_PRECISION, ONLY : R8
      USE HOMPACK90_GLOBAL
!
C Interface for subroutine that evaluates F(X) and returns it in the vector V.
      INTERFACE
         SUBROUTINE F(X,V)
         USE REAL_PRECISION
         REAL (KIND=R8), DIMENSION(:), INTENT(IN):: X
         REAL (KIND=R8), DIMENSION(:), INTENT(OUT):: V
         END SUBROUTINE F
      END INTERFACE
!
C Interface for subroutine that returns in V the K-th column of the Jacobian 
C matrix of F(X) evaluated at X. 
      INTERFACE
         SUBROUTINE FJAC(X,V,K)
         USE REAL_PRECISION
         REAL (KIND=R8), DIMENSION(:), INTENT(IN):: X
         REAL (KIND=R8), DIMENSION(:), INTENT(OUT):: V
         INTEGER, INTENT(IN):: K
         END SUBROUTINE FJAC
      END INTERFACE
!
C Interface for subroutine that evaluates RHO(A,LAMBDA,X) and returns it 
C in the vector V.
      INTERFACE
         SUBROUTINE RHO(A,LAMBDA,X,V)
         USE REAL_PRECISION
         REAL (KIND=R8), INTENT(IN):: A(:),X(:)
         REAL (KIND=R8), INTENT(IN OUT):: LAMBDA
         REAL (KIND=R8), INTENT(OUT):: V(:)
         END SUBROUTINE RHO
      END INTERFACE
C The following code is specifically for the polynomial system driver
C POLSYS1H, and should be used verbatim with POLSYS1H in the external 
C subroutine RHO.  
!     USE HOMPACK90_GLOBAL, ONLY: IPAR, PAR  ! FOR POLSYS1H ONLY.
!     INTERFACE
!       SUBROUTINE HFUNP(N,A,LAMBDA,X)
!       USE REAL_PRECISION
!       INTEGER, INTENT(IN):: N
!       REAL (KIND=R8), INTENT(IN):: A(2*N),LAMBDA,X(2*N)
!       END SUBROUTINE HFUNP
!     END INTERFACE
!     INTEGER:: J,NPOL
C FORCE PREDICTED POINT TO HAVE  LAMBDA .GE. 0  .
!     IF (LAMBDA .LT. 0.0) LAMBDA=0.0
!     NPOL=IPAR(1)
!     CALL HFUNP(NPOL,A,LAMBDA,X)
!     DO J=1,2*NPOL
!       V(J)=PAR(IPAR(3 + (4-1)) + (J-1))
!     END DO
!     RETURN
C If calling FIXP?? or STEP?? directly, supply appropriate replacement
C code in the external subroutine RHO.
!
C Interface for subroutine that calculates and returns in A the vector
C Z such that RHO(Z,LAMBDA,X) = 0 .
      INTERFACE
         SUBROUTINE RHOA(A,LAMBDA,X)
         USE REAL_PRECISION
         REAL (KIND=R8), DIMENSION(:), INTENT(OUT):: A
         REAL (KIND=R8), INTENT(IN):: LAMBDA,X(:)
         END SUBROUTINE RHOA
      END INTERFACE
!
C Interface for subroutine that returns in the vector V the Kth column
C of the Jacobian matrix [D RHO/D LAMBDA, D RHO/DX] evaluated at the
C point (A, LAMBDA, X).
      INTERFACE
         SUBROUTINE RHOJAC(A,LAMBDA,X,V,K)
         USE REAL_PRECISION
         REAL (KIND=R8), INTENT(IN):: A(:),X(:)
         REAL (KIND=R8), INTENT(IN OUT):: LAMBDA
         REAL (KIND=R8), INTENT(OUT):: V(:)
         INTEGER, INTENT(IN):: K
         END SUBROUTINE RHOJAC
      END INTERFACE
C The following code is specifically for the polynomial system driver
C POLSYS1H, and should be used verbatim with POLSYS1H in the external 
C subroutine RHOJAC.  
!     USE HOMPACK90_GLOBAL, ONLY: IPAR, PAR  ! FOR POLSYS1H ONLY.
!     INTERFACE
!       SUBROUTINE HFUNP(N,A,LAMBDA,X)
!       USE REAL_PRECISION
!       INTEGER, INTENT(IN):: N
!       REAL (KIND=R8), INTENT(IN):: A(2*N),LAMBDA,X(2*N)
!       END SUBROUTINE HFUNP
!     END INTERFACE
!     INTEGER:: J,NPOL,N2
!     NPOL=IPAR(1)
!     N2=2*NPOL
!     IF (K .EQ. 1) THEN
C FORCE PREDICTED POINT TO HAVE  LAMBDA .GE. 0  .
!       IF (LAMBDA .LT. 0.0) LAMBDA=0.0
!       CALL HFUNP(NPOL,A,LAMBDA,X)
!       DO J=1,N2
!         V(J)=PAR(IPAR(3 + (6-1)) + (J-1))
!       END DO
!       RETURN
!     ELSE
!       DO J=1,N2
!         V(J)=PAR(IPAR(3 + (5-1)) + (J-1) + N2*(K-2))
!       END DO
!     ENDIF
C
!     RETURN
C If calling FIXP?? or STEP?? directly, supply appropriate replacement
C code in the external subroutine RHOJAC.
!
!
C Interface for subroutine that evaluates a sparse Jacobian matrix of
C F(X) at X, and operates as follows:
C
C If MODE = 1,
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 QRSPARSE.  LENQR is the
C length of QRSPARSE, and ROWPOS contains the indices of the diagonal
C elements of the Jacobian matrix within QRSPARSE.  ROWPOS(N+1) and
C ROWPOS(N+2) are set by subroutine FODEDS.  The allocatable array COLPOS
C is not used by this storage format.
C
C If MODE = 2,
C evaluate the N x N Jacobian matrix of F(X) at X, and return the result
C in sparse row storage format in QRSPARSE.  LENQR is the length of
C QRSPARSE, ROWPOS contains the indices of where each row begins within
C QRSPARSE, and COLPOS (of length LENQR) contains the column indices of
C the corresponding elements in QRSPARSE.  Even if zero, the diagonal
C elements of the Jacobian matrix must be stored in QRSPARSE.
      INTERFACE
         SUBROUTINE FJACS(X)
         USE REAL_PRECISION
         USE HOMPACK90_GLOBAL, ONLY: QRSPARSE, ROWPOS, COLPOS
         REAL (KIND=R8), DIMENSION(:), INTENT(IN):: X
         END SUBROUTINE FJACS
      END INTERFACE
!
!
C Interface for subroutine that evaluates a sparse Jacobian matrix of
C RHO(A,X,LAMBDA) at (A,X,LAMBDA), and operates as follows:
C
C If MODE = 1,
C evaluate the N X N symmetric Jacobian matrix [D RHO/DX] at
C (A,X,LAMBDA), and return the result in packed skyline storage format in
C QRSPARSE.  LENQR is the length of QRSPARSE, and ROWPOS contains the
C indices of the diagonal elements of [D RHO/DX] within QRSPARSE.  PP
C contains -[D RHO/D LAMBDA] evaluated at (A,X,LAMBDA).  Note the minus
C sign in the definition of PP.  The allocatable array COLPOS is not used
C in this storage format.
C
C If MODE = 2,
C evaluate the N X (N+1) Jacobian matrix [D RHO/DX, D RHO/DLAMBDA] at
C (A,X,LAMBDA), and return the result in sparse row storage format in
C QRSPARSE.  LENQR is the length of QRSPARSE, ROWPOS contains the indices
C of where each row begins within QRSPARSE, and COLPOS (of length LENQR)
C contains the column indices of the corresponding elements in QRSPARSE.
C Even if zero, the diagonal elements of the Jacobian matrix must be
C stored in QRSPARSE.  The allocatable array PP is not used in this
C storage format.
C
      INTERFACE
         SUBROUTINE RHOJS(A,LAMBDA,X)
         USE REAL_PRECISION
         USE HOMPACK90_GLOBAL, ONLY: QRSPARSE, ROWPOS, COLPOS
         REAL (KIND=R8), INTENT(IN):: A(:),LAMBDA,X(:)
         END SUBROUTINE RHOJS
      END INTERFACE
      END MODULE HOMOTOPY

		

		
      MODULE HOMPACK90
!
!  This MODULE is an encapsulation of the HOMPACK90 drivers, and uses
!  the modules REAL_PRECISION (defines real precision for all
!  routines), HOMPACK90_GLOBAL (allocatable global data structures for
!  sparse matrices), and HOMOTOPY (interfaces to user written routines
!  defining the problem).
!
!  The intended usage is that the calling program would include a
!  statement like, for example,
!     USE HOMPACK90, ONLY : FIXPNF
!
      USE REAL_PRECISION, ONLY : R8    ! Kind for all reals.
      USE HOMPACK90_GLOBAL             ! Allocated data structures.
      CONTAINS
!
      SUBROUTINE FIXPDF(N,Y,IFLAG,ARCTOL,EPS,TRACE,A,NDIMA,
     &   NFE,ARCLEN)
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)  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)
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 Whichever of the routines  F,  FJAC,  RHOA,  RHOJAC  are required
C should be supplied as external subroutines, conforming with the
C interfaces in the module  HOMOTOPY.
C FIXPDF  directly or indirectly uses the subroutines
C   F (or  RHOA ),  FJAC (or  RHOJAC ),  FODE,   ROOT,
C   SINTRP,  STEPS,  the LAPACK routine  DGEQPF,  auxiliary LAPACK 
C routines, and the BLAS functions  DCOPY,  DDOT,  DGEMV,  DGER,  
C   DNRM2,  DSCAL,  DSWAP,  IDAMAX.  
C The module  REAL_PRECISION  specifies 64-bit real arithmetic, which
C the user may want to change.
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 array 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*SQRT(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, used for the curve tracking problem,
C    and must be N for the fixed point and zero finding problems.
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   8   Memory allocation error, fatal.
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 matrix evaluations).
C
C ARCLEN  is the length of the path followed.
C
C
C Automatic work arrays:
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:3*N+3), 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
      USE HOMOTOPY
      USE REAL_PRECISION
C
      INTEGER, INTENT(IN)::N,NDIMA,TRACE
      REAL (KIND=R8), DIMENSION(:), INTENT(IN OUT)::A,Y
      INTEGER, INTENT(IN OUT)::IFLAG
      REAL (KIND=R8), INTENT(IN OUT)::ARCTOL,EPS
      INTEGER, INTENT(OUT)::NFE
      REAL (KIND=R8), INTENT(OUT)::ARCLEN
C
C LOCAL VARIABLES.
      REAL (KIND=R8), SAVE:: CURSW,CURTOL,EPSSTP,EPST,H,HOLD,
     &  S,S99,SA,SB,SOUT,SQNP1,XOLD,Y1SOUT
      INTEGER, SAVE:: IFLAGC,ITER,IVC,JW,K,KGI,KOLD,
     &  KSTEPS,LCODE,LIMIT,NFEC,NP1
      LOGICAL, SAVE:: CRASH,START,ST99
C
C *****  ARRAY DECLARATIONS.  *****
C
C ARRAYS NEEDED BY THE ODE SUBROUTINE  STEPS .
      REAL (KIND=R8), ALLOCATABLE, SAVE:: P(:),PHI(:,:),WT(:),YP(:)
      REAL (KIND=R8), SAVE:: ALPHAS(12),G(13),GI(11),W(12)
      INTEGER, SAVE:: IV(10)
C
C ARRAYS NEEDED BY  FIXPDF , FODE , AND LAPACK ROUTINES.
      REAL (KIND=R8), DIMENSION(:), ALLOCATABLE, SAVE:: YPOLD
      REAL (KIND=R8):: ALPHA(3*N+3),AOLD(NDIMA),QR(N,N+1),TZ(N+1)
      INTEGER:: PIVOT(N+1)
C
C *****  END OF DIMENSIONAL INFORMATION.  *****
C
C LIMITD  IS AN UPPER BOUND ON THE NUMBER OF STEPS.  IT MAY BE
C CHANGED BY CHANGING THE FOLLOWING PARAMETER STATEMENT:
      INTEGER, PARAMETER:: LIMITD=1000
C
      INTERFACE
        SUBROUTINE FODE(S,Y,YP,YPOLD,A,QR,ALPHA,TZ,PIVOT,NFE,N,IFLAG)
        USE REAL_PRECISION
        REAL (KIND=R8):: S
        INTEGER:: IFLAG,N,NFE
        REAL (KIND=R8):: A(:),Y(:),YP(N+1),YPOLD(N+1)
        REAL (KIND=R8):: ALPHA(3*N+3),QR(N,N+1),TZ(N+1)
        INTEGER, DIMENSION(N+1):: PIVOT
        END SUBROUTINE FODE
        SUBROUTINE STEPS(F,NEQN,Y,X,H,EPS,WT,START,HOLD,K,KOLD,CRASH,
     &  PHI,P,YP,ALPHA,W,G,KSTEPS,XOLD,IVC,IV,KGI,GI,  FPWA1,FPWA2,
     &  FPWA3,FPWA4,FPWA5,IFPWA1,IFPC1,IFPC2)
        USE REAL_PRECISION
        EXTERNAL F
        REAL (KIND=R8):: ALPHA,EPS,FPWA1,FPWA2,FPWA3,FPWA4,FPWA5,
     &  G,GI,H,HOLD,P,PHI,W,WT,X,XOLD,Y,YP
        INTEGER:: IFPC1,IFPC2,IFPWA1,IV,IVC,K,KGI,KOLD,KSTEPS,NEQN
        LOGICAL:: CRASH,START
        DIMENSION Y(:),WT(NEQN),PHI(NEQN,16),P(NEQN),YP(NEQN),
     &  ALPHA(12),W(12),G(13),GI(11),IV(10),
     &  FPWA1(NEQN),FPWA2(:),FPWA3(NEQN-1,NEQN),FPWA4(3*NEQN),
     &  FPWA5(NEQN),IFPWA1(NEQN)
        END SUBROUTINE STEPS
      END INTERFACE
C
C
C :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :
      IF (N .LE. 0  .OR.  EPS .LE. 0.0  .OR.  N+1 .NE. SIZE(Y)
     &  .OR.  NDIMA .NE. SIZE(A)  .OR.
     &  ((IFLAG .EQ. -1  .OR.  IFLAG .EQ. 0) .AND.  N .NE. SIZE(A)))
     &  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))
      IF (ALLOCATED(P)) DEALLOCATE(P)
      IF (ALLOCATED(PHI)) DEALLOCATE(PHI)
      IF (ALLOCATED(WT)) DEALLOCATE(WT)
      IF (ALLOCATED(YP)) DEALLOCATE(YP)
      IF (ALLOCATED(YPOLD)) DEALLOCATE(YPOLD)
      ALLOCATE(P(NP1),PHI(NP1,16),WT(NP1),YP(NP1),YPOLD(NP1),
     &  STAT=JW)
      IF (JW /= 0) THEN
        IFLAG=8
        RETURN
      END IF
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
      YPOLD(2:NP1)=0.0
      YP(2:NP1)=0.0
C LOAD  A  FOR THE FIXED POINT AND ZERO FINDING PROBLEMS.
      IF (IFLAGC .GE. -1) THEN
        A=Y(2:NP1)
      ENDIF
30    LIMIT=LIMITD
C
C *****  END OF INITIALIZATION BLOCK.  *****
C
35    MAIN_LOOP: DO ITER=1,LIMIT  ! *****  MAIN LOOP.  *****
      IF (Y(1) .LT. 0.0) THEN
        ARCLEN=ARCLEN+S
        IFLAG=5
        CALL CLEANUP ; RETURN
      ENDIF
      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
        AOLD=A
        CALL RHOA(A,Y(1),Y(2:NP1))
C IF NEW AND OLD  A  DIFFER BY TOO MUCH, TRACKING SHOULD NOT CONTINUE.
        IF (ANY(ABS(A-AOLD) .GT. 1.0+ABS(AOLD))) THEN
          ARCLEN=ARCLEN+S
          IFLAG=5
          CALL CLEANUP ; RETURN
        ENDIF
      ELSE
        CALL F(Y(2:NP1),YP(1:N))
        AOLD=A
        IF (IFLAGC .EQ. -1) THEN
          A=Y(1)*YP(1:N)/(1.0 - Y(1)) + Y(2:NP1)
        ELSE
          A=(Y(2:NP1) - Y(1)*YP(1:N))/(1.0 - Y(1))
        ENDIF
C IF NEW AND OLD  A  DIFFER BY TOO MUCH, TRACKING SHOULD NOT CONTINUE.
        IF (ANY(ABS(A-AOLD) .GT. 1.0+ABS(AOLD))) THEN
          ARCLEN=ARCLEN+S
          IFLAG=5
          CALL CLEANUP ; RETURN
        ENDIF
      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
      WHERE (ABS(YP-YPOLD) .LE. CURTOL)
        WT=(ABS(Y)+1.0)
      ELSEWHERE
        WT=(ABS(Y)+1.0)*EPST
      END WHERE
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)
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:'/(1X,6ES12.4))
      ENDIF
      NFE=NFEC
C CHECK IF THE STEP WAS SUCCESSFUL.
      IF (IFLAGC .EQ. 4) THEN
        ARCLEN=ARCLEN+S
        IFLAG=4
        CALL CLEANUP ; RETURN
      ENDIF
      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
      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     Y=WT
        YPOLD=YP
        S=S99
        GO TO 90
      ENDIF
C
      END DO MAIN_LOOP  ! *****  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
      Y=WT
      CALL CLEANUP ; RETURN
C
      CONTAINS
        SUBROUTINE CLEANUP
        IF (ALLOCATED(P)) DEALLOCATE(P)
        IF (ALLOCATED(PHI)) DEALLOCATE(PHI)
        IF (ALLOCATED(WT)) DEALLOCATE(WT)
        IF (ALLOCATED(YP)) DEALLOCATE(YP)
        IF (ALLOCATED(YPOLD)) DEALLOCATE(YPOLD)
        END SUBROUTINE CLEANUP
      END SUBROUTINE FIXPDF
!
      SUBROUTINE FIXPDS(N,Y,IFLAG,ARCTOL,EPS,TRACE,A,NDIMA,NFE,
     &     ARCLEN,MODE,LENQR)
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)  which evaluates, if
C MODE = 1,
C   the (symmetric) Jacobian matrix of F(X) at X, and returns the
C   symmetric Jacobian matrix in packed skyline storage format in
C   QR, or if
C MODE = 2,
C   returns the (nonsymmetric) Jacobian matrix in sparse row format
C   in QR.  The MODE 1 format is defined by QR, LENQR, ROWPOS; the
C   MODE 2 format is defined by QR, LENQR, ROWPOS, COLPOS.
C
C For the curve tracking problem, the user must supply a subroutine
C  RHOA(V,LAMBDA,X)  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)  which, if
C MODE = 1,
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).  This data structure is described by QR, LENQR,
C   ROWPOS, PP.  *** Note the minus sign in the definition of PP. ***  If
C MODE = 2,
C   the (nonsymmetric) N X (N+1) Jacobian matrix [D RHO/DX, D RHO/DLAMBDA]
C   evaluated at (A,X,LAMBDA) is returned in a data structure described
C   by QR, LENQR, ROWPOS, COLPOS.
C
C Whichever of the routines  F,  FJACS,  RHOA,  RHOJS  are required
C should be supplied as external subroutines, conforming with the
C interfaces in the module  HOMOTOPY.
C
C
C Functions and subroutines directly or indirectly called by FIXPDS:
C DLAIC1  and  DLAMCH (LAPACK), F (or  RHOA ), FJACS (or  RHOJS ),
C FODEDS , GMFADS , GMRES , GMRILUDS , ILUFDS , ILUSOLVDS , MULTDS ,
C MULT2DS , PCGDS , ROOT , SINTRP , SOLVDS , STEPDS , and the BLAS
C functions  DDOT , DNRM2.  The module  REAL_PRECISION  specifies 64-bit
C real arithmetic, which the user may want to change.
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 array 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*SQRT(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, used for the curve tracking problem,
C    and must be N for the fixed point and zero finding problems.
C
C MODE = 1 if the Jacobian matrix is symmetric and stored in a packed
C          skyline format;
C      = 2 if the Jacobian matrix is stored in a sparse row format.
C
C LENQR  is the number of nonzero entries in the sparse Jacobian
C    matrices, used to determine the sparse matrix data structures.
C
C A, 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 or has a zero on the
C       diagonal, and/or the conjugate gradient iteration for the
C       kernel of the Jacobian matrix failed to converge.  The
C       algorithm has failed (the zero curve of the homotopy map
C       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
C Allocatable and automatic work arrays:
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), PP(1:N), ROWPOS(1:N+2), COLPOS(1:LENQR) are all work
C    arrays used to define the sparse Jacobian matrices, allocated
C    here, and distributed via the module  HOMOTOPY .
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
      USE HOMOTOPY, QR => QRSPARSE
      USE REAL_PRECISION
      INTEGER, INTENT(IN)::LENQR,MODE,N,NDIMA,TRACE
      REAL (KIND=R8), DIMENSION(:), INTENT(IN OUT)::A,Y
      INTEGER, INTENT(IN OUT)::IFLAG
      REAL (KIND=R8), INTENT(IN OUT)::ARCTOL,EPS
      INTEGER, INTENT(OUT)::NFE
      REAL (KIND=R8), INTENT(OUT)::ARCLEN
C
C *****  LOCAL VARIABLES.  *****
C
      REAL (KIND=R8), SAVE:: CURSW,CURTOL,EPSSTP,EPST,
     &  H,HOLD,S,S99,SA,SB,SOUT,SQNP1,XOLD,Y1SOUT
      INTEGER, SAVE:: IFLAGC,ITER,IVC,JW,K,KGI,KOLD,
     &  KSTEPS,LCODE,LIMIT,NFEC,NP1
      LOGICAL, SAVE:: CRASH,START,ST99
C
C ARRAYS NEEDED BY THE ODE SUBROUTINE  STEPDS .
      REAL (KIND=R8), SAVE:: ALPHAS(12),G(13),GI(11),W(12)
      REAL (KIND=R8), ALLOCATABLE, SAVE:: P(:),PHI(:,:),WT(:),YP(:)
      INTEGER, SAVE:: IV(10)
C
C ARRAYS NEEDED BY  FIXPDS , FODEDS , AND  PCGDS .
      REAL (KIND=R8), ALLOCATABLE, DIMENSION(:), SAVE:: AOLD,YPOLD
C
C *****  END OF DIMENSIONAL INFORMATION.  *****
C
      INTERFACE
        SUBROUTINE FODEDS(S,Y,YP,N,IFLAG,YPOLD,A,NDIMA,LENQR,MODE,NFE)
        USE HOMOTOPY, QR => QRSPARSE
        USE REAL_PRECISION
        INTEGER:: IFLAG,LENQR,MODE,N,NDIMA,NFE
        REAL (KIND=R8):: A(NDIMA),S,Y(N+1),YP(N+1),YPOLD(N+1)
        END SUBROUTINE FODEDS
      END INTERFACE
C
C LIMITD  IS AN UPPER BOUND ON THE NUMBER OF STEPS.  IT MAY BE
C CHANGED BY CHANGING THE FOLLOWING PARAMETER STATEMENT:
      INTEGER, PARAMETER:: LIMITD=1000
C
C
C :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :
      IF (N .LE. 0  .OR.  EPS .LE. 0.0  .OR.  N+1 .NE. SIZE(Y)
     &  .OR.  NDIMA .NE. SIZE(A)  .OR.
     &  ((IFLAG .EQ. -1  .OR.  IFLAG .EQ. 0) .AND.  N .NE. SIZE(A))
     &  .OR.  MODE .LE. 0  .OR.  MODE .GE. 3)
     &  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(REAL(NP1,KIND=R8))
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 ALLOCATE SAVED WORK ARRAYS.
      IF (ALLOCATED(AOLD)) DEALLOCATE(AOLD)
      IF (ALLOCATED(P)) DEALLOCATE(P)
      IF (ALLOCATED(PHI)) DEALLOCATE(PHI)
      IF (ALLOCATED(WT)) DEALLOCATE(WT)
      IF (ALLOCATED(YP)) DEALLOCATE(YP)
      IF (ALLOCATED(YPOLD)) DEALLOCATE(YPOLD)
      ALLOCATE(AOLD(NDIMA),P(NP1),PHI(NP1,16),WT(NP1),YP(NP1),
     &  YPOLD(NP1))
C SET INITIAL CONDITIONS FOR ORDINARY DIFFERENTIAL EQUATION.
      YPOLD(NP1)=1.0
      YP(NP1)=1.0
      Y(NP1)=0.0
      YPOLD(1:N)=0.0
      YP(1:N)=0.0
C LOAD  A  FOR THE FIXED POINT AND ZERO FINDING PROBLEMS.
      IF (IFLAGC .GE. -1) THEN
        A=Y(1:N)
      ENDIF
30    LIMIT=LIMITD
C ALLOCATE ARRAYS FOR SPARSE JACOBIAN MATRIX DATA STRUCTURE.
35    SELECT CASE (MODE)
        CASE (1)
          IF (.NOT. ALLOCATED(QR)) ALLOCATE(QR(LENQR))
          IF (.NOT. ALLOCATED(ROWPOS)) ALLOCATE(ROWPOS(N+2))
          IF (.NOT. ALLOCATED(PP)) ALLOCATE(PP(N))
        CASE (2)
          IF (.NOT. ALLOCATED(QR)) ALLOCATE(QR(LENQR))
          IF (.NOT. ALLOCATED(ROWPOS)) ALLOCATE(ROWPOS(N+2))
          IF (.NOT. ALLOCATED(COLPOS)) ALLOCATE(COLPOS(LENQR))
          IF ((.NOT. ALLOCATED(PP)) .AND. (IFLAGC .GE. -1))
     &      ALLOCATE(PP(N))
      END SELECT
C
C *****  END OF INITIALIZATION BLOCK.  *****
C
      MAIN_LOOP: DO ITER=1,LIMIT  ! *****  MAIN LOOP.  *****
      IF (Y(NP1) .LT. 0.0) THEN
        ARCLEN=ARCLEN+S
        IFLAG=5
        CALL CLEANUPALL
        RETURN
      ENDIF
      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
        AOLD=A
        CALL RHOA(A,Y(NP1),Y(1:N))
C IF NEW AND OLD  A  DIFFER BY TOO MUCH, TRACKING SHOULD NOT CONTINUE.
        IF (ANY(ABS(A-AOLD) .GT. 1.0+ABS(AOLD))) THEN
            ARCLEN=ARCLEN+S
            IFLAG=5
            CALL CLEANUPALL
            RETURN
        ENDIF
      ELSE
        CALL F(Y(1:N),YP(1:N))
        AOLD=A
        IF (IFLAGC .EQ. -1) THEN
          A=Y(NP1)*YP(1:N)/(1.0 - Y(NP1)) + Y(1:N)
        ELSE
          A=(Y(1:N) - Y(NP1)*YP(1:N))/(1.0 - Y(NP1))
        ENDIF
C IF NEW AND OLD  A  DIFFER BY TOO MUCH, TRACKING SHOULD NOT CONTINUE.
        IF (ANY(ABS(A-AOLD) .GT. 1.0+ABS(AOLD))) THEN
            ARCLEN=ARCLEN+S
            IFLAG=5
            CALL CLEANUPALL
            RETURN
        ENDIF
      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
      WHERE (ABS(YP-YPOLD) .LE. CURTOL)
        WT=(ABS(Y)+1.0)
      ELSEWHERE
        WT=(ABS(Y)+1.0)*EPST
      END WHERE
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,
     &     IFLAGC,YPOLD,A,NDIMA,LENQR,MODE,NFEC)
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:'/(1X,6ES12.4))
      ENDIF
      NFE=NFEC
C CHECK IF THE STEP WAS SUCCESSFUL.
      IF (IFLAGC .EQ. 4) THEN
        ARCLEN=ARCLEN+S
        IFLAG=4
        CALL CLEANUPALL
        RETURN
      ENDIF
      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
        CALL CLEANUP
        RETURN
      ENDIF
C
      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     Y=WT
        YPOLD=YP
        S=S99
        GO TO 90
      ENDIF
C
      END DO MAIN_LOOP ! *****  END OF MAIN LOOP.  *****
C
C LAMBDA HAS NOT REACHED 1 IN 1000 STEPS.
      IFLAG=3
      CALL CLEANUP
      RETURN
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
      Y=WT
      CALL CLEANUPALL
      RETURN
C
      CONTAINS
      SUBROUTINE CLEANUPALL
      IF (ALLOCATED(AOLD)) DEALLOCATE(AOLD)
      IF (ALLOCATED(P)) DEALLOCATE(P)
      IF (ALLOCATED(PHI)) DEALLOCATE(PHI)
      IF (ALLOCATED(WT)) DEALLOCATE(WT)
      IF (ALLOCATED(YP)) DEALLOCATE(YP)
      IF (ALLOCATED(YPOLD)) DEALLOCATE(YPOLD)
      CALL CLEANUP
      RETURN
      END SUBROUTINE CLEANUPALL
      SUBROUTINE CLEANUP
      IF (ALLOCATED(QR)) DEALLOCATE(QR)
      IF (ALLOCATED(ROWPOS)) DEALLOCATE(ROWPOS)
      IF (ALLOCATED(COLPOS)) DEALLOCATE(COLPOS)
      IF (ALLOCATED(PP)) DEALLOCATE(PP)
      IF (ALLOCATED(PAR)) DEALLOCATE(PAR)
      IF (ALLOCATED(IPAR)) DEALLOCATE(IPAR)
      RETURN
      END SUBROUTINE CLEANUP
      END SUBROUTINE FIXPDS
!
      SUBROUTINE FIXPNF(N,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE,A,
     &   SSPAR,NFE,ARCLEN,  POLY_SWITCH)
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)  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)  which returns in V the Kth
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  F (or  RHO ),  FJAC (or  RHOJAC ), 
C   ROOT,  ROOTNF,  STEPNF,  the LAPACK routines  DGEQPF,  DORMQR,  
C their auxiliary routines, and the BLAS routines  DCOPY,
C   DDOT,  DGEMM,  DGEMV,  DGER,  DNRM2,  DSCAL,  DSWAP,  DTRMM,  DTRMV, 
C   IDAMAX.  The module  REAL_PRECISION  specifies 64-bit
C real arithmetic, which the user may want to change.
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 array 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(:)  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 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 POLY_SWITCH  is an optional logical variable used only by the driver
C    POLSYS1H  for polynomial systems.
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   8   Memory allocation error, fatal.
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 matrix evaluations).
C
C ARCLEN  is the length of the path followed.
C
C
C Allocatable and automatic work arrays:
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:3*N+3), 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
      USE REAL_PRECISION
      INTEGER, INTENT(IN)::N,TRACE
      REAL (KIND=R8), DIMENSION(:), INTENT(IN OUT)::A,Y
      INTEGER, INTENT(IN OUT)::IFLAG
      REAL (KIND=R8), INTENT(IN OUT)::ANSAE,ANSRE,ARCAE,ARCRE,
     &    SSPAR(8)
      INTEGER, INTENT(OUT)::NFE
      REAL (KIND=R8), INTENT(OUT)::ARCLEN
      LOGICAL, INTENT(IN), OPTIONAL::POLY_SWITCH
C
C LOCAL VARIABLES.
      REAL (KIND=R8), SAVE:: ABSERR,CURTOL,H,HOLD,RELERR,S
      INTEGER, SAVE:: IFLAGC,ITER,JW,LIMIT,NC,NFEC,NP1
      LOGICAL, SAVE:: CRASH,POLSYS,START
      INTERFACE
        FUNCTION DNRM2(N,X,STRIDE)
        USE REAL_PRECISION
        INTEGER:: N,STRIDE
        REAL (KIND=R8):: DNRM2,X(N)
        END FUNCTION DNRM2
      END INTERFACE
C
C ALLOCATABLE AND AUTOMATIC ARRAYS.
      REAL (KIND=R8), DIMENSION(:), ALLOCATABLE, SAVE:: YOLD,YP,YPOLD
      REAL (KIND=R8):: ALPHA(3*N+3),QR(N,N+2),TZ(N+1),
     &  W(N+1),WP(N+1),Z0(N+1),Z1(N+1)
      INTEGER:: PIVOT(N+1)
C
C ***** END OF DIMENSIONAL INFORMATION. *****
C
C LIMITD  IS AN UPPER BOUND ON THE NUMBER OF STEPS.  IT MAY BE
C CHANGED BY CHANGING THE FOLLOWING PARAMETER STATEMENT:
      INTEGER, 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.
      REAL (KIND=R8), PARAMETER:: CURSW=10.0
C
      INTERFACE
        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)
        USE REAL_PRECISION
        REAL (KIND=R8):: ABSERR,H,HOLD,RELERR,S
        INTEGER:: IFLAG,N,NFE
        LOGICAL:: CRASH,START
        REAL (KIND=R8):: A(:),ALPHA(3*N+3),QR(N,N+2),SSPAR(8),TZ(N+1),
     &    W(N+1),WP(N+1),Y(:),YOLD(N+1),YP(N+1),YPOLD(N+1),
     &    Z0(N+1),Z1(N+1)
        INTEGER:: PIVOT(N+1)
        END SUBROUTINE STEPNF
        SUBROUTINE ROOTNF(N,NFE,IFLAG,RELERR,ABSERR,Y,YP,YOLD,
     &    YPOLD,A,QR,ALPHA,TZ,PIVOT,W,WP)
        USE REAL_PRECISION
        REAL (KIND=R8):: ABSERR,RELERR
        INTEGER:: IFLAG,N,NFE
        REAL (KIND=R8):: A(:),ALPHA(3*N+3),QR(N,N+2),TZ(N+1),W(N+1),
     &    WP(N+1),Y(:),YOLD(N+1),YP(N+1),YPOLD(N+1)
        INTEGER:: PIVOT(N+1)
        END SUBROUTINE ROOTNF
      END INTERFACE
C
C
C :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :
C TEST LOGICAL SWITCH TO REFLECT INTENDED USAGE OF FIXPNF.
      IF (PRESENT(POLY_SWITCH)) THEN
        POLSYS=.TRUE.
      ELSE
        POLSYS=.FALSE.
      ENDIF
C
      IF (N .LE. 0  .OR.  ANSRE .LE. 0.0  .OR.  ANSAE .LT. 0.0
     &  .OR.  N+1 .NE. SIZE(Y)  .OR.
     &  ((IFLAG .EQ. -1  .OR.  IFLAG .EQ. 0) .AND.  N .NE. SIZE(A)))
     &  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
      IF (ALLOCATED(YP)) DEALLOCATE(YP)
      IF (ALLOCATED(YOLD)) DEALLOCATE(YOLD)
      IF (ALLOCATED(YPOLD)) DEALLOCATE(YPOLD)
      ALLOCATE(YP(NP1),YOLD(NP1),YPOLD(NP1),STAT=JW)
      IF (JW /= 0) THEN
        IFLAG=8
        RETURN
      END IF
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
      YPOLD(2:NP1)=0.0
      YP(2:NP1)=0.0
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)*EPSILON(1.0_R8)
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_R8
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
        A=Y(2:NP1)
      ENDIF
90    LIMIT=LIMITD
C
C *****  END OF INITIALIZATION BLOCK.  *****
C
120   MAIN_LOOP: DO ITER=1,LIMIT  ! *****  MAIN LOOP.  *****
      IF (Y(1) .LT. 0.0) THEN
        ARCLEN=S
        IFLAG=5
        CALL CLEANUP ; RETURN
      ENDIF
C
C SET DIFFERENT ERROR TOLERANCE IF THE TRAJECTORY Y(S) HAS ANY HIGH 
C CURVATURE COMPONENTS.
      CURTOL=CURSW*HOLD
      RELERR=ARCRE
      ABSERR=ARCAE
      IF (ANY(ABS(YP-YPOLD) .GT. CURTOL)) THEN
        RELERR=ANSRE
        ABSERR=ANSAE
      ENDIF
C
C TAKE A STEP ALONG THE CURVE.
      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)
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:'/(1X,6ES12.4))
      ENDIF
      NFE=NFEC
C CHECK IF THE STEP WAS SUCCESSFUL.
      IF (IFLAGC .GT. 0) THEN
        ARCLEN=S
        IFLAG=IFLAGC
        CALL CLEANUP ; 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.
        Z0=YOLD
        CALL ROOTNF(NC,NFEC,IFLAGC,ANSRE,ANSAE,Y,YP,YOLD,YPOLD,
     &              A,QR,ALPHA,TZ,PIVOT,W,WP)
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.
        W=Y-Z0
        ARCLEN=S - HOLD + DNRM2(NP1,W,1)
        CALL CLEANUP ; RETURN
      ENDIF
C
C FOR POLYNOMIAL SYSTEMS AND THE  POLSYS1H  HOMOTOPY MAP,
C D LAMBDA/DS .GE. 0 NECESSARILY.  THIS CONDITION IS FORCED HERE IF
C THE  POLY_SWITCH  VARIABLE IS PRESENT.
C
      IF (POLSYS) THEN
        IF (YP(1) .LT. 0.0) THEN
C REVERSE TANGENT DIRECTION SO D LAMBDA/DS = YP(1) > 0 .
          YP=-YP
          YPOLD=YP
C FORCE  STEPNF  TO USE THE LINEAR PREDICTOR FOR THE NEXT STEP ONLY.
          START=.TRUE.
        ENDIF
      ENDIF
C
      END DO MAIN_LOOP   ! *****  END OF MAIN LOOP.  *****
C
C LAMBDA HAS NOT REACHED 1 IN 1000 STEPS.
      IFLAG=3
      ARCLEN=S
      RETURN
C
      CONTAINS
        SUBROUTINE CLEANUP
        IF (ALLOCATED(YP)) DEALLOCATE(YP)
        IF (ALLOCATED(YOLD)) DEALLOCATE(YOLD)
        IF (ALLOCATED(YPOLD)) DEALLOCATE(YPOLD)
        END SUBROUTINE CLEANUP
      END SUBROUTINE FIXPNF
!
      SUBROUTINE FIXPNS(N,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE,A,
     &   NFE,ARCLEN,MODE,LENQR,SSPAR)
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)  which evaluates, if
C MODE = 1,
C   the (symmetric) Jacobian matrix of F(X) at X, and returns the
C   symmetric Jacobian matrix in packed skyline storage format in
C   QR, or if
C MODE = 2,
C   returns the (nonsymmetric) Jacobian matrix in sparse row format
C   in QR.  The MODE 1 format is defined by QR, LENQR, ROWPOS; the
C   MODE 2 format is defined by QR, LENQR, ROWPOS, COLPOS.
C
C For the curve tracking problem, the user must supply a subroutine
C  RHO(A,LAMBDA,X,V)  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)  which, if
C MODE = 1,
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).  This data structure is described by QR, LENQR,
C   ROWPOS, PP.  *** Note the minus sign in the definition of PP. ***  If
C MODE = 2,
C   the (nonsymmetric) N X (N+1) Jacobian matrix [D RHO/DX, D RHO/DLAMBDA]
C   evaluated at (A,X,LAMBDA) is returned in a data structure described
C   by QR, LENQR, ROWPOS, COLPOS.
C
C Whichever of the routines  F,  FJACS,  RHO,  RHOJS  are required
C should be supplied as external subroutines, conforming with the
C interfaces in the module  HOMOTOPY.
C
C
C Functions and subroutines directly or indirectly called by FIXPNS:
C F (or  RHO ), FJACS (or  RHOJS ), GMFADS , GMRES , GMRILUDS ,
C ILUFDS , ILUSOLVDS , MULTDS , MULT2DS , PCGDS , ROOT , ROOTNS ,
C SOLVDS , STEPNS , TANGNS , and the BLAS functions  DDOT , DLAIC1 ,
C DLAMCH , DNRM2 .  The module  REAL_PRECISION  specifies 64-bit
C real arithmetic, which the user may want to change.
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 array 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(:)  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 MODE = 1 if the Jacobian matrix is symmetric and stored in a packed
C          skyline format;
C      = 2 if the Jacobian matrix is stored in a sparse row format.
C
C LENQR  is the number of nonzero entries in the sparse Jacobian
C    matrices, used to determine the sparse matrix data structures.
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
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, or the Jacobian matrix does not have full rank
C       or has a zero on the diagonal.  The algorithm has failed
C       (the zero curve of the homotopy map cannot be followed any
C       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 Allocatable and automatic work arrays:
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), PP(1:N), ROWPOS(1:N+2), COLPOS(1:LENQR) are all work
C    arrays used to define the sparse Jacobian matrices, allocated
C    here, and distributed via the module  HOMOTOPY.
C
C
C
      USE HOMOTOPY, QR => QRSPARSE
      USE REAL_PRECISION
      INTEGER, INTENT(IN)::LENQR,MODE,N,TRACE
      REAL (KIND=R8), DIMENSION(:), INTENT(IN OUT)::A,Y
      INTEGER, INTENT(IN OUT)::IFLAG
      REAL (KIND=R8), INTENT(IN OUT)::ANSAE,ANSRE,ARCAE,ARCRE,SSPAR(8)
      INTEGER, INTENT(OUT)::NFE
      REAL (KIND=R8), INTENT(OUT)::ARCLEN
C
C *****  LOCAL VARIABLES.  *****
C
      REAL (KIND=R8), SAVE:: ABSERR,CURTOL,H,HOLD,RELERR,S
      INTEGER, SAVE:: IFLAGC,ITER,JW,LIMIT,NC,NFEC,NP1
      LOGICAL, SAVE:: CRASH,START
      INTERFACE
        FUNCTION DNRM2(N,X,STRIDE)
        USE REAL_PRECISION
        INTEGER:: N,STRIDE
        REAL (KIND=R8):: DNRM2,X(N)
        END FUNCTION DNRM2
      END INTERFACE
C ***** WORK ARRAYS. *****
      REAL (KIND=R8), ALLOCATABLE, DIMENSION(:), SAVE:: YP,YOLD,YPOLD
      REAL (KIND=R8):: TZ(N+1),W(N+1),WP(N+1),Z0(N+1),Z1(N+1)
C
C LIMITD  IS AN UPPER BOUND ON THE NUMBER OF STEPS.  IT MAY BE
C CHANGED BY CHANGING THE FOLLOWING PARAMETER STATEMENT:
      INTEGER, 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.
      REAL (KIND=R8), PARAMETER:: CURSW=10.0
C
      INTERFACE
        SUBROUTINE ROOTNS(NC,NFEC,IFLAGC,ANSRE,ANSAE,Y,YP,YOLD,YPOLD,
     &     A,MODE,LENQR)
        USE HOMOTOPY, QR => QRSPARSE
        USE REAL_PRECISION
        INTEGER, INTENT(IN):: LENQR,MODE,NC
        INTEGER, INTENT(IN OUT):: IFLAGC,NFEC
        REAL (KIND=R8), INTENT(IN):: A(:)
        REAL (KIND=R8), INTENT(IN):: ANSAE,ANSRE
        REAL (KIND=R8), DIMENSION(:), INTENT(IN OUT):: Y,YOLD,YP,YPOLD
        END SUBROUTINE ROOTNS
C
        SUBROUTINE STEPNS(NC,NFEC,IFLAGC,START,CRASH,HOLD,H,RELERR,
     &     ABSERR,S,Y,YP,YOLD,YPOLD,A,MODE,LENQR,SSPAR,TZ,W,WP,Z0,Z1)
        USE HOMOTOPY, QR => QRSPARSE
        USE REAL_PRECISION
        INTEGER, INTENT(IN):: LENQR,MODE,NC
        INTEGER, INTENT(IN OUT):: IFLAGC,NFEC
        LOGICAL, INTENT(IN OUT):: CRASH,START
        REAL (KIND=R8), INTENT(IN):: A(:),SSPAR(8)
        REAL (KIND=R8), INTENT(IN OUT):: ABSERR,H,HOLD,RELERR,S,
     &    Y(:),YOLD(:),YP(:),YPOLD(:)
        REAL (KIND=R8), INTENT(OUT), DIMENSION(:):: TZ,W,WP,Z0,Z1
        END SUBROUTINE STEPNS
      END INTERFACE
C
C ***** END OF SPECIFICATION INFORMATION. *****
C
C :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :  :
      IF (N .LE. 0  .OR.  ANSRE .LE. 0.0  .OR.  ANSAE .LT. 0.0
     &  .OR.  N+1 .NE. SIZE(Y) .OR.
     &  ((IFLAG .EQ. -1  .OR.  IFLAG .EQ. 0) .AND.  N .NE. SIZE(A))
     &  .OR.  MODE .LE. 0  .OR.  MODE .GE. 3)
     &                                                     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 ALLOCATE SAVED WORK ARRAYS.
      IF (ALLOCATED(YOLD)) DEALLOCATE(YOLD)
      IF (ALLOCATED(YP)) DEALLOCATE(YP)
      IF (ALLOCATED(YPOLD)) DEALLOCATE(YPOLD)
      ALLOCATE(YOLD(NP1),YP(NP1),YPOLD(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
      YPOLD(1:N)=0.0
      YP(1:N)=0.0
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_R8
C IDEAL RESIDUAL FACTOR:  ||RHO(A, Z[1])|| / ||RHO(A, Z[0])||
      IF (SSPAR(2) .LE. 0.0) SSPAR(2)= .01_R8
C IDEAL DISTANCE FACTOR:  ||Z[1] - Y|| / ||Z[0] - Y||
      IF (SSPAR(3) .LE. 0.0) SSPAR(3)= .5_R8
C MINIMUM STEP SIZE  HMIN .
      IF (SSPAR(4) .LE. 0.0) SSPAR(4)=(SQRT(N+1.0)+4.0)*EPSILON(1.0_R8)
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_R8
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) A(1:N) = Y(1:N)
90    LIMIT=LIMITD
C ALLOCATE ARRAYS FOR SPARSE JACOBIAN MATRIX DATA STRUCTURE.
120   SELECT CASE (MODE)
        CASE (1)
          IF (.NOT. ALLOCATED(QR)) ALLOCATE(QR(LENQR))
          IF (.NOT. ALLOCATED(ROWPOS)) ALLOCATE(ROWPOS(N+2))
          IF (.NOT. ALLOCATED(PP)) ALLOCATE(PP(N))
        CASE (2)
          IF (.NOT. ALLOCATED(QR)) ALLOCATE(QR(LENQR))
          IF (.NOT. ALLOCATED(ROWPOS)) ALLOCATE(ROWPOS(N+2))
          IF (.NOT. ALLOCATED(COLPOS)) ALLOCATE(COLPOS(LENQR))
          IF ((.NOT. ALLOCATED(PP)) .AND. (IFLAGC .GE. -1))
     &      ALLOCATE(PP(N))
      END SELECT
C
C *****  END OF INITIALIZATION BLOCK.  *****
C
      MAIN_LOOP: DO ITER=1,LIMIT  ! *****  MAIN LOOP.  *****
      IF (Y(NP1) .LT. 0.0) THEN
        ARCLEN=S
        IFLAG=5
        CALL CLEANUPALL
        RETURN
      ENDIF
C
C SET DIFFERENT ERROR TOLERANCE IF THE TRAJECTORY Y(S) HAS ANY HIGH 
C CURVATURE COMPONENTS.
      CURTOL=CURSW*HOLD
      RELERR=ARCRE
      ABSERR=ARCAE
        IF (ANY(ABS(YP-YPOLD) .GT. CURTOL)) THEN
          RELERR=ANSRE
          ABSERR=ANSAE
        ENDIF
C
C TAKE A STEP ALONG THE CURVE.
      CALL STEPNS(NC,NFEC,IFLAGC,START,CRASH,HOLD,H,RELERR,
     &     ABSERR,S,Y,YP,YOLD,YPOLD,A,MODE,LENQR,SSPAR,TZ,W,WP,Z0,Z1)
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:'/(1X,6ES12.4))
      ENDIF
      NFE=NFEC
C CHECK IF THE STEP WAS SUCCESSFUL.
      IF (IFLAGC .GT. 0) THEN
        ARCLEN=S
        IFLAG=IFLAGC
        CALL CLEANUPALL
        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
        CALL CLEANUP
        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.
        W=YOLD
C
        CALL ROOTNS(NC,NFEC,IFLAGC,ANSRE,ANSAE,Y,YP,YOLD,YPOLD,
     &              A,MODE,LENQR)
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.
        W = Y - W
        ARCLEN = S - HOLD + DNRM2(NP1,W,1)
        CALL CLEANUPALL
        RETURN
      ENDIF
C
      END DO MAIN_LOOP  !  *****  END OF MAIN LOOP.  *****
C
C LAMBDA HAS NOT REACHED 1 IN 1000 STEPS.
      IFLAG=3
      ARCLEN=S
      CALL CLEANUP
      RETURN
C
      CONTAINS
      SUBROUTINE CLEANUPALL
      IF (ALLOCATED(YOLD)) DEALLOCATE(YOLD)
      IF (ALLOCATED(YP)) DEALLOCATE(YP)
      IF (ALLOCATED(YPOLD)) DEALLOCATE(YPOLD)
      CALL CLEANUP
      RETURN
      END SUBROUTINE CLEANUPALL
      SUBROUTINE CLEANUP
      IF (ALLOCATED(QR)) DEALLOCATE(QR)
      IF (ALLOCATED(ROWPOS)) DEALLOCATE(ROWPOS)
      IF (ALLOCATED(COLPOS)) DEALLOCATE(COLPOS)
      IF (ALLOCATED(PP)) DEALLOCATE(PP)
      IF (ALLOCATED(PAR)) DEALLOCATE(PAR)
      IF (ALLOCATED(IPAR)) DEALLOCATE(IPAR)
      RETURN
      END SUBROUTINE CLEANUP
      END SUBROUTINE FIXPNS
!
      SUBROUTINE FIXPQF(N,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE,A,
     &     SSPAR,NFE,ARCLEN)
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)  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)  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  F (or RHO), 
C   FJAC (or RHOJAC),  ROOT,  ROOTQF,  STEPQF,  TANGQF,  UPQRQF,
C the LAPACK routines  DGEQRF,  DORGQR, their auxiliary routines,
C and the BLAS routines  DCOPY,  DDOT,  DGEMM,  DGEMV,
C   DGER,  DNRM2,  DSCAL,  DTPMV,  DTPSV,  DTRMM,  and   DTRMV.
C The module  REAL_PRECISION  specifies 64-bit real arithmetic,
C which the user may want to change.
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(:)  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 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
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   8   Memory allocation error, fatal.
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
C Allocatable and automatic work arrays:
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 Q(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
C ***** DECLARATIONS *****
      USE REAL_PRECISION
C
C     FUNCTION DECLARATIONS 
C 
      INTERFACE
        FUNCTION DNRM2(N,X,STRIDE)
        USE REAL_PRECISION
        INTEGER:: N,STRIDE
        REAL (KIND=R8):: DNRM2,X(N)
        END FUNCTION DNRM2
      END INTERFACE
C
C     LOCAL VARIABLES 
C
      REAL (KIND=R8), SAVE:: ABSERR, H, HOLD, RELERR, S, WK 
      INTEGER, SAVE:: IFLAGC, ITER, JW, LIMIT, NP1
      LOGICAL, SAVE:: CRASH, START       
C
C     SCALAR ARGUMENTS 
C
      REAL (KIND=R8):: ARCRE, ARCAE, ANSRE, ANSAE, ARCLEN
      INTEGER:: N,IFLAG,TRACE,NFE
C
C     ARRAY DECLARATIONS 
C
      REAL (KIND=R8), DIMENSION(:), ALLOCATABLE, SAVE::
     &  R,YOLD,YP,YPOLD
      REAL (KIND=R8), DIMENSION(:,:), ALLOCATABLE, SAVE:: Q
      REAL (KIND=R8):: A(:), DZ(N+1), F0(N+1), F1(N+1),
     &    SSPAR(4), T(N+1), W(N+1), Y(:), YSAV(N+1), Z0(N+1)
C 
C ***** END OF DECLARATIONS *****
      INTERFACE
        SUBROUTINE STEPQF(N,NFE,IFLAG,START,CRASH,HOLD,H,
     &    WK,RELERR,ABSERR,S,Y,YP,YOLD,YPOLD,A,Q,R,
     &    F0,F1,Z0,DZ,W,T,SSPAR)
        USE REAL_PRECISION
        INTEGER:: N, NFE, IFLAG
        LOGICAL:: START, CRASH
        REAL (KIND=R8):: HOLD, H, WK, RELERR, ABSERR, S
        REAL (KIND=R8):: A(:), DZ(N+1), F0(N+1), F1(N+1), 
     &    Q(N+1,N+1), R((N+1)*(N+2)/2), SSPAR(4), T(N+1), W(N+1),
     &    Y(:), YOLD(N+1), YP(N+1), YPOLD(N+1), Z0(N+1)
        END SUBROUTINE STEPQF
        SUBROUTINE ROOTQF(N,NFE,IFLAG,RELERR,ABSERR,Y,YP,YOLD,
     &    YPOLD,A,Q,R,DZ,Z,W,T,F0,F1)
        USE REAL_PRECISION
        REAL (KIND=R8):: RELERR, ABSERR
        INTEGER:: N, NFE, IFLAG
        REAL (KIND=R8):: A(:), DZ(N+1), F0(N+1), F1(N+1), 
     &    Q(N+1,N+1), R((N+1)*(N+2)/2), T(N+1), W(N+1),
     &    Y(:), YOLD(N+1), YP(N+1), YPOLD(N+1), Z(N+1)
        END SUBROUTINE ROOTQF
      END INTERFACE
C
C LIMITD IS AN UPPER BOUND ON THE NUMBER OF STEPS.  IT MAY BE 
C CHANGED BY CHANGING THE FOLLOWING PARAMETER STATEMENT:
      INTEGER, 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
     &  .OR.  N+1 .NE. SIZE(Y)  .OR.
     &  ((IFLAG .EQ. -1  .OR.  IFLAG .EQ. 0) .AND.  N .NE. SIZE(A)))
     &  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
      IF (ALLOCATED(Q)) DEALLOCATE(Q)
      IF (ALLOCATED(R)) DEALLOCATE(R)
      IF (ALLOCATED(YOLD)) DEALLOCATE(YOLD)
      IF (ALLOCATED(YP)) DEALLOCATE(YP)
      IF (ALLOCATED(YPOLD)) DEALLOCATE(YPOLD)
      ALLOCATE(Q(NP1,NP1),R(NP1*(N+2)/2),YOLD(NP1),YP(NP1),YPOLD(NP1),
     &  STAT=JW)
      IF (JW /= 0) THEN
        IFLAG=8
        RETURN
      END IF
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
      YPOLD(2:NP1)=0.0
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)*EPSILON(1.0_R8)
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_R8
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
        A=Y(2:NP1)
      ENDIF
C
40    LIMIT=LIMITD
C
C ***** END OF INITIALIZATION BLOCK. *****
C
50    DO ITER=1,LIMIT   ! ***** MAIN LOOP. *****
      IF (Y(1) .LT. 0.0) THEN
        ARCLEN = S
        IFLAG = 5
        CALL CLEANUP ; 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,Q,R,F0,F1,Z0,DZ,
     &    W,T,SSPAR) 
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:'/(1X,6ES12.4))
      ENDIF
C
C CHECK IF THE STEP WAS SUCCESSFUL.
C
      IF (IFLAGC .GT. 0) THEN
        ARCLEN=S
        IFLAG=IFLAGC
        CALL CLEANUP ; 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
      END DO   ! ***** 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  YSAV=YOLD
C
C FIND SOLUTION.
C
      CALL ROOTQF(N,NFE,IFLAGC,ANSRE,ANSAE,Y,YP,YOLD,
     &    YPOLD,A,Q,R,DZ,Z0,W,T,F0,F1)
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
      DZ = Y - YSAV
      ARCLEN = S - HOLD + DNRM2(NP1,DZ,1)
C
C ***** END OF FINAL STEP *****
C
      CALL CLEANUP ; RETURN
C
      CONTAINS
        SUBROUTINE CLEANUP
        IF (ALLOCATED(Q)) DEALLOCATE(Q)
        IF (ALLOCATED(R)) DEALLOCATE(R)
        IF (ALLOCATED(YOLD)) DEALLOCATE(YOLD)
        IF (ALLOCATED(YP)) DEALLOCATE(YP)
        IF (ALLOCATED(YPOLD)) DEALLOCATE(YPOLD)
        END SUBROUTINE CLEANUP
      END SUBROUTINE FIXPQF
!
      SUBROUTINE FIXPQS(N,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE,A,
     &     NFE,ARCLEN,MODE,LENQR,SSPAR)
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
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)  which evaluates, if
C MODE = 1,
C   the (symmetric) Jacobian matrix of F(X) at X, and returns the
C   symmetric Jacobian matrix in packed skyline storage format in
C   QR, or if
C MODE = 2,
C   returns the (nonsymmetric) Jacobian matrix in sparse row format
C   in QR.  The MODE 1 format is defined by QR, LENQR, ROWPOS; the
C   MODE 2 format is defined by QR, LENQR, ROWPOS, COLPOS.
C
C For the curve tracking problem, the user must supply a subroutine
C  RHO(A,LAMBDA,X,V)  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)  which, if
C MODE = 1,
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).  This data structure is described by QR, LENQR,
C   ROWPOS, PP.  *** Note the minus sign in the definition of PP. ***  If
C MODE = 2,
C   the (nonsymmetric) N X (N+1) Jacobian matrix [D RHO/DX, D RHO/DLAMBDA]
C   evaluated at (A,X,LAMBDA) is returned in a data structure described
C   by QR, LENQR, ROWPOS, COLPOS.
C
C Whichever of the routines  F,  FJACS,  RHO,  RHOJS  are required
C should be supplied as external subroutines, conforming with the
C interfaces in the module  HOMOTOPY.
C
C
C FIXPQS directly or indirectly uses the subroutines  
C F (or  RHO ), FJACS (or  RHOJS ), GMFADS , GMRES , GMRILUDS ,
C ILUFDS , ILUSOLVDS , MULTDS , MULT2DS , PCGDS , ROOT , ROOTNS ,
C SOLVDS , STEPNS , TANGNS , and the BLAS functions  DDOT , DLAIC1 ,
C DLAMCH , DNRM2 .  The module  REAL_PRECISION  specifies 64-bit
C real arithmetic, which the user may want to change.
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(:)  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 MODE = 1 if the Jacobian matrix is symmetric and stored in a packed
C          skyline format;
C      = 2 if the Jacobian matrix is stored in a sparse row format.
C
C LENQR  is the number of nonzero entries in the sparse Jacobian
C    matrices, used to determine the sparse matrix data structures.
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
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  ROOTNS  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
C Allocatable and automatic work arrays:
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), PP(1:N), ROWPOS(1:N+2), COLPOS(1:LENQR) are all work
C    arrays used to define the sparse Jacobian matrices, allocated
C    here, and distributed via the module  HOMOTOPY .
C
C
C
      USE HOMOTOPY, QR => QRSPARSE
      USE REAL_PRECISION
      INTEGER, INTENT(IN)::LENQR,MODE,N,TRACE
      REAL (KIND=R8), DIMENSION(:), INTENT(IN OUT)::A,Y
      INTEGER, INTENT(IN OUT)::IFLAG
      REAL (KIND=R8), INTENT(IN OUT)::ANSAE,ANSRE,ARCAE,ARCRE,SSPAR(4)
      INTEGER, INTENT(OUT)::NFE
      REAL (KIND=R8), INTENT(OUT)::ARCLEN
C
C     FUNCTION DECLARATIONS 
C 
      INTERFACE
        FUNCTION DNRM2(N,X,STRIDE)
        USE REAL_PRECISION
        INTEGER:: N,STRIDE
        REAL (KIND=R8):: DNRM2,X(N)
        END FUNCTION DNRM2
      END INTERFACE
C
C     LOCAL VARIABLES 
C
      REAL (KIND=R8), SAVE:: ABSERR, H, HOLD, RELERR, S, WK 
      INTEGER, SAVE:: IFLAGC, ITER, JW, LIMIT, NP1
      LOGICAL, SAVE:: CRASH, START       
C
C     WORK ARRAYS 
C
      REAL (KIND=R8), ALLOCATABLE, DIMENSION(:), SAVE:: YP,YOLD,YPOLD
      REAL (KIND=R8):: DZ(N+1),T(N+1),Z0(N+1) 
C
C LIMITD  IS AN UPPER BOUND ON THE NUMBER OF STEPS.  IT MAY BE 
C CHANGED BY CHANGING THE FOLLOWING PARAMETER STATEMENT:
      INTEGER, PARAMETER:: LIMITD = 1000
C
      INTERFACE
        SUBROUTINE ROOTNS(N,NFE,IFLAGC,ANSRE,ANSAE,Y,YP,
     &    YOLD,YPOLD,A,MODE,LENQR)
        USE HOMOTOPY, QR => QRSPARSE
        USE REAL_PRECISION
        INTEGER, INTENT(IN):: LENQR,MODE,N
        INTEGER, INTENT(IN OUT):: IFLAGC,NFE
        REAL (KIND=R8), INTENT(IN):: A(:)
        REAL (KIND=R8), INTENT(IN):: ANSAE,ANSRE
        REAL (KIND=R8), DIMENSION(:), INTENT(IN OUT):: Y,YOLD,YP,YPOLD
        END SUBROUTINE ROOTNS
C
        SUBROUTINE STEPQS(N,NFE,IFLAGC,MODE,LENQR,START,CRASH,HOLD,H,
     &    WK,RELERR,ABSERR,S,Y,YP,YOLD,YPOLD,A,Z0,DZ,T,SSPAR)
        USE HOMOTOPY, QR => QRSPARSE
        USE REAL_PRECISION
        INTEGER, INTENT(IN):: LENQR,MODE,N
        INTEGER, INTENT(IN OUT):: IFLAGC,NFE
        LOGICAL, INTENT(IN OUT):: CRASH,START
        REAL (KIND=R8), INTENT(IN):: A(:),SSPAR(4)
        REAL (KIND=R8), INTENT(IN OUT):: ABSERR,H,HOLD,RELERR,S,WK,
     &    Y(:),YOLD(:),YP(:),YPOLD(:)
        REAL (KIND=R8), INTENT(OUT), DIMENSION(:):: DZ,T,Z0
        END SUBROUTINE STEPQS
      END INTERFACE
C
C ***** FIRST EXECUTABLE STATEMENT *****
C
C CHECK IFLAG
C
      IF (N .LE. 0  .OR.  ANSRE .LE. 0.0  .OR.  ANSAE .LT. 0.0
     &  .OR.  N+1 .NE. SIZE(Y) .OR.
     &  ((IFLAG .EQ. -1  .OR.  IFLAG .EQ. 0) .AND.  N .NE. SIZE(A))
     &  .OR.  MODE .LE. 0  .OR.  MODE .GE. 3)
     &                                                     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 ALLOCATE SAVED WORK ARRAYS.
      IF (ALLOCATED(YOLD)) DEALLOCATE(YOLD)
      IF (ALLOCATED(YP)) DEALLOCATE(YP)
      IF (ALLOCATED(YPOLD)) DEALLOCATE(YPOLD)
      ALLOCATE(YOLD(NP1),YP(NP1),YPOLD(NP1))
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
        YPOLD(1:N)=0.0
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)*EPSILON(1.0_R8)
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_R8
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) A(1:N) = Y(1:N)
C
 40   LIMIT=LIMITD
C ALLOCATE ARRAYS FOR SPARSE JACOBIAN MATRIX DATA STRUCTURE.
 50   SELECT CASE (MODE)
        CASE (1)
          IF (.NOT. ALLOCATED(QR)) ALLOCATE(QR(LENQR))
          IF (.NOT. ALLOCATED(ROWPOS)) ALLOCATE(ROWPOS(N+2))
          IF (.NOT. ALLOCATED(PP)) ALLOCATE(PP(N))
        CASE (2)
          IF (.NOT. ALLOCATED(QR)) ALLOCATE(QR(LENQR))
          IF (.NOT. ALLOCATED(ROWPOS)) ALLOCATE(ROWPOS(N+2))
          IF (.NOT. ALLOCATED(COLPOS)) ALLOCATE(COLPOS(LENQR))
          IF ((.NOT. ALLOCATED(PP)) .AND. (IFLAGC .GE. -1))
     &      ALLOCATE(PP(N))
      END SELECT
C
C ***** END OF INITIALIZATION BLOCK. *****
C
      MAIN_LOOP: DO ITER=1,LIMIT ! ***** MAIN LOOP. *****
        IF (Y(NP1) .LT. 0.0) THEN
          ARCLEN = S
          IFLAG = 5
          CALL CLEANUPALL
          RETURN
        END IF
C
C TAKE A STEP ALONG THE CURVE.
C
        CALL STEPQS(N,NFE,IFLAGC,MODE,LENQR,START,CRASH,HOLD,H,
     &    WK,RELERR,ABSERR,S,Y,YP,YOLD,YPOLD,A,Z0,DZ,T,SSPAR)
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:'/(1X,6ES12.4))
        ENDIF
C
C CHECK IF THE STEP WAS SUCCESSFUL.
C
        IF (IFLAGC .GT. 0) THEN
          ARCLEN=S
          IFLAG=IFLAGC
          CALL CLEANUPALL
          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
          CALL CLEANUP
          RETURN
        END IF
C
C IF  LAMBDA >= 1.0,  USE  ROOTNS  TO FIND SOLUTION.
C
        IF (Y(NP1) .GE. 1.0) GO TO 500
C
      END DO MAIN_LOOP   ! ***** END OF MAIN LOOP *****
C
C DID NOT CONVERGE IN  LIMIT  ITERATIONS, SET  IFLAG  AND RETURN.
C
      ARCLEN = S
      IFLAG = 3
      CALL CLEANUP
      RETURN
C
C ***** FINAL STEP -- FIND SOLUTION AT LAMBDA=1 *****
C
C SAVE  YOLD  FOR ARC LENGTH CALCULATION LATER.
C
 500  T = YOLD
C
C FIND SOLUTION.
C
      CALL ROOTNS(N,NFE,IFLAGC,ANSRE,ANSAE,Y,YP,
     &    YOLD,YPOLD,A,MODE,LENQR)
C
C CHECK IF SOLUTION WAS FOUND AND SET  IFLAG  ACCORDINGLY.
C
      IFLAG=1
C
C     SET ERROR FLAG IF ROOTNS 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
      DZ = Y - T
      ARCLEN = S - HOLD + DNRM2(NP1,DZ,1)
C
C ***** END OF FINAL STEP *****
C
      CALL CLEANUPALL
      RETURN
C
      CONTAINS
        SUBROUTINE CLEANUPALL
        IF (ALLOCATED(YOLD)) DEALLOCATE(YOLD)
        IF (ALLOCATED(YP)) DEALLOCATE(YP)
        IF (ALLOCATED(YPOLD)) DEALLOCATE(YPOLD)
        CALL CLEANUP
        RETURN
        END SUBROUTINE CLEANUPALL
        SUBROUTINE CLEANUP
        IF (ALLOCATED(QR)) DEALLOCATE(QR)
        IF (ALLOCATED(ROWPOS)) DEALLOCATE(ROWPOS)
        IF (ALLOCATED(COLPOS)) DEALLOCATE(COLPOS)
        IF (ALLOCATED(PP)) DEALLOCATE(PP)
        IF (ALLOCATED(PAR)) DEALLOCATE(PAR)
        IF (ALLOCATED(IPAR)) DEALLOCATE(IPAR)
        RETURN
        END SUBROUTINE CLEANUP
      END SUBROUTINE FIXPQS
!
      SUBROUTINE POLSYS1H(N,NUMT,COEF,KDEG,IFLG1,IFLG2,EPSBIG,EPSSML,
     &     SSPAR,NUMRR,LAMBDA,ROOTS,ARCLEN,NFE)
C
C POLSYS1H 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, POLSYS1H
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 POLSYS1H 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 Mth path,
C
C ROOTS(2,J,M) = imaginary part of X(J) for the Mth path,
C
C for J=1, ..., N, and
C
C ROOTS(1,N+1,M) = real part of Z(N+1) for the Mth path,
C
C ROOTS(2,N+1,M) = imaginary part of Z(N+1) for the Mth 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 POLSYS1H.
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 be 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  POLSYS1H  and whether the projective transformation
C of the system is to be automatically evoked by POLSYS1H.  See
c "ON INPUT" below.
C
C IFLG2, EPSBIG, EPSSML, and  SSPAR  tell the path tracker
C FIXPNF  which paths to track and set parameters for the path
C tracker.
C
C NUMRR  tells  POLSYS1H  how many multiples of 1000 steps to try
C before abandoning a path.
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
C The following subroutines are used directly or indirectly by
C POLSYS1H: 
C         Special for POLSYS1H:
C           INITP , STRPTP , OTPUTP , RHO , RHOJAC ,
C           HFUNP , HFUN1P , GFUNP , FFUNP ,
C           MULP , POWP , DIVP , SCLGNP .
C         From the general HOMPACK routines:
C           FIXPNF , ROOT , ROOTNF , STEPNF , TANGNF .
C         From LAPACK routines:
C           DGEQPF , DGEQRF , DORMQR .
C         From BLAS routines:
C           DCOPY ,  DDOT ,  DGEMM ,  DGEMV ,  DGER ,  
C           DNRM2 ,  DSCAL ,  DSWAP ,  DTRMM ,  DTRMV , DTRSV ,
C           IDAMAX ,  LSAME , XERBLA . 
C
C ON INPUT:
C
C N  is the number of equations and variables.
C
C NUMT(1:N)  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:N,1:)  is a real array.  COEF(J,K)  is 
C   the Kth coefficient of the Jth equation for J=1 to N,
C   K=1 to NUMT(J).  The second dimension must be greater than or equal
C   to the maximum number of terms in each equation.  In other words,
C   SIZE(COEF,DIM=2) .GE. MAXT = MAX {NUMT(J) | J=1, ..., N} .
C
C KDEG(1:N,1:N+1,1:)  is an integer array.  
C   KDEG(J,L,K)  is the degree of the Lth variable in the Kth
C   term of the Jth equation for  J=1 to N, L=1 to N, K=1 to NUMT(J).
C   SIZE(KDEG,DIM=3) .GE. MAXT = MAX {NUMT(J) | J=1, ..., N} .
C
C IFLG1 =
C   00  if the problem is to be solved without
C       calling POLSYS1H' 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:TOTDG)  is an integer array.  If IFLG2(M) = -2, then the 
C   Mth path is tracked.  Otherwise the Mth 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 IFLG2(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  FIXPNF ) are set to  EPSBIG.
C
C EPSSML  is the accuracy desired for the final solution.  ANSRE and
C   ANSAE (in  FIXPNF ) 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  FIXPNF .  Otherwise the input value of  SSPAR(J)  is used.
C    See the comments in  FIXPNF  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
C ON OUTPUT:
C
C N, NUMT, COEF, KDEG, EPSBIG, EPSSML, and NUMRR are unchanged.
C
C IFLG1=
C   -1  if  NUMT  is incorrectly dimensioned or invalid.
C   -2  if  COEF  is incorrectly dimensioned.
C   -3  if  KDEG  is incorrectly dimensioned or invalid.
C   -4  if any of  IFLG2, LAMBDA, ROOTS, ARCLEN, or  NFE  are
C       incorrectly dimensioned.
C   -5  if the global work arrays  IPAR  and  PAR  could not be
C       allocated.
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 Mth 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 tolerances  EPSBIG  or  EPSSML
C       may be too stringent.
C
C   7   Illegal input parameters, a fatal error.
C
C LAMBDA(M)  is the final LAMBDA value for the Mth 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 Mth 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 Mth path for M = 1, ..., TOTDG.
C
C NFE(M)  is the number of Jacobian matrix evaluations required to 
C   track the Mth path for M =1, ..., TOTDG.
C
C ----------------------------------------------------------------------
      USE HOMOTOPY
      USE REAL_PRECISION
      INTERFACE
        SUBROUTINE INITP(IFLG1,N,NUMT,KDEG,COEF,
     &                              IDEG,FACV,CL,PDG,QDG,R)
        USE HOMOTOPY
        USE REAL_PRECISION
        INTEGER, INTENT(IN):: IFLG1,N,NUMT(:)
        INTEGER, INTENT(IN OUT):: KDEG(:,:,:)
        REAL (KIND=R8), INTENT(IN OUT):: COEF(:,:)
        INTEGER, INTENT(OUT):: IDEG(N)
        REAL (KIND=R8), INTENT(OUT):: 
     &    FACV(N),CL(2,N+1),PDG(2,N),QDG(2*N),R(2,N)
        END SUBROUTINE INITP
C
        SUBROUTINE STRPTP(N,ICOUNT,IDEG,R,X)
        USE REAL_PRECISION
        INTEGER:: N,ICOUNT(N),IDEG(N)
        REAL (KIND=R8):: R(2,N),X(2*N)
        END SUBROUTINE STRPTP
C
!       SUBROUTINE FIXPNF(N,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE,A,
!    &    SSPAR,NFE,ARCLEN,POLY_SWITCH)
!       USE REAL_PRECISION
!       INTEGER, INTENT(IN)::N,TRACE
!       REAL (KIND=R8), DIMENSION(:), INTENT(IN OUT)::A,Y
!       INTEGER, INTENT(IN OUT)::IFLAG
!       REAL (KIND=R8), INTENT(IN OUT)::ANSAE,ANSRE,ARCAE,ARCRE,
!    &    SSPAR(8)
!       INTEGER, INTENT(OUT)::NFE
!       REAL (KIND=R8), INTENT(OUT)::ARCLEN
!       LOGICAL, INTENT(IN), OPTIONAL::POLY_SWITCH
!       END SUBROUTINE FIXPNF
C
        SUBROUTINE OTPUTP(N,NUMPAT,CL,FACV,CLX,X,XNP1)
        USE REAL_PRECISION
        INTEGER, INTENT(IN):: N,NUMPAT
        REAL (KIND=R8), INTENT(IN):: CL(2,N+1),FACV(N)
        REAL (KIND=R8), INTENT(IN OUT):: CLX(2,N),X(2,N),XNP1(2)
        END SUBROUTINE OTPUTP
      END INTERFACE
C
C TYPE DECLARATIONS FOR INPUT AND OUTPUT
C
      INTEGER, INTENT(IN):: N,NUMT(:),NUMRR
      REAL (KIND=R8), INTENT(IN OUT):: COEF(:,:),SSPAR(8)
      INTEGER, INTENT(IN OUT):: KDEG(:,:,:),IFLG1,IFLG2(:)
      REAL (KIND=R8), INTENT(IN):: EPSBIG,EPSSML
      REAL (KIND=R8), INTENT(OUT):: LAMBDA(:),ROOTS(:,:,:),ARCLEN(:)
      INTEGER, INTENT(OUT):: NFE(:)
C
C TYPE DECLARATIONS FOR LOCAL VARIABLES
C
      INTEGER:: I,ICOUNT(N),IDEG(N),IDUMMY,IFLAG,IJ,
     &  IPROFF(15),J,LIPAR(15),LPAR(25),MAXT,N2,N2P1,
     &  NNFE,NP1,NUMPAT,PROFF(25),TOTDG,TRACE
      REAL (KIND=R8):: AARCLN,ANSAE,ANSRE,ARCAE,ARCRE,CL(2,N+1),
     &  FACV(N),PDG(2,N),QDG(2*N),R(2,N),XNP1(2),Y(2*N+1)
C
C ----------------------------------------------------------------------
      N2=2*N
      NP1=N+1
      N2P1=N2+1
C
C CHECK THAT DIMENSIONS ARE VALID.
C
      IF ((SIZE(NUMT) /= N) .OR. ANY(NUMT .LE. 0)) THEN
        IFLG1=-1
        RETURN
      END IF
      MAXT = MAXVAL(NUMT)
      IF ((SIZE(COEF,DIM=1) /= N) .OR. (SIZE(COEF,DIM=2) < MAXT)) THEN
        IFLG1=-2
        RETURN
      END IF
      KDEG = ABS(KDEG)
      IF ((SIZE(KDEG,DIM=1) /= N) .OR. (SIZE(KDEG,DIM=2) /= NP1) .OR.
     &  (SIZE(KDEG,DIM=3) < MAXT) ) THEN
        IFLG1=-3
        RETURN
      END IF
      DO J=1,N
        IDEG(J)=MAXVAL(SUM(KDEG(J,1:N,1:NUMT(J)),DIM=1))
      END DO
      TOTDG = PRODUCT(IDEG)
      IF ((SIZE(IFLG2) < TOTDG) .OR. (SIZE(LAMBDA) < TOTDG) .OR.
     &  (SIZE(ROOTS,DIM=3) < TOTDG) .OR. (SIZE(ARCLEN) < TOTDG) .OR.
     &  (SIZE(NFE) < TOTDG) .OR. 
     &  (IFLG1 <= 1 .AND. SIZE(ROOTS,DIM=2) /= N) .OR.
     &  (IFLG1 >= 10 .AND. SIZE(ROOTS,DIM=2) /= NP1)) THEN
        IFLG1=-4
        RETURN
      END IF
      IF (IFLG1 /= 0 .AND. IFLG1 /= 1 .AND.
     &  IFLG1 /= 10 .AND. IFLG1 /= 11) THEN
        IFLG1=-6
        RETURN
      END IF
C
C ALLOCATE THE GLOBAL WORK ARRAYS  IPAR  AND  PAR, USED TO COMMUNICATE
C DATA BETWEEN SUBROUTINES VIA THE MODULE HOMOTOPY.
C
      ALLOCATE(IPAR(42 + 2*N + N*(N+1)*MAXT),
     &  PAR(2 + 28*N + 6*N**2 + 7*N*MAXT + 4*N**2*MAXT),STAT=IJ)
      IF (IJ .NE. 0) THEN
        IFLG1=-5
        RETURN
      END IF
C      
C INITIALIZATION
C
      CALL INITP(IFLG1,N,NUMT,KDEG,COEF,
     &                              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             MAXT               1
C          3            PROFF               25
C          4           IPROFF               15
C          5             IDEG               N
C          6             NUMT               N
C          7             KDEG               N*(N+1)*MAXT
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*MAXT
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)*MAXT
C         16              TRM               2*N*MAXT
C         17             DTRM               2*N*(N+1)*MAXT
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)*MAXT
      LPAR( 1)=2*N
      LPAR( 2)=2*NP1
      LPAR( 3)=N*MAXT
      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*MAXT
      LPAR(16)=2*N*MAXT
      LPAR(17)=2*N*NP1*MAXT
      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 I=2,19
          PROFF(I)=PROFF(I-1)+LPAR(I-1)
      END DO
      IPROFF(1)=1
      DO I=2,7
          IPROFF(I)=IPROFF(I-1)+LIPAR(I-1)
      END DO
C
C DEFINE VARIABLES
      IPAR(1)=N
      IPAR(2)=MAXT
      IPAR(IPROFF(3):IPROFF(3)+18) = PROFF(1:19)
      IPAR(IPROFF(4):IPROFF(4)+ 6) = IPROFF(1:7)
      IPAR(IPROFF(5):IPROFF(5)+N-1) = IDEG(1:N)
      IPAR(IPROFF(6):IPROFF(6)+N-1) = NUMT(1:N)
      IPAR(IPROFF(7):IPROFF(7)+LIPAR(7)-1) =
     &  PACK(KDEG(:,:,1:MAXT),.TRUE.)
      PAR(PROFF(1):PROFF(1)+LPAR(1)-1) = PACK(PDG,.TRUE.)
      PAR(PROFF(2):PROFF(2)+LPAR(2)-1) = PACK(CL,.TRUE.)
      PAR(PROFF(3):PROFF(3)+LPAR(3)-1) = PACK(COEF(:,1:MAXT),.TRUE.)
C
C ICOUNT IS A COUNTER USED BY "STRPTP"
      ICOUNT(1)=0
      ICOUNT(2:N)=1
C
C PATHS LOOP -- ITERATE THROUGH PATHS
C
      PATHS: DO NUMPAT = 1,TOTDG
C         GET A START POINT, Y, FOR THE PATH.
          Y(1) = 0.0
          CALL STRPTP(N,ICOUNT,IDEG,R,Y(2:N2P1))
C         CHECK WHETHER PATH IS TO BE FOLLOWED.
          IFLAG = IFLG2(NUMPAT)
          IF (IFLAG .NE. -2) CYCLE PATHS
          ARCRE = EPSBIG
          ARCAE = ARCRE
          ANSRE = EPSSML
          ANSAE = ANSRE
          TRACE = 0
C         TRACK A HOMOTOPY PATH.
          DO IDUMMY=1,MAX(NUMRR,1)
            CALL FIXPNF(N2,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE,
     &        QDG,SSPAR,NNFE,AARCLN, POLY_SWITCH=.TRUE.)
            IF (IFLAG .NE. 2 .AND. IFLAG .NE. 3) EXIT
          END DO
C         UNSCALE AND UNTRANSFORM COMPUTED SOLUTION.
          CALL OTPUTP(N,NUMPAT,CL,FACV,
     &      PAR(PROFF(18):PROFF(18)+LPAR(18)-1),Y(2:N2P1),XNP1)
          LAMBDA(NUMPAT) = Y(1)
          ROOTS(1,1:N,NUMPAT) = Y(2:N2P1:2)
          ROOTS(2,1:N,NUMPAT) = Y(3:N2P1:2)
          ROOTS(1:2,NP1,NUMPAT) = XNP1
C
          ARCLEN(NUMPAT)= AARCLN
          NFE(NUMPAT)   = NNFE
          IFLG2(NUMPAT) = IFLAG
      END DO PATHS
C CLEAN UP WORK SPACE.
      IF (ALLOCATED(IPAR)) DEALLOCATE(IPAR)
      IF (ALLOCATED(PAR))  DEALLOCATE(PAR)
      RETURN
      END SUBROUTINE POLSYS1H
      END MODULE HOMPACK90

		

		
      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  HUGE .
C
C  0   IF DIVISION DOES NOT CAUSE OVERFLOW.
C
C DECLARATION OF INPUT
      USE REAL_PRECISION
      REAL (KIND=R8), DIMENSION(2), INTENT(IN):: XXXX,YYYY
C
C DECLARATION OF OUTPUT
      INTEGER, INTENT(OUT):: IERR
      REAL (KIND=R8), DIMENSION(2), INTENT(OUT):: ZZZZ
C
C DECLARATION OF VARIABLES
      REAL (KIND=R8):: DENOM,XNUM
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)/HUGE(1.0_R8) .LT. ABS(DENOM) ) ) THEN
            ZZZZ(1) = XNUM/DENOM
          ELSE
            ZZZZ(1) = HUGE(1.0_R8)
            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)/HUGE(1.0_R8) .LT. ABS(DENOM) ) ) THEN
            ZZZZ(2) = XNUM/DENOM
          ELSE
            ZZZZ(2) = HUGE(1.0_R8)
            IERR =1
          END IF
      RETURN
      END SUBROUTINE DIVP
      SUBROUTINE FFUNP(N,NUMT,MAXT,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 MAXT  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
      USE REAL_PRECISION
C
      INTERFACE
        SUBROUTINE DIVP(XXXX,YYYY,ZZZZ,IERR)
        USE REAL_PRECISION
        REAL (KIND=R8), DIMENSION(2), INTENT(IN):: XXXX,YYYY
        INTEGER, INTENT(OUT):: IERR
        REAL (KIND=R8), DIMENSION(2), INTENT(OUT):: ZZZZ
        END SUBROUTINE DIVP
        SUBROUTINE MULP(XXXX,YYYY,ZZZZ)
        USE REAL_PRECISION
        REAL (KIND=R8), DIMENSION(2), INTENT(IN):: XXXX,YYYY
        REAL (KIND=R8), DIMENSION(2), INTENT(OUT):: ZZZZ
        END SUBROUTINE MULP
        SUBROUTINE POWP(NNNN,XXXX,YYYY)
        USE REAL_PRECISION
        INTEGER, INTENT(IN):: NNNN
        REAL (KIND=R8), DIMENSION(2), INTENT(IN):: XXXX
        REAL (KIND=R8), DIMENSION(2), INTENT(IN OUT):: YYYY
        END SUBROUTINE POWP
      END INTERFACE
C
C DECLARATION OF INPUT AND OUTPUT:
      INTEGER, INTENT(IN):: N,NUMT(N),MAXT,KDEG(N,N+1,MAXT)
      REAL (KIND=R8), INTENT(IN):: COEF(N,MAXT),CL(2,N+1),X(2,N)
      REAL (KIND=R8), INTENT(IN OUT):: 
     &  XX(2,N,N+1,MAXT),TRM(2,N,MAXT),DTRM(2,N,N+1,MAXT)
      REAL (KIND=R8), INTENT(OUT):: 
     &  CLX(2,N),DXNP1(2,N),F(2,N),DF(2,N,N+1)
C
C DECLARATION OF LOCAL VARIABLES:
      INTEGER:: IERR,J,K,L,M,NNNN,NP1
      REAL (KIND=R8), DIMENSION(2):: TEMP1,TEMP2,XNP1
C
      NP1=N+1
C
C GENERATE XNP1, THE PROJECTIVE COORDINATE, AND ITS DERIVATIVES.
      DO J=1,N
        CALL MULP(CL(1,J),X(1,J),CLX(1,J))
      END DO
C
      XNP1(1:2)=CL(1:2,NP1) + SUM(CLX(1:2,1:N),DIM=2)
      DXNP1(1:2,1:N)=CL(1:2,1:N)
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 J=1,N
        DO K=1,NUMT(J)
          CALL POWP(KDEG(J,NP1,K),XNP1, XX(1,J,NP1,K))
          DO L=1,N
            CALL POWP(KDEG(J, L,K),X(1,L),XX(1,J,  L,K))
          END DO
        END DO
      END DO
      TRM = 0.0
      DO J=1,N
        DO K=1,NUMT(J)
          TRM(1,J,K)=COEF(J,K)
          DO L=1,NP1
            CALL MULP(XX(1,J,L,K), TRM(1,J,K),TEMP1)
            TRM(1:2,J,K ) = TEMP1(1:2)
          END DO
        END DO
      END DO
      F(1:2,1:N) = SUM(TRM(1:2,1:N,:),DIM=3)
C
C END OF "COMPUTE F"
C
C BEGIN "COMPUTE DF"
C
      J_LOOP: DO J=1,N
        K_LOOP: DO K=1,NUMT(J)
        M_LOOP: DO 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: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:2,J,M,K)=KDEG(J,M,K)*DTRM(1: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 L=1,NP1
                IF (L .EQ. M) CYCLE
                CALL MULP(XX(1,J,L,K),DTRM(1,J,M,K),TEMP1)
                DTRM(1:2,J,M,K)=TEMP1(1:2)
              END DO
              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:2,J,M,K)=KDEG(J,M,K)*DTRM(1:2,J,M,K)
            END IF
          END IF
        END DO M_LOOP
        END DO K_LOOP
      END DO J_LOOP
      DO J=1,N
        DF(1:2,J,1:NP1) = SUM(DTRM(1:2,J,1:NP1,1:NUMT(J)), DIM=3)
      END DO
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 J=1,N
        DO K=1,N
          CALL MULP(DF(1,J,NP1),DXNP1(1,K),TEMP1)
          DF(1:2,J,K)=DF(1:2,J,K)+TEMP1(1:2)
        END DO
      END DO
      RETURN
      END SUBROUTINE FFUNP
      SUBROUTINE FODE(S,Y,YP,YPOLD,A,QR,ALPHA,TZ,PIVOT,NFE,N,IFLAG)
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 CALLS  DGEQPF , DNRM2 .
C
      USE HOMOTOPY
      USE REAL_PRECISION
      REAL (KIND=R8):: DNRM2,S,YPNORM
      INTEGER:: I,IFLAG,IK,K,KP1,LW,N,NFE,NP1
C
C *****  ARRAY DECLARATIONS.  *****
C
      REAL (KIND=R8):: A(:),Y(:),YP(N+1),YPOLD(N+1)
C
C ARRAYS FOR COMPUTING THE JACOBIAN MATRIX AND ITS KERNEL.
      REAL (KIND=R8):: ALPHA(3*N+3),QR(N,N+1),TZ(N+1)
      INTEGER, DIMENSION(N+1):: PIVOT
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 K=1,NP1
          CALL RHOJAC(A,Y(1),Y(2:NP1),QR(:,K),K)
        END DO
      ELSE
        CALL F(Y(2:NP1),TZ(1:N))
        QR(:,1)=A
        IF (IFLAG .EQ. 0) THEN
C
C      QR = ( A - F(X), I - LAMBDA*DF(X) )  .
C
          QR(:,1)=QR(:,1)-TZ(1:N)
          DO K=1,N
            CALL FJAC(Y(2:NP1),TZ(1:N),K)
            KP1=K+1
            QR(:,KP1)=-Y(1)*TZ(1:N)
            QR(K,KP1)=1.0+QR(K,KP1)
          END DO
        ELSE
C
C   QR = ( F(X) - X + A, LAMBDA*DF(X) + (1 - LAMBDA)*I ) .
C
          QR(:,1)=QR(:,1)+TZ(1:N)-Y(2:NP1)
          DO K=1,N
            CALL FJAC(Y(2:NP1),TZ(1:N),K)
            KP1=K+1
            QR(:,KP1)=Y(1)*TZ(1:N)
            QR(K,KP1)=1.0-Y(1)+QR(K,KP1)
          END DO
        ENDIF
      ENDIF
C
C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
C REDUCE THE JACOBIAN MATRIX TO UPPER TRIANGULAR FORM.
C
        PIVOT = 0
C
      CALL DGEQPF(N,NP1,QR,N,PIVOT,YP,ALPHA,K)
C
      IF (ABS(QR(N,N)) .LE. ABS(QR(1,1))*EPSILON(1.0_R8)) THEN 
        IFLAG=4
        RETURN
      ENDIF 
C COMPUTE KERNEL OF JACOBIAN, WHICH SPECIFIES YP=DY/DS.
      TZ(NP1)=1.0
      DO LW=1,N
        I=NP1-LW
        IK=I+1
        TZ(I)=-DOT_PRODUCT(QR(I,IK:NP1),TZ(IK:NP1))/QR(I,I)
      END DO
      YPNORM=DNRM2(NP1,TZ,1)
      YP(PIVOT)=TZ/YPNORM
      IF (DOT_PRODUCT(YP,YPOLD) .LT. 0.0) YP=-YP
C
C SAVE CURRENT DERIVATIVE (= TANGENT VECTOR) IN  YPOLD .
      YPOLD=YP
      RETURN
      END SUBROUTINE FODE
      SUBROUTINE FODEDS(S,Y,YP,N,IFLAG,YPOLD,A,NDIMA,LENQR,MODE,NFE)
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
      USE HOMOTOPY, QR => QRSPARSE
      USE REAL_PRECISION
      REAL (KIND=R8):: LAMBDA,S,YPNORM
      INTEGER:: IFLAG,J,JPOS,LENQR,MODE,N,NDIMA,NFE,NP1
      REAL (KIND=R8):: A(NDIMA),Y(N+1),YP(N+1),YPOLD(N+1)
      INTERFACE
        SUBROUTINE PCGDS(N,LENQR,IFLAG,YP,RHO)
          USE REAL_PRECISION
          INTEGER, INTENT(IN):: LENQR,N
          INTEGER, INTENT(IN OUT):: IFLAG
          REAL (KIND=R8), INTENT(IN OUT):: YP(N+1)
          REAL (KIND=R8), OPTIONAL, INTENT(IN):: RHO(N)
        END SUBROUTINE PCGDS
        SUBROUTINE GMRILUDS(N,LENQR,IFLAG,YP,RHO)
          USE REAL_PRECISION
          INTEGER, INTENT(IN):: LENQR,N
          INTEGER, INTENT(IN OUT):: IFLAG
          REAL (KIND=R8), INTENT(IN OUT):: YP(N+1)
          REAL (KIND=R8), OPTIONAL, INTENT(IN):: RHO(N)
        END SUBROUTINE GMRILUDS
        FUNCTION DNRM2(N,X,STRIDE)
          USE REAL_PRECISION
          INTEGER:: N,STRIDE
          REAL (KIND=R8):: DNRM2,X(N)
        END FUNCTION DNRM2
      END INTERFACE
C
C *****  END OF SPECIFICATION INFORMATION.  *****
C
      NP1=N+1
      NFE=NFE+1
C NFE CONTAINS THE NUMBER OF JACOBIAN EVALUATIONS.
      LAMBDA=Y(NP1)
      ROWPOS(NP1)=LENQR+1
C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
C MODE = 1 STORAGE FORMAT.
C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
C
      IF (MODE .EQ. 1) THEN
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
C  PP = - (D RHO(A,X,LAMBDA)/D LAMBDA) .
        CALL RHOJS(A,LAMBDA,Y(1:N))
C
      ELSE
        CALL F(Y(1:N),PP)
        IF (IFLAG .EQ. 0) THEN
C
C      [QR | -PP] = [ I - LAMBDA*DF(X) | A - F(X) ]  .
C
          PP = PP - A(1:N)
          CALL FJACS(Y(1:N))
          QR = (-LAMBDA)*QR
          QR(ROWPOS(1:N)) = QR(ROWPOS(1:N)) + 1.0
        ELSE
C
C   [QR | -PP] = [ LAMBDA*DF(X) + (1 - LAMBDA)*I | F(X) - X + A ] .
C
          PP = Y(1:N) - A(1:N) - PP
          CALL FJACS(Y(1:N))
          QR = LAMBDA*QR
          QR(ROWPOS(1:N)) = QR(ROWPOS(1:N)) + 1.0 - LAMBDA
        ENDIF
      ENDIF
      ELSE
C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
C MODE = 2 STORAGE FORMAT.
C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
C
      IF (IFLAG .EQ. -2) THEN
C
C  [QR] = [ D RHO(A,X,LAMBDA)/DX , D RHO(A,X,LAMBDA)/D LAMBDA ]  .
C
        CALL RHOJS(A,LAMBDA,Y(1:N))
C
      ELSE
        CALL F(Y(1:N),PP)
        IF (IFLAG .EQ. 0) THEN
C
C      [QR | -PP] = [ I - LAMBDA*DF(X) | A - F(X) ]  .
C
          PP = PP - A(1:N)
          CALL FJACS(Y(1:N))
          QR = (-LAMBDA)*QR
C FIND INDEX JPOS OF DIAGONAL ELEMENT IN JTH ROW OF QR.
          DO J=1,N
            JPOS=ROWPOS(J)
            DO
              IF (COLPOS(JPOS) .EQ. J) EXIT
              JPOS=JPOS+1
              IF (JPOS < ROWPOS(J+1)) CYCLE
              IFLAG=4
              RETURN
            END DO
            QR(JPOS) = QR(JPOS) + 1.0
          END DO
        ELSE
C
C   [QR | -PP] = [ LAMBDA*DF(X) + (1 - LAMBDA)*I | F(X) - X + A ] .
C
          PP = Y(1:N) - A(1:N) - PP
          CALL FJACS(Y(1:N))
          QR = LAMBDA*QR
C FIND INDEX JPOS OF DIAGONAL ELEMENT IN JTH ROW OF QR.
          DO J=1,N
            JPOS=ROWPOS(J)
            DO
              IF (COLPOS(JPOS) .EQ. J) EXIT
              JPOS=JPOS+1
              IF (JPOS < ROWPOS(J+1)) CYCLE
              IFLAG=4
              RETURN
            END DO
            QR(JPOS) = QR(JPOS) + 1.0 - LAMBDA
          END DO
        ENDIF
      ENDIF
      ENDIF
C
C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
      YP=YPOLD
C COMPUTE KERNEL OF JACOBIAN, WHICH SPECIFIES YP=DY/DS, USING A
C PRECONDITIONED CONJUGATE GRADIENT ALGORITHM.
      SELECT CASE (MODE)
        CASE (1)
        CALL PCGDS(N,LENQR,IFLAG,YP)
        CASE (2)
        CALL GMRILUDS(N,LENQR,IFLAG,YP)
      END SELECT
      IF (IFLAG .GT. 0) RETURN
C
C NORMALIZE TANGENT VECTOR YP.
      YPNORM=DNRM2(NP1,YP,1)
      YP = (1.0/YPNORM)*YP
C
C CHOOSE UNIT TANGENT VECTOR DIRECTION TO MAINTAIN CONTINUITY.
      IF (DOT_PRODUCT(YP,YPOLD) .LT. 0.0) YP = -YP
C
C SAVE CURRENT DERIVATIVE (= TANGENT VECTOR) IN  YPOLD .
      YPOLD = YP
C
      RETURN
      END SUBROUTINE FODEDS
      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 SUBROUTINES:  MULP, POWP.
C
      USE REAL_PRECISION
C
      INTERFACE
        SUBROUTINE DIVP(XXXX,YYYY,ZZZZ,IERR)
        USE REAL_PRECISION
        REAL (KIND=R8), DIMENSION(2), INTENT(IN):: XXXX,YYYY
        INTEGER, INTENT(OUT):: IERR
        REAL (KIND=R8), DIMENSION(2), INTENT(OUT):: ZZZZ
        END SUBROUTINE DIVP
        SUBROUTINE MULP(XXXX,YYYY,ZZZZ)
        USE REAL_PRECISION
        REAL (KIND=R8), DIMENSION(2), INTENT(IN):: XXXX,YYYY
        REAL (KIND=R8), DIMENSION(2), INTENT(OUT):: ZZZZ
        END SUBROUTINE MULP
        SUBROUTINE POWP(NNNN,XXXX,YYYY)
        USE REAL_PRECISION
        INTEGER, INTENT(IN):: NNNN
        REAL (KIND=R8), DIMENSION(2), INTENT(IN):: XXXX
        REAL (KIND=R8), DIMENSION(2), INTENT(IN OUT):: YYYY
        END SUBROUTINE POWP
      END INTERFACE
C
C DECLARATION OF INPUT AND OUTPUT:
      INTEGER, INTENT(IN):: N,IDEG(N)
      REAL (KIND=R8), INTENT(IN):: PDG(2,N),QDG(2,N),X(2,N)
      REAL (KIND=R8), INTENT(IN OUT):: XDGM1(2,N),XDG(2,N),PXDGM1(2,N),
     &  PXDG(2,N)
      REAL (KIND=R8), INTENT(OUT):: G(2,N),DG(2,N)
C
C DECLARATION LOCAL OF VARIABLES
      INTEGER:: I,J
C
C COMPUTE THE (IDEG-1)-TH AND IDEG-TH POWER OF X
      DO 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))
      END DO
C
C COMPUTE THE PRODUCT OF PDG AND XDGM1
      DO J=1,N
          CALL MULP( PDG(1,J), XDGM1(1,J), PXDGM1(1,J) )
      END DO
C
C COMPUTE THE PRODUCT OF PDG AND XDG
      DO J=1,N
          CALL MULP( PDG(1,J), XDG(1,J), PXDG(1,J) )
      END DO
      G = PXDG - QDG
      DO J=1,N
        DG(1:2,J)= IDEG(J)*PXDGM1(1:2,J)
      END DO
      RETURN
      END SUBROUTINE GFUNP
      SUBROUTINE GMFADS(NN,A,NWK,MAXA)
C
C     This subroutine computes the LDU decomposition of a symmetric positive
C     definite matrix B where only the upper triangular skyline structure
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
      USE REAL_PRECISION
      INTEGER, INTENT(IN):: NN,NWK,MAXA(NN+1)
      REAL (KIND=R8), INTENT(IN OUT):: A(NWK)
      INTEGER:: I,I0,I1,I2,I3,I4,J,J1,K,K1,K2,KH,KL,KN,KU,KZ,L,L1,
     &   L2,L3,M,M1,N1,NNN
      REAL (KIND=R8):: BET,DEL,DJ,G,GAM,GAM1,PHI,
     &   THE,THE1,XT1,XT2,ZET,ZET1
      G=0.0
      GAM=0.0
      DO I=1,NN
         K=MAXA(I)
         G=G+A(K)*A(K)
         GAM1=ABS(A(K))
         IF(GAM1.GT.GAM)GAM=GAM1
      END DO
      ZET=0.0
      DO I=1,NN
         K=MAXA(I)
         K1=MAXA(I+1)-1
         K2=K1-K
         IF (K2.EQ.0) CYCLE
         L=K+1
         DO J=L,K1
            G=G+2.0*A(J)*A(J)
            ZET1=ABS(A(J))
            IF(ZET1.GT.ZET)ZET=ZET1
         END DO
      END DO
      ZET=ZET/NN
      DEL=EPSILON(1.0_R8)
      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 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 .GE. 0) THEN
           K1=KN+1
           K2=I
           DO J=K1,KU
              K2=K2-1
              KZ=MAXA(K2)
              PHI=PHI-A(J)*A(J)*A(KZ)
           END DO
         END IF
         PHI=ABS(PHI)
         L=I+1
         THE=0.0
         NNN=NN+1
         IF (L .NE. NNN) THEN
           DO J=L,NN
              L1=MAXA(J)
              L2=MAXA(J+1)
              L3=L2-L1-1
              M=J-I
              IF (L3 .LT. M) CYCLE
              M1=L1+M
              IF (N1 .NE. 0) THEN
                DO J1=1,N1
                  I0=MAXA(J1)
                  I1=MAXA(L)
                  I2=I-J1
                  I3=I1-KN-1
                  I4=J-J1
                  IF (I3 .LT. I2) CYCLE
                  IF (L3 .LT. I4) CYCLE
                  XT1=A(KN+I2)
                  XT2=A(L1+I4)
                  A(M1)=A(M1)-XT1*XT2*A(I0)
                END DO
              END IF
            THE1=ABS(A(M1))
            IF (THE .LT. THE1) THE=THE1
            END DO
         END IF
         THE=THE*THE/BET
         DJ=DEL
         IF (PHI .GT. DJ) DJ=PHI
         IF (THE .GT. DJ) DJ=THE
         A(KN)=DJ
         IF (L .EQ. NNN) CYCLE
         DO J=L,NN
            L1=MAXA(J)
            L2=MAXA(J+1)
            L3=L2-L1-1
            M=J-I
            IF (L3 .LT. M) CYCLE
            M1=L1+M
            A(M1)=A(M1)/A(KN)
         END DO
      END DO
      RETURN
      END SUBROUTINE GMFADS
      SUBROUTINE GMRES(N, KDMAX, ITMAX, RHS, X, KVAL,
     &                PRECON, IFLAG, ROWPOSP, COLPOSP)
C
C THIS ROUTINE IS AN EXTENSION OF THE STANDARD RESTARTED GMRES METHOD OF
C Y. SAAD AND M. SCHULTZ, "GMRES: A GENERALIZED MINIMAL RESIDUAL METHOD
C FOR SOLVING NONSYMMETRIC LINEAR SYSTEMS", SIAM J. SCI. STAT. COMPUT., 7
C (1986), PP. 856-869, THAT ALLOWS THE MAXIMUM KRYLOV SUBSPACE DIMENSION
C TO INCREASE (UP TO A MAXIMUM SPECIFIED PARAMETER VALUE) IF STAGNATION
C OCCURS.  THE ARNOLDI BASIS VECTORS ARE GENERATED USING ORTHOGONALIZATION
C WITH HOUSEHOLDER TRANSFORMATIONS.
C ON RESTARTS, RESIDUAL VECTORS ARE COMPUTED BY DIRECT EVALUATION.
C CONDITIONING OF THE GMRES LEAST-SQUARES PROBLEM IS MONITORED USING 
C LAPACK ROUTINE DLAIC1 (SEE P. N. BROWN AND H. F. WALKER, "GMRES ON 
C (NEARLY) SINGULAR SYSTEMS", UTAH STATE UNIV.  C MATH. STAT. DEPT. RES.
C REPORT 2/94/73, FEBRUARY, 1994).
C
C
C INPUT VARIABLES:
C
C N  IS THE DIMENSION OF THE LINEAR SYSTEM AA*X = RHS.  THE SPARSE
C   MATRIX DATA STRUCTURE FOR AA IS STORED IN THE MODULE HOMOTOPY.
C
C KDMAX  IS THE MAXIMUM KRYLOV SUBSPACE DIMENSION ALLOWED BEFORE
C   STAGNATION DETECTION BEGINS.
C
C ITMAX  IS THE MAXIMUM OVERALL NUMBER OF GMRES ITERATIONS ALLOWED.
C
C RHS  IS THE RIGHT HAND SIDE OF THE LINEAR SYSTEM.
C
C X  IS THE INITIAL APPROXIMATE SOLUTION OF THE LINEAR SYSTEM.
C
C KVAL  IS AN INDEX INTO X REQUIRED FOR MATRIX-VECTOR MULTIPLICATION.
C  
C PRECON  IS A ONE-DIMENSIONAL REAL ARRAY CONTAINING A PRECONDITIONING
C   MATRIX Q FOR AA.   
C
C IFLAG  INDICATES WHAT DATA IS USED IN MATRIX-VECTOR MULTIPLICATION.
C
C ROWPOSP  IS AN OPTIONAL INTEGER ARRAY USED IN THE DATA STRUCTURE
C   DESCRIBING THE SPARSE PRECONDITIONING MATRIX Q. 
C
C COLPOSP  IS AN OPTIONAL INTEGER ARRAY USED IN THE DATA STRUCTURE
C   DESCRIBING THE SPARSE PRECONDITIONING MATRIX Q. 
C
C OUTPUT VARIABLES:
C
C KDMAX  IS THE INCREASED MAXIMUM KRYLOV SUBSPACE DIMENSION ON
C   TERMINATION.
C
C IFLAG  IS UNCHANGED ON NORMAL TERMINATION (DESIRED TOLERANCE MET);
C   = 4, IF GMRES ITERATION FAILS TO CONVERGE BECAUSE
C      - DESIRED TOLERANCE NOT MET AFTER ITMAX ITERATIONS;
C      - DANGEROUS NEAR-SINGULARITY DETECTED;
C      - LIMITS OF NUMERICAL ACCURACY REACHED;
C      - STAGNATION OCCURS.
C
C ITMAX  IS THE TOTAL NUMBER OF GMRES ITERATIONS PERFORMED.
C
C X  IS THE FINAL APPROXIMATE SOLUTION.
C   
C
C  CALLS DNRM2, ILUSOLVDS, MULTDS, MULT2DS, SOLVDS, AND INTERNAL
C  SUBROUTINES MULM1 AND MULM2 AND INTERNAL FUNCTIONS APPL_HOUSE, HOUSE.
C
      USE HOMOTOPY, AA=>QRSPARSE
      USE REAL_PRECISION
      INTEGER, INTENT(IN):: KVAL, N
      INTEGER, INTENT(IN OUT):: IFLAG, ITMAX, KDMAX
      REAL (KIND=R8), INTENT(IN):: PRECON(:), RHS(N)  
      REAL (KIND=R8), INTENT(IN OUT):: X(N)
      INTEGER, INTENT(IN), OPTIONAL:: COLPOSP(:), ROWPOSP(:)
C
C IPRINT  IS A PARAMETER FOR THE FORTRAN UNIT NUMBER, WHICH IF POSITIVE
C   ACTIVATES TRACING OF THE GMRES ITERATIONS.
C M  IS A PARAMETER USED IN THE ADAPTIVE STRATEGY FOR INCREMENTING THE 
C   KRYLOV SUBSPACE DIMENSION (VALUE KDMAX).  
C STRONG_VERSION  IS A LOGICAL PARAMETER, WHICH IF TRUE CAUSES GMRES TO 
C   STOP IN TWO CASES: WHEN THE ESTIMATED CONDITION NUMBER IS GREATER 
C   THAN 1.0/(50*EPSILON); 
C   WHEN THE TRUE RESIDUAL NORM IS LARGE AND IT INCREASED DURING THE LAST 
C   RESTART CYCLE.
C
      INTEGER, PARAMETER:: IPRINT=0, M=4 
      LOGICAL, PARAMETER:: STRONG_VERSION=.TRUE.
C
C LOCAL VARIABLES.
C
      INTEGER:: I, IFLAGC, IFLAGI, IQUIT, ITNO, KD, 
     &  KDP1, KDLIMIT, LENAA 
      REAL (KIND=R8), ALLOCATABLE:: C(:), R(:,:), S(:), SVBIG(:), 
     &  SVSML(:), V(:,:), W(:)
      REAL (KIND=R8):: VTEMP(N), VTEMP2(N)
      REAL (KIND=R8):: BIG, BIGCND, CC, CNDMAX,
     &  RSN, RSNOLD, SESTPR, SMALL, SS, TEMP, TOL 
      INTERFACE
        FUNCTION DNRM2(N,X,STRIDE)
        USE REAL_PRECISION
        INTEGER:: N,STRIDE
        REAL (KIND=R8):: DNRM2,X(N)
        END FUNCTION DNRM2
      END INTERFACE
C
C DEFINE MAXIMUM ALLOWED KRYLOV SUBSPACE DIMENSION.
C
      KDLIMIT = MIN(MAX(200, INT(SQRT(REAL(N)))), (N+1)/2)
      KDMAX = MIN(KDMAX,KDLIMIT)
C
C ALLOCATE LOCAL ARRAYS.
C
      IF(.NOT. ALLOCATED(C)) ALLOCATE(C(KDLIMIT))
      IF(.NOT. ALLOCATED(R)) ALLOCATE(R(KDLIMIT,KDLIMIT))
      IF(.NOT. ALLOCATED(S)) ALLOCATE(S(KDLIMIT))
      IF(.NOT. ALLOCATED(SVBIG)) ALLOCATE(SVBIG(KDLIMIT))
      IF(.NOT. ALLOCATED(SVSML)) ALLOCATE(SVSML(KDLIMIT))
      IF(.NOT. ALLOCATED(V)) ALLOCATE(V(N,KDLIMIT+1))
      IF(.NOT. ALLOCATED(W)) ALLOCATE(W(KDLIMIT+1))
C
C PERFORM INITIALIZATIONS.
C
      ITNO = 0
      IFLAGC = 0
      IFLAGI = 1
      LENAA = ROWPOS(N)-1
      TOL = MAX(100.0, 1.01*REAL(LENAA)/REAL(N))*EPSILON(1.0_R8)
      VTEMP = X
      IF (PRESENT(ROWPOSP) .AND. PRESENT( COLPOSP)) THEN
        CALL MULM2(V(:,1),VTEMP)            ! MODE=2 
      ELSE 
        CALL MULM1(V(:,1),VTEMP)            ! MODE=1 
      END IF
      V(:,1) = RHS - V(:,1)
      RSN = DNRM2(N, V(:,1), 1)
      TEMP = DNRM2(N, RHS, 1)
      TOL = MAX(RSN,TEMP)*TOL
      IF (RSN .LE. TOL) THEN 
         ITMAX = ITNO
         CALL CLEANUP
         RETURN
      ELSE
         IF (ITMAX .EQ. 0) THEN 
            ITMAX = ITNO
            IFLAG = 4
            CALL CLEANUP
            RETURN
         ENDIF
      ENDIF
      CNDMAX = 1.0/(50.0*EPSILON(1.0_R8))
      IQUIT = 0
      BIGCND = 0.0
C
C FOR PRINTING:
C
      IF (IPRINT .GT. 0) THEN 
         WRITE(IPRINT, 19) ITNO, RSN
19       FORMAT(//,9X,'GMRES ITERATIONS:',//,T4,'ITERATION',TR4,
     &   'RESIDUAL NORM',TR5,'CONDITION NUMBER',/,T4,I6,TR7,ES16.8)
      ENDIF
C
C BEGIN THE OUTER LOOP. 
C
      OUTER: DO
C
C FOR PRINTING:
C
      IF (IPRINT .GT. 0 ) THEN
        IF (IFLAGI .NE. 0) THEN
          WRITE (IPRINT, 21) KDMAX
21        FORMAT(/' RESTART WITH KRYLOV SUBSPACE DIMENSION =',I2)
        ELSE
           WRITE(IPRINT, 22) 
22         FORMAT(/' RESTART')
        ENDIF
      ENDIF
C
      KD = 0
      RSNOLD = RSN
      IQUIT = 0
      IFLAGI = 0
C
C FIND HOUSEHOLDER VECTOR V(:,1).
C
      W(1)=V(1,1)
      CALL HREFG(N,V(2:N,1),V(1,1),W(1))
C
C BEGIN THE INNER LOOP.
C
 200  INNER: DO
      KD = KD + 1
      KDP1 = KD + 1
      ITNO = ITNO + 1
      IQUIT = 0 
C
C FIND THE KD-TH ORTHOGONAL VECTOR.
C
      VTEMP = 0.0 
      VTEMP(KD) = 1.0
      DO I=KD,1,-1
        TEMP=V(I,I)
        V(I,I)=1.0
        CALL HREFX(N-I+1,V(I:N,I),TEMP,VTEMP(I:N))
        V(I,I)=TEMP
      END DO
C
C EVALUATE AA*(KD-TH KRYLOV SUBSPACE BASIS VECTOR). 
C
        IF (PRESENT(ROWPOSP) .AND. PRESENT(COLPOSP)) THEN  ! MODE = 2
          CALL ILUSOLVDS(N, PRECON(1:ROWPOSP(N+1)-1), 
     &      ROWPOSP(N+1)-1, ROWPOSP(1:N+1), 
     &      COLPOSP(1:ROWPOSP(N+1)-1), VTEMP(1:N))
          CALL MULM2(VTEMP2, VTEMP(1:N))
        ELSE                                               ! MODE = 1 
          CALL SOLVDS(N, PRECON, ROWPOS(N+1)-1, ROWPOS(1:N+1),
     &      VTEMP(1:N))
          CALL MULM1(VTEMP2, VTEMP(1:N))
        ENDIF
C
C FIND HOUSEHOLDER VECTOR V(:,KDP1).
C
      VTEMP(1:N)=VTEMP2(1:N)
      DO I=1,KD
        TEMP=V(I,I)
        V(I,I)=1.0
        CALL HREFX(N-I+1,V(I:N,I),TEMP,VTEMP(I:N))
        V(I,I)=TEMP
      END DO 
      IF ( MAXVAL(ABS(VTEMP(KDP1:N))) .NE. 0.0) THEN
        V(KDP1+1:N, KDP1) = VTEMP(KDP1+1:N)
        CALL HREFG(N-KDP1+1,V(KDP1+1:N, KDP1),V(KDP1,KDP1), 
     &   VTEMP(KDP1))
      ENDIF
C
C IF KD .GT. 1, APPLY THE PREVIOUS GIVENS ROTATIONS. 
C
      DO I = 1, KD-1
        TEMP = VTEMP(I) 
        VTEMP(I) = C(I)*TEMP + S(I)*VTEMP(I+1)
        VTEMP(I+1) = -S(I)*TEMP + C(I)*VTEMP(I+1)
      END DO   
C
C DETERMINE AND APPLY THE NEXT ROTATION. 
C
      IF (VTEMP(KDP1) .NE. 0.0) THEN
        TEMP = VTEMP(KD)
        R(KD,KD) = SQRT(VTEMP(KD)**2 + VTEMP(KDP1)**2) 
        C(KD) = TEMP/R(KD,KD)
        S(KD) = VTEMP(KDP1)/R(KD,KD)
        VTEMP(KD) = C(KD)*TEMP + S(KD)*VTEMP(KDP1)
      END IF 
      R(1:KD, KD) = VTEMP(1:KD)
C
C COMPUTE AND TEST INCREMENTAL CONDITION NUMBER.
C
      IF (KD .EQ. 1) THEN 
        BIG = R(KD,KD) 
        SMALL = BIG 
        SVBIG(1) = 1.0
        SVSML(1) = 1.0
      ELSE
        I = 1
        CALL DLAIC1(I, KD-1, SVBIG, BIG, R(1,KD), R(KD,KD),
     &    SESTPR, SS, CC)
        BIG = SESTPR
        SVBIG(1:KD-1) = SS*SVBIG(1:KD-1)
        SVBIG(KD) = CC
        I = 2
        CALL DLAIC1(I, KD-1, SVSML, SMALL, R(1,KD), R(KD,KD),
     &    SESTPR, SS, CC)
        SMALL = SESTPR
        SVSML(1:KD-1) = SS*SVSML(1:KD-1)
        SVSML(KD) = CC
      ENDIF
      IF (STRONG_VERSION) THEN
        IF (BIG .GE. SMALL*CNDMAX) THEN
          IF (IPRINT .GT. 0) THEN
            WRITE (IPRINT, 230) CNDMAX
 230        FORMAT(/,4X, 'IN GMRES CONDITION NUMBER .GE.',
     &      ES16.8)
          ENDIF
          ITNO = ITNO - 1
          IFLAGC = 4
          EXIT OUTER
        ENDIF
      ENDIF  
      TEMP = BIG/SMALL
      IF (TEMP .GT. BIGCND) BIGCND = TEMP
C
C UPDATE W AND THE RESIDUAL NORM. 
C
      IF (VTEMP(KDP1) .NE. 0.0) THEN
        W(KDP1)= -S(KD)*W(KD)
        W(KD) = C(KD)*W(KD)
      ELSE
        W(KDP1) = 0.0
      ENDIF 
      RSN = ABS(W(KDP1))
C
C FOR PRINTING:
C
      IF (IPRINT .GT. 0 ) THEN
        WRITE (IPRINT, 240) ITNO, RSN, BIG/SMALL                             
 240    FORMAT(T4,I6, TR7,2ES16.8)
      ENDIF
C
C TEST FOR TERMINATION OF THE INNER LOOP. 
C
      IF (RSN .LE. TOL .OR. KD .EQ. KDMAX .OR. ITNO .EQ. ITMAX)
     &  EXIT INNER
      END DO INNER
C
C IF TERMINATING THE INNER LOOP, TEST FOR TERMINATION OF THE OUTER LOOP, 
C COMPUTE THE CORRECTION, AND UPDATE THE APPROXIMATE SOLUTION. 
C
C TEST FOR TERMINATION OF THE OUTER LOOP. 
C
      IF (RSN .LE. TOL .OR. ITNO .EQ. ITMAX ) THEN
        IQUIT = 1
C
C TEST FOR STAGNATION.
C
      ELSE 
        TEMP = KD*LOG(TOL/RSN)/
     &    LOG(RSN/((1.0 + 10.0*EPSILON(1.0_R8))*RSNOLD))
        IF (TEMP .GE. 40.0*(ITMAX - ITNO)) THEN
          IF (KDMAX .LE. KDLIMIT-M) THEN
            IFLAGI = 3
            KDMAX = KDMAX + M ! INCREASE KDMAX BY M
            GO TO 200
          ELSE IF (KDMAX .NE. KDLIMIT) THEN
            IFLAGI = 3 
            KDMAX = KDLIMIT
            GO TO 200 
          END IF
        ENDIF 
      ENDIF             
C
C COMPUTE THE CORRECTION IN V(:,1).
C
      DO I = KD, 1, -1
        W(I) = W(I)/R(I,I)
        IF (I .GT. 1) W(1:I-1) = W(1:I-1)-W(I)*R(1:I-1,I) 
      END DO
C
C COMPUTE KD ORTHOGONAL VECTORS FROM HOUSEHOLDER VECTORS.
C
      VTEMP = 0.0
      VTEMP(1:KD)=W(1:KD)
      DO I=KD,1,-1
        TEMP=V(I,I)
        V(I,I)=1.0
        CALL HREFX(N-I+1,V(I:N,I), TEMP, VTEMP(I:N))
        V(I,I)=TEMP
      END DO
C
C ADD THE CORRECTION TO THE APPROXIMATE SOLUTION. 
C
      IF (PRESENT(ROWPOSP) .AND. PRESENT(COLPOSP)) THEN    ! MODE = 2
        CALL ILUSOLVDS(N, PRECON(1:ROWPOSP(N+1)-1), 
     &     ROWPOSP(N+1)-1, ROWPOSP(1:N+1), 
     &     COLPOSP(1:ROWPOSP(N+1)-1), VTEMP(1:N))
      ELSE                                                 ! MODE = 1
        CALL SOLVDS(N, PRECON, ROWPOS(N+1)-1, ROWPOS(1:N+1),
     &     VTEMP(1:N))
      ENDIF
      X = X+VTEMP
C
C UPDATE THE RESIDUAL VECTOR BY DIRECT EVALUATION IN (V:,1) AND RECOMPUTE 
C THE RESIDUAL NORM.
C
      IF (IQUIT .EQ. 0 ) THEN
        VTEMP=X
        IF (PRESENT(ROWPOSP) .AND. PRESENT( COLPOSP)) THEN
          CALL MULM2(V(:,1),VTEMP)            ! MODE=2
        ELSE
          CALL MULM1(V(:,1),VTEMP)            ! MODE=1
        END IF
        V(:,1) = RHS - V(:,1)
        RSN = DNRM2(N, V(:,1), 1)
      ENDIF
C
C TERMINATE, OR GO TO THE TOP OF THE OUTER LOOP.
C
      IF (RSN .LE. TOL) THEN 
        IFLAGC = 0
        EXIT OUTER 
      ENDIF
      IF (ITNO .EQ. ITMAX) THEN 
        IF (IPRINT .GT. 0) THEN
          WRITE (IPRINT, 250) ITMAX 
 250      FORMAT(/,4X, 'MAXIMUM NUMBER OF ITERATIONS REACHED:',I7)
        ENDIF
        IFLAGC = 4 
        EXIT OUTER
      END IF 
      IF (IQUIT .EQ. 0 ) THEN
        IF (RSN .GT. RSNOLD ) THEN
          IF (IPRINT .GT. 0) THEN
            WRITE (IPRINT, 260) RSN     
 260        FORMAT(/,4X, '(TRUE) RESIDUAL NORM INCREASED TO',ES16.8)
          ENDIF
          IF (RSN .LE. TOL**(2.0/3.0))  THEN
            IFLAGC = 0
          ELSE  IF (STRONG_VERSION) THEN
            IF (IPRINT .GT. 0) THEN
              WRITE (IPRINT, 270) TOL**(2.0/3.0)                
 270          FORMAT(/,4X,'(TRUE) RESIDUAL NORM IS LARGER THAN',ES16.8)
            ENDIF
            IFLAGC = 4
          END IF
          EXIT OUTER
        END IF
C
C TEST FOR STAGNATION USING TRUE RESIDUAL NORM.
C
        TEMP = KD*LOG(TOL/RSN)/
     &     LOG(RSN/((1.0 + 10.0*EPSILON(1.0_R8))*RSNOLD))
        IF (TEMP .GE. 70.0*(ITMAX - ITNO)) THEN
          IFLAGI = 3
          IF ( KDMAX .LE. KDLIMIT-M ) THEN
            KDMAX = KDMAX + M            ! INCREASE KDMAX
          ELSE IF (KDMAX .NE. KDLIMIT) THEN
            KDMAX = KDLIMIT
          END IF
        ELSE  IF (TEMP .GE. 1000.0*(ITMAX - ITNO)) THEN
          IFLAGC = 4
          EXIT OUTER
        END IF
      END IF
      END DO OUTER
C
C RETURN. 
C
      ITMAX = ITNO
      IF (IFLAGC .NE. 0) IFLAG = IFLAGC
      CALL CLEANUP
      RETURN
C
C INTERNAL SUBROUTINES.
C
      CONTAINS
      SUBROUTINE MULM1(Y,X)
C
C MATRIX-VECTOR MULTIPLY FOR MODE = 1.
C 
        REAL (KIND=R8), INTENT(IN):: X(N) 
        REAL (KIND=R8), INTENT(OUT):: Y(N) 
        Y = 0.0
        CALL MULTDS(Y(1:N-1), AA, X(1:N-1), ROWPOS(1:N),
     &    N-1, ROWPOS(N)-1)       
C
C       RESULT MODIFIED ACCORDING TO KVAL.
C
        Y(KVAL) = Y(KVAL)+X(N)
        IF (KVAL .LT. N) 
     &    Y(N) = X(KVAL) + X(N)*(1.0/ABS(AA(ROWPOS(KVAL)))+1.0)
        RETURN
      END SUBROUTINE MULM1
C       
      SUBROUTINE MULM2(Y,X)
C
C MATRIX-VECTOR MULTIPLY FOR MODE = 2.
C
        REAL (KIND=R8), INTENT(IN):: X(N)
        REAL (KIND=R8), INTENT(OUT):: Y(N) 
        INTERFACE
          SUBROUTINE MULT2DS(Y, B, X, ROWPOS, COLPOS, N, LENB)
            USE REAL_PRECISION
            INTEGER, INTENT (IN):: LENB, N, ROWPOS(N+1),   
     &        COLPOS(LENB)
            REAL (KIND=R8), INTENT(IN):: X(:), B(LENB)
            REAL (KIND=R8), INTENT (OUT):: Y(N)
          END SUBROUTINE MULT2DS
        END INTERFACE
        Y = 0.0
        IF (IFLAG .NE. -2) THEN 
          CALL MULT2DS(Y(1:N-1), AA, X(1:N-1), ROWPOS(1:N), 
     &      COLPOS(1:LENAA), N-1, LENAA)
          Y(1:N-1) = Y(1:N-1)-X(N)*PP(1:N-1)
        ELSE
          CALL MULT2DS(Y(1:N-1), AA, X(1:N), ROWPOS(1:N),
     &      COLPOS(1:LENAA), N-1, LENAA)
        END IF
C
C       RESULT MODIFIED ACCORDING TO KVAL.
C
        Y(N) = X(KVAL)
        RETURN
      END SUBROUTINE MULM2
      SUBROUTINE CLEANUP    ! DEALLOCATE TEMPORARY LOCAL STORAGE.
        IF(ALLOCATED(C)) DEALLOCATE(C)
        IF(ALLOCATED(R)) DEALLOCATE(R)
        IF(ALLOCATED(S)) DEALLOCATE(S)
        IF(ALLOCATED(SVBIG)) DEALLOCATE(SVBIG)
        IF(ALLOCATED(SVSML)) DEALLOCATE(SVSML)
        IF(ALLOCATED(V)) DEALLOCATE(V)
        IF(ALLOCATED(W)) DEALLOCATE(W)
      END SUBROUTINE CLEANUP
C 
      SUBROUTINE HREFG(N, X, TAU, ALPHA)
C
C HOUSEHOLDER VECTOR CONSTRUCTION. HREFG IS  THE LAPACK AUXILIARY 
C ROUTINE DLARFG WITH TRIVIAL MODIFICATIONS FOR COMPATIBILITY WITH
C HOMPACK90.
C
      INTEGER, INTENT(IN):: N
      REAL (KIND=R8), INTENT(OUT):: ALPHA, TAU
      REAL (KIND=R8), INTENT(IN OUT):: X(N-1)
!
!  Purpose
!  =======
!
!  HREFG generates a real elementary reflector H of order N, such
!  that
!
!        H * ( ALPHA ) = ( BETA ),   H' * H = I.
!            (   X   )   (   0  )
!
!  where ALPHA and BETA are scalars, and X is an (N-1)-element real
!  vector. H is represented in the form
!
!        H = I - TAU * ( 1 ) * ( 1 V' ) ,
!                      ( V )
!
!  where TAU is a real scalar and V is a real (N-1)-element
!  vector.
!
!  If the elements of X are all zero, then TAU = 0 and H is taken to be
!  the unit matrix.
!
!  Otherwise  1 <= TAU <= 2.  
!
!  Arguments
!  =========
!
!  N       (input)
!          The order of the elementary reflector.
!
!
!  X       (input/output) 
!          On entry, the vector X.
!          On exit, it is overwritten with the vector V.
!
!  TAU     (output)
!          The value TAU.
! 
!  ALPHA   (INPUT/OUTPUT)
!          On entry, the value ALPHA.
!          On exit, it is overwritten with the value BETA.
!
!  =====================================================================
!
!     .. Parameters ..
      REAL (KIND=R8), PARAMETER:: ONE = 1.0_R8, ZERO = 0.0_R8
!     .. Local Scalars ..
      INTEGER::          J, KNT
      REAL (KIND=R8)::   BETA, RSAFMN, SAFMIN, XNORM
!       
!     .. External Functions ..
      INTERFACE
        FUNCTION DLAMCH(CMACH)
          USE REAL_PRECISION
          CHARACTER (LEN=1):: CMACH
          REAL (KIND=R8):: DLAMCH
        END FUNCTION DLAMCH
        FUNCTION DLAPY2(X,Y)
          USE REAL_PRECISION
          REAL (KIND=R8):: DLAPY2,X,Y
        END FUNCTION DLAPY2
        FUNCTION DNRM2(N,X,STRIDE)
          USE REAL_PRECISION
          INTEGER:: N,STRIDE
          REAL (KIND=R8):: DNRM2,X(N)
        END FUNCTION DNRM2
      END INTERFACE
!      
!     .. Executable Statements ..
!
      IF( N.LE.1 ) THEN
         TAU = ZERO
         RETURN
      END IF
      XNORM = DNRM2( N-1, X, 1)
      IF( XNORM.EQ.ZERO ) THEN
!
!        H  =  I
!
         TAU = ZERO
      ELSE
!
!        General case.
!
         BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )
         SAFMIN = DLAMCH( 'S' )
         IF( ABS( BETA ).LT.SAFMIN ) THEN
!
!           XNORM, BETA may be inaccurate; scale X and recompute them.
!
            RSAFMN = ONE / SAFMIN
            KNT = 0
            DO WHILE (ABS(BETA) < SAFMIN)
              KNT = KNT + 1
              X=RSAFMN*X
              BETA = BETA*RSAFMN
              ALPHA = ALPHA*RSAFMN
            END DO
!
!           New BETA is at most 1, at least SAFMIN.
!
            XNORM = DNRM2( N-1, X, 1 )
            BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )
            TAU = ( BETA-ALPHA ) / BETA
            X = X/( ALPHA-BETA )
!
!           If ALPHA is subnormal, it may lose relative accuracy.
!
            ALPHA = BETA
            DO J = 1, KNT
               ALPHA = ALPHA*SAFMIN
            END DO
         ELSE
            TAU = ( BETA-ALPHA) / BETA
            X = X/( ALPHA-BETA )
            ALPHA = BETA
         END IF
      END IF
      RETURN
      END SUBROUTINE HREFG
C
      SUBROUTINE HREFX(M, V, TAU, C)
C
C HOUSEHOLDER VECTOR APPLICATION. HREFX IS A FORTRAN 90 VERSION OF
C THE LAPACK ROUTINE DLARFX WITH MODIFICATIONS FOR
C COMPATIBILITY WITH HOMPACK 90.
C
      INTEGER, INTENT(IN):: M
      REAL (KIND=R8), INTENT(IN):: TAU, V(M)
      REAL (KIND=R8), INTENT(IN OUT):: C(M) 
!
!  Purpose
!  =======
!
!  HREFX applies a real elementary reflector H to a real M-element
!  vector C. H is represented in the form
!
!        H = I - TAU * V * V'
!
!  where TAU is a real scalar and V is a real vector.
!
!  If TAU = 0, then H is taken to be the unit matrix.
!
!  This version uses inline code if H has order < 11.
!
!  Arguments
!  =========
!
!  M       (input)
!          The order of the vector C.
!
!  V       (input) 
!          The vector V in the representation of H.
!
!  TAU     (input) 
!          The value TAU in the representation of H.
!
!  C       (input/output) 
!          On entry, the M-element vector C.
!          On exit, C is overwritten by H * C.
!
!  =====================================================================
!
!     ..  Parameters ..
      REAL (KIND=R8), PARAMETER:: ONE=1.0_R8, ZERO=0.0_R8
!
!     .. Local Scalars ..
      REAL (KIND=R8):: SUM, T1, T10, T2, T3, T4, T5, T6, T7, T8, T9,
     &                   V1, V10, V2, V3, V4, V5, V6, V7, V8, V9
!
!     .. Executable Statements ..  
!
      IF( TAU.EQ.ZERO ) RETURN
!
!        Form  H * C, where H has order M.
!
      SELECT CASE(M)
!
!     Code for general M.
!
      CASE (11:)
!
!     C := C - TAU * V * V' * C
!
           C = C - (TAU * DOT_PRODUCT(V,C)) * V
!
!        Special code for 1 x 1 Householder. 
!
      CASE(1)
           T1 = ONE - TAU*V( 1 )*V( 1 )
           C(1) = T1*C(1)
!
!        Special code for 2 x 2 Householder.
!
      CASE(2)
           V1 = V( 1 )
           T1 = TAU*V1
           V2 = V( 2 )
           T2 = TAU*V2
           SUM = V1*C(1) + V2*C(2)
           C(1) = C(1) - SUM*T1
           C(2) = C(2) - SUM*T2
!
!        Special code for 3 x 3 Householder.
!
      CASE(3)
           V1 = V( 1 )
           T1 = TAU*V1
           V2 = V( 2 )
           T2 = TAU*V2
           V3 = V( 3 )
           T3 = TAU*V3
           SUM = V1*C(1) + V2*C(2) + V3*C(3)
           C(1) = C(1) - SUM*T1
           C(2) = C(2) - SUM*T2
           C(3) = C(3) - SUM*T3
!
!        Special code for 4 x 4 Householder.
!
      CASE(4)
           V1 = V( 1 )
           T1 = TAU*V1
           V2 = V( 2 )
           T2 = TAU*V2
           V3 = V( 3 )
           T3 = TAU*V3
           V4 = V( 4 )
           T4 = TAU*V4
           SUM = V1*C(1) + V2*C(2) + V3*C(3) + V4*C(4)
           C( 1 ) = C( 1 ) - SUM*T1
           C( 2 ) = C( 2 ) - SUM*T2
           C( 3 ) = C( 3 ) - SUM*T3
           C( 4 ) = C( 4 ) - SUM*T4
!
!        Special code for 5 x 5 Householder.
!
      CASE(5)
           V1 = V( 1 )
           T1 = TAU*V1
           V2 = V( 2 )
           T2 = TAU*V2
           V3 = V( 3 )
           T3 = TAU*V3
           V4 = V( 4 )
           T4 = TAU*V4
           V5 = V( 5 )
           T5 = TAU*V5
           SUM = V1*C( 1 ) + V2*C( 2 ) + V3*C( 3 ) +
     &            V4*C( 4 ) + V5*C( 5 )
           C( 1 ) = C( 1 ) - SUM*T1
           C( 2 ) = C( 2 ) - SUM*T2
           C( 3 ) = C( 3 ) - SUM*T3
           C( 4 ) = C( 4 ) - SUM*T4
           C( 5 ) = C( 5 ) - SUM*T5
!
!        Special code for 6 x 6 Householder.
!
      CASE(6)
           V1 = V( 1 )
           T1 = TAU*V1
           V2 = V( 2 )
           T2 = TAU*V2
           V3 = V( 3 )
           T3 = TAU*V3
           V4 = V( 4 )
           T4 = TAU*V4
           V5 = V( 5 )
           T5 = TAU*V5
           V6 = V( 6 )
           T6 = TAU*V6
           SUM = V1*C( 1 ) + V2*C( 2 ) + V3*C( 3 ) +
     &            V4*C( 4 ) + V5*C( 5 ) + V6*C( 6 )
           C( 1 ) = C( 1 ) - SUM*T1
           C( 2 ) = C( 2 ) - SUM*T2
           C( 3 ) = C( 3 ) - SUM*T3
           C( 4 ) = C( 4 ) - SUM*T4
           C( 5 ) = C( 5 ) - SUM*T5
           C( 6 ) = C( 6 ) - SUM*T6
!
!        Special code for 7 x 7 Householder.
!
      CASE(7)
           V1 = V( 1 )
           T1 = TAU*V1
           V2 = V( 2 )
           T2 = TAU*V2
           V3 = V( 3 )
           T3 = TAU*V3
           V4 = V( 4 )
           T4 = TAU*V4
           V5 = V( 5 )
           T5 = TAU*V5
           V6 = V( 6 )
           T6 = TAU*V6
           V7 = V( 7 )
           T7 = TAU*V7
           SUM = V1*C( 1 ) + V2*C( 2 ) + V3*C( 3 ) +
     &            V4*C( 4 ) + V5*C( 5 ) + V6*C( 6 ) +
     &            V7*C( 7 )
           C( 1 ) = C( 1 ) - SUM*T1
           C( 2 ) = C( 2 ) - SUM*T2
           C( 3 ) = C( 3 ) - SUM*T3
           C( 4 ) = C( 4 ) - SUM*T4
           C( 5 ) = C( 5 ) - SUM*T5
           C( 6 ) = C( 6 ) - SUM*T6
           C( 7 ) = C( 7 ) - SUM*T7
!
!        Special code for 8 x 8 Householder.
!
      CASE(8) 
           V1 = V( 1 )
           T1 = TAU*V1
           V2 = V( 2 )
           T2 = TAU*V2
           V3 = V( 3 )
           T3 = TAU*V3
           V4 = V( 4 )
           T4 = TAU*V4
           V5 = V( 5 )
           T5 = TAU*V5
           V6 = V( 6 )
           T6 = TAU*V6
           V7 = V( 7 )
           T7 = TAU*V7
           V8 = V( 8 )
           T8 = TAU*V8
           SUM = V1*C( 1 ) + V2*C( 2 ) + V3*C( 3 ) +
     &            V4*C( 4 ) + V5*C( 5 ) + V6*C( 6 ) +
     &            V7*C( 7 ) + V8*C( 8 )
           C( 1 ) = C( 1 ) - SUM*T1
           C( 2 ) = C( 2 ) - SUM*T2
           C( 3 ) = C( 3 ) - SUM*T3
           C( 4 ) = C( 4 ) - SUM*T4
           C( 5 ) = C( 5 ) - SUM*T5
           C( 6 ) = C( 6 ) - SUM*T6
           C( 7 ) = C( 7 ) - SUM*T7
           C( 8 ) = C( 8 ) - SUM*T8
!
!        Special code for 9 x 9 Householder.
!
      CASE(9)
           V1 = V( 1 )
           T1 = TAU*V1
           V2 = V( 2 )
           T2 = TAU*V2
           V3 = V( 3 )
           T3 = TAU*V3
           V4 = V( 4 )
           T4 = TAU*V4
           V5 = V( 5 )
           T5 = TAU*V5
           V6 = V( 6 )
           T6 = TAU*V6
           V7 = V( 7 )
           T7 = TAU*V7
           V8 = V( 8 )
           T8 = TAU*V8
           V9 = V( 9 )
           T9 = TAU*V9
           SUM = V1*C( 1 ) + V2*C( 2 ) + V3*C( 3 ) +
     &            V4*C( 4 ) + V5*C( 5 ) + V6*C( 6 ) +
     &            V7*C( 7 ) + V8*C( 8 ) + V9*C( 9 )
           C( 1 ) = C( 1 ) - SUM*T1
           C( 2 ) = C( 2 ) - SUM*T2
           C( 3 ) = C( 3 ) - SUM*T3
           C( 4 ) = C( 4 ) - SUM*T4
           C( 5 ) = C( 5 ) - SUM*T5
           C( 6 ) = C( 6 ) - SUM*T6
           C( 7 ) = C( 7 ) - SUM*T7
           C( 8 ) = C( 8 ) - SUM*T8
           C( 9 ) = C( 9 ) - SUM*T9
!
!        Special code for 10 x 10 Householder.
!
      CASE (10)
           V1 = V( 1 )
           T1 = TAU*V1
           V2 = V( 2 )
           T2 = TAU*V2
           V3 = V( 3 )
           T3 = TAU*V3
           V4 = V( 4 )
           T4 = TAU*V4
           V5 = V( 5 )
           T5 = TAU*V5
           V6 = V( 6 )
           T6 = TAU*V6
           V7 = V( 7 )
           T7 = TAU*V7
           V8 = V( 8 )
           T8 = TAU*V8
           V9 = V( 9 )
           T9 = TAU*V9
           V10 = V( 10 )
           T10 = TAU*V10
           SUM = V1*C( 1 ) + V2*C( 2 ) + V3*C( 3 ) +
     &            V4*C( 4 ) + V5*C( 5 ) + V6*C( 6 ) +
     &            V7*C( 7 ) + V8*C( 8 ) + V9*C( 9 ) +
     &            V10*C( 10 )
           C( 1 ) = C( 1 ) - SUM*T1
           C( 2 ) = C( 2 ) - SUM*T2
           C( 3 ) = C( 3 ) - SUM*T3
           C( 4 ) = C( 4 ) - SUM*T4
           C( 5 ) = C( 5 ) - SUM*T5
           C( 6 ) = C( 6 ) - SUM*T6
           C( 7 ) = C( 7 ) - SUM*T7
           C( 8 ) = C( 8 ) - SUM*T8
           C( 9 ) = C( 9 ) - SUM*T9
           C( 10 ) = C( 10 ) - SUM*T10
      END SELECT   
      RETURN
      END SUBROUTINE HREFX
      END SUBROUTINE GMRES
      SUBROUTINE GMRILUDS(NN,LENAA,IFLAG,START,RHS)
C
C     This subroutine solves a system of equations using a
C     preconditioned adaptive GMRES(k).
C     GMRILUDS is the MODE=2 equivalent of subroutine PCGDS, which
C     is only for MODE=1 storage.
C
C     The linear system to be solved is  Mx=b.
C     If IFLAG = -1 or 0,
C 
C        +--          --+ 
C        |        |     |
C        |   AA   | -PP |
C    M = |        |     | ,
C        +--------+-----+ 
C        |    E(k)**t   | 
C        +--          --+
C
C        where AA is an (NN x NN) matrix stored in compressed-row format,
C        PP is an (NN x 1) vector.
C        It is assumed that rank [AA,-PP]=NN and M is invertible.
C      If IFLAG = -2,
C
C        +--          --+ 
C        |              |
C        |     AA       | 
C    M = |              | , 
C        +--------+-----+ 
C        |    E(k)**t   | 
C        +--          --+ 
C
C        where AA is an (NN x (NN+1)) matrix stored in compressed-row 
C        format. It is assumed that rank [AA]=NN and M is invertible.
C
C        +-   -+          +-    -+
C        |  0  |          |      |
C        | ... |          | -RHS |
C    b = |  0  |,  or b = |      |, 
C        +-----+          +------+
C        |  T  |          |  T   |
C        +-   -+          +-    -+
C
C        T = START(k), where |START(k)|= max|START(i)|
C                                       1<=i<=NN+1
C
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
C  Input variables:
C
C      NN -- row dimension of the matrix packed in AA.
C
C      LENAA -- number of elements in the packed array AA.
C
C      IFLAG -- indicator of how M is assembled.  
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      RHS -- optional vector of length NN, used to define right hand
C             side for normal flow correction calculation.  It is
C             assumed that GMRILUDS is called without RHS present before
C             it is called with RHS present.  An ILU factorization based 
C             preconditioner is computed only when RHS is not present.
C
C  Input variables defined in module HOMOTOPY:
C
C      AA -- one dimensional real array containing a submatrix of M
C            in compressed-row storage form.  The logical dimensions
C            of AA depend on IFLAG.
C
C      ROWPOS -- integer array used for specifying information about AA.
C                Using compressed-row storage, it has length NN+2, and
C                stores the indices of where each row begins within AA.
C                ROWPOS(NN+1) = LENAA + 1 and ROWPOS(NN+2) = LENAA + 2.
C                (NOTE:  The value of ROWPOS(NN+2) is set by this
C                subroutine when the preconditioning matrix Q is
C                initialized.)
C
C      COLPOS -- integer array used for specifying information about AA.
C                Using compressed-row storage, it has length LENAA,
C                and contains the column indices of the corresponding
C                elements in AA.
C
C             For example, using the compressed-row storage scheme 
C             with IFLAG = -2, a 5 x 6 matrix of the form
C
C             +--               --+
C             |  1  3  0  0  0 10 |
C             |  3  2  0  7  0 11 |
C             |  0  0  4  6  0 12 |
C             |  0  7  6  5  9 13 |
C             |  0  0  0  9  8 14 |
C             +--               --+
C 
C             would result in NN=5, LENAA=18, ROWPOS=(1,4,8,11,16,19,*),
C             AA=(1,3,10,3,2,7,11,4,6,12,7,6,5,9,13,9,8,14),
C             COLPOS=(1,2,6,1,2,6,3,4,6,2,3,4,5,6,4,5,6).
C
C      PP -- vector of length NN, used for (NN+1)st column of
C            augmented matrix M when IFLAG = -1 or 0 .
C
C  Output variables:
C
C      START -- solution vector x of  M x = b  (defined above).
C
C      IFLAG -- normally unchanged on output.  If the GMRES
C               iteration fails to converge in 10*(NN+1) iterations (most
C               likely due to a singular Jacobian matrix), GMRILUDS returns
C               with  IFLAG = 4 , and does not compute x.
C
C  Calls subroutines ILUFDS and GMRES.
C
      USE HOMOTOPY, AA => QRSPARSE, WORK => PAR, IWORK => IPAR
      USE REAL_PRECISION
C
      INTEGER, INTENT(IN):: NN,LENAA
      INTEGER, INTENT(IN OUT):: IFLAG
      REAL (KIND=R8), INTENT(IN OUT):: START(NN+1)
      REAL (KIND=R8), INTENT(IN), OPTIONAL :: RHS(NN)
C
C LOCAL VARIABLES.
C
      INTEGER:: I, ITMAX, K, KD, NP1, QIND, ZBIND  
      INTEGER:: CIND, RIND, ROWL, STRT 
      REAL (KIND=R8):: STARTK
      REAL (KIND=R8):: RHSC(NN+1)
C
C GMRES PARAMETER.
C
      INTEGER, PARAMETER:: SUBSPACE=8         ! KRYLOV SUBSPACE VALUE.
C
      INTERFACE
        SUBROUTINE GMRES(N, KDMAX, ITMAX, RHSC, X, KVAL,
     &                Q, IFLAG, ROWPOSP, COLPOSP)
          USE HOMOTOPY
          USE REAL_PRECISION
          INTEGER, INTENT(IN):: KVAL, N
          INTEGER, INTENT(IN OUT):: IFLAG, ITMAX, KDMAX
          REAL (KIND=R8), INTENT(IN):: Q(:), RHSC(N)
          REAL (KIND=R8), INTENT(IN OUT):: X(N)
          INTEGER, INTENT(IN), OPTIONAL:: COLPOSP(:), ROWPOSP(:)
        END SUBROUTINE GMRES
        SUBROUTINE ILUFDS(NN, Q, LENQ, ROWPOS, COLPOS)
          USE REAL_PRECISION
          INTEGER, INTENT(IN):: LENQ, NN, COLPOS(LENQ), ROWPOS(NN+1) 
          REAL (KIND=R8), INTENT(IN OUT):: Q(LENQ) 
        END SUBROUTINE ILUFDS
      END INTERFACE 
C 
      NP1=NN+1 
C
C     INITIALIZE START POSITIONS WITHIN WORK AND IWORK.
C
      ZBIND = 1
      QIND = NP1+1
      RIND = 1
      CIND = NP1+2
C
      IF (.NOT. ALLOCATED(WORK)) THEN
        IF (IFLAG .EQ. -2) THEN
          ALLOCATE(WORK(NP1+LENAA+2)) 
        ELSE
          ALLOCATE(WORK(NP1+LENAA+NN+2))
        END IF
        WORK(1:NP1) = 0.0
      END IF
      IF (.NOT. ALLOCATED(IWORK)) THEN
        IF (IFLAG .EQ. -2) THEN
          ALLOCATE(IWORK(NP1+1+LENAA+2))
        ELSE
          ALLOCATE(IWORK(NP1+1+LENAA+NN+2))
        END IF
      END IF
C
C     FIND THE ELEMENT OF LARGEST MAGNITUDE IN THE INITIAL VECTOR, AND
C     RECORD ITS POSITION IN K.
C
      K = MAXVAL(MAXLOC(ABS(START)))
      STARTK = START(K)
C
C     SET VALUES OF ROWPOS(NN+1) AND ROWPOS(NN+2), AND
C     COMPUTE THE PRECONDITIONER Q FOR M.
C
      IF (.NOT. PRESENT(RHS)) THEN
        ROWPOS(NP1) = LENAA+1
        ROWPOS(NN+2) = LENAA+2
        IF (IFLAG .EQ. -2) THEN
          WORK(QIND:QIND+LENAA-1) = AA(1:LENAA)
          IWORK(RIND:RIND+NP1) = ROWPOS
          IWORK(CIND:CIND+LENAA-1) = COLPOS
        ELSE
C       MERGE AA AND -PP INTO Q ONLY FOR IFLAG >= -1. 
          IWORK(RIND) = 1
          DO I=1,NN
            STRT = IWORK(RIND+I-1)
            ROWL = ROWPOS(I+1)-ROWPOS(I)
            WORK(QIND+STRT-1:QIND+STRT+ROWL-2) = 
     &        AA(ROWPOS(I):ROWPOS(I+1)-1)
            WORK(QIND+STRT+ROWL-1) = -PP(I)
            IWORK(CIND+STRT-1:CIND+STRT+ROWL-2) =
     &        COLPOS(ROWPOS(I):ROWPOS(I+1)-1)
            IWORK(CIND+STRT+ROWL-1) = NN+1
            IWORK(RIND+I) = ROWPOS(I+1)+I
          END DO 
          IWORK(RIND+NP1) = ROWPOS(NN+2)+NN
        END IF
        WORK(QIND+IWORK(RIND+NN)-1) = 1.0
        IWORK(CIND+IWORK(RIND+NN)-1) = K
        IF (K. LT. NP1) THEN
          WORK(QIND+IWORK(RIND+NN)) = 0.0
          IWORK(CIND+IWORK(RIND+NN)) = NP1
          IWORK(RIND+NP1) = IWORK(RIND+NP1)+1
        END IF
        CALL ILUFDS(NP1, WORK(QIND:QIND+IWORK(RIND+NP1)-2),
     &    IWORK(RIND+NP1)-1, IWORK(RIND:RIND+NP1),
     &    IWORK(CIND:CIND+IWORK(RIND+NP1)-2))
      END IF
C
C     COMPUTE RIGHT HAND SIDE FOR Mx=b.
C
      RHSC(NP1) = STARTK
      IF (PRESENT(RHS)) THEN 
        RHSC(1:NN) = -RHS
      ELSE
        RHSC(1:NN) = 0.0
      END IF
C
C CALL GMRES FOR THE Mx=b SYSTEM.
C
      ITMAX=15*NP1
      KD=SUBSPACE          
      CALL GMRES(NP1, KD, ITMAX, RHSC, WORK(ZBIND:ZBIND+NN), 
     &  K, WORK(QIND:QIND+IWORK(RIND+NP1)-2), IFLAG,
     &  ROWPOSP=IWORK(RIND:RIND+NP1),
     &  COLPOSP=IWORK(CIND:CIND+IWORK(RIND+NP1)-2))
      IF ( IFLAG .GT. 0) RETURN
      START(1:NP1) = WORK(ZBIND:ZBIND+NN)
      RETURN
      END SUBROUTINE GMRILUDS
      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,MAXT,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    MAXT
C    IDEG
C    NUMT
C    KDEG
C
C  OTHER VARIABLES:
C    ONEML
C
C  SUBROUTINES:  GFUNP, FFUNP.
C
      USE REAL_PRECISION
C DECLARATION OF INPUT, WORKSPACE, AND OUTPUT:
      INTEGER, INTENT(IN):: N,MAXT,IDEG(N),NUMT(N),KDEG(N,N+1,MAXT)
      REAL (KIND=R8), INTENT(IN):: QDG(2,N),LAMBDA,X(2,N),
     &  PDG(2,N),CL(2,N+1),COEF(N,MAXT)
      REAL (KIND=R8), INTENT(OUT):: RHO(2*N),DRHOX(2*N,2*N),DRHOL(2*N)
      REAL (KIND=R8), INTENT(IN OUT):: 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,MAXT),TRM(2,N,MAXT),
     &  DTRM(2,N,N+1,MAXT),CLX(2,N),DXNP1(2,N)
C
C DECLARATION OF LOCAL VARIABLES:
      INTEGER:: J,J2,J2M1,K,K2,K2M1
      REAL (KIND=R8):: ONEML
C
      CALL GFUNP(N,IDEG,PDG,QDG,X,XDGM1,XDG,PXDGM1,PXDG,G,DG)
      CALL FFUNP(N,NUMT,MAXT,KDEG,COEF,CL,X,XX,TRM,DTRM,CLX,DXNP1,F,DF)
      ONEML=1.0 - LAMBDA
      DO J=1,N
          J2=2*J
          J2M1=J2-1
          DO 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)
          END DO
          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)
      END DO
      RETURN
      END SUBROUTINE HFUN1P
      SUBROUTINE HFUNP(N,QDG,LAMBDA,X)
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*MAXT
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)*MAXT
C         16              TRM               2*N*MAXT
C         17             DTRM               2*N*(N+1)*MAXT
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             MAXT               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)*MAXT   43+N2
C
C ON INPUT:
C
C N  IS THE NUMBER OF EQUATIONS AND VARIABLES.
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 ON OUTPUT:
C
C THE GLOBAL WORK ARRAYS PAR AND IPAR HAVE BEEN UPDATED.
C
C SUBROUTINES:  HFUN1P.
C
      USE HOMOTOPY
      USE REAL_PRECISION
      INTEGER, INTENT(IN):: N
      REAL (KIND=R8), INTENT(IN):: QDG(2,N),LAMBDA,X(2,N)
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 SUBROUTINE HFUNP
      SUBROUTINE ILUFDS(NP1, B, LENB, ROWPOSP, COLPOSP)
c
C     Computes the incomplete LU factorization of the matrix B,
C     where B is NP1 x NP1.  B is assumed to be stored in the general
C     sparse row scheme.
C
C     The method used is that found in TR 89-41, Department of Computer
C     Science, VPI&SU, Blacksburg, VA, 1989: 'Preconditioned
C     conjugate gradient algorithms for homotopy curve tracking',
C     page 10.
C---------------------------------------------------------------------
C
C     Input variables:
C       B       matrix to be factored.
C       ROWPOSP  indices of row-starts within B.
C       COLPOSP  column indices for matrix B stored in the general
C                sparse row scheme.
C       LENB    number of entries in B.
C       NP1     the dimension of B.
C
C     Output variables:
C       B       the ILU factors of input matrix B.
C-------------------------------------------------------------
C
      USE REAL_PRECISION
      INTEGER, INTENT(IN):: LENB, NP1, ROWPOSP(NP1+1), COLPOSP(LENB)
      REAL (KIND=R8), INTENT(IN OUT):: B(LENB)
C
C LOCAL VARIABLES
      REAL (KIND=R8):: SIJ, LIT, LII
      INTEGER:: I, J, COUNT, ISTRT, IFIN, TMAX, K, T, M
C
C
      DO I = 1, NP1
         ISTRT = ROWPOSP(I)
         IFIN  = ROWPOSP(I+1) - 1
C---------------------------------------  FOR EACH ELEMENT IN ROW I,
C                                         COMPUTE THE COLUMN NUMBER
C                                         AND T.
         DO COUNT = ISTRT, IFIN
            J = COLPOSP(COUNT)
            TMAX = MIN0(I,J) - 1
            SIJ = B(COUNT)
C---------------------------------------  COMPUTE THE CORRESPONDING
C                                         SUM OF PRODUCTS OF ELEMENTS
C                                         OF L AND U.
            K = ISTRT
 42         T = COLPOSP(K)
            IF (T .LE. TMAX) THEN
              LIT = B(K)
              M = ROWPOSP(T)
C---------------------------------------  FIND VALUE OF U_{TJ}.
 20           IF (COLPOSP(M) .LT. J) THEN
                 M = M + 1
                 GOTO 20
              ENDIF
              IF (COLPOSP(M) .EQ. J) SIJ = SIJ - LIT*B(M)
              K = K + 1
              GOTO 42
           ENDIF
C---------------------------------------  END OF 'T' LOOP.
           K = ISTRT
C---------------------------------------  FIND VALUE OF L_{II}.
 30        IF (COLPOSP(K) .LT. I) THEN
              K = K+1
              GOTO 30
           ENDIF
           IF (COLPOSP(K) .EQ. I) THEN
              LII = B(K)
              IF (DABS(LII) .EQ. 0.0) THEN
                 LII = 0.00001
                 B(K) = 0.00001
              ENDIF
           ELSE
              LII = 0.00001
           ENDIF
C---------------------------------------  UPDATE L OR U, AS NEEDED.
           IF (I .GE. J) THEN
              B(COUNT) = SIJ
           ELSE
              B(COUNT) = SIJ/LII
           ENDIF
        END DO
C---------------------------------------  END OF 'COUNT' LOOP.
      END DO
C
      RETURN
      END SUBROUTINE ILUFDS
      SUBROUTINE ILUSOLVDS(NN, Q, LENQ, ROWPOSP, COLPOSP, B)
C
C     Computes Q^{-1}*B -- returns result as B.
C---------------------------------------------------------------------
C
C     Input variables:
C
C       Q        triangular factors of preconditioning matrix, stored
C                in the general sparse row scheme.
C       ROWPOSP  indices of row-starts within B.
C       COLPOSP  column indices for matrix B stored in the general
C                sparse row scheme.
C       NN       logical row dimension of Q.
C       LENQ     number of data entries in Q.
C       B        right hand side -- should have dimension NN.
C
C     Output variables:
C
C       B        solution of Qx = B.
C
C---------------------------------------------------------------------
C
      USE REAL_PRECISION
      INTEGER, INTENT(IN) ::  NN, LENQ, ROWPOSP(NN+1), COLPOSP(LENQ)
      REAL (KIND=R8), INTENT(IN) :: Q(LENQ) 
      REAL (KIND=R8), INTENT(IN OUT) :: B(NN)
C 
C LOCAL VARIABLES
      INTEGER:: DIAG(NN), I, K, J
C------------------------------------------------ COMPUTE B = INV(L)*B
      B(1) = B(1)/Q(1)
      DIAG(1) = 1
      DO  I = 2, NN
        K = ROWPOSP(I)
 42     J = COLPOSP(K)
        IF (J .LT. I) THEN
          B(I) = B(I) - Q(K)*B(J)
          K = K + 1
          GOTO 42
        ELSE 
          DIAG(I) = K
          B(I) = B(I)/Q(K)
        ENDIF
      END DO
C------------------------------------------------ COMPUTE B = INV(U)*B
      DO  I = NN-1, 1, -1
        DO  K = DIAG(I)+1, ROWPOSP(I+1)-1
          B(I) = B(I) - Q(K)*B(COLPOSP(K))
        END DO
      END DO
      RETURN
      END SUBROUTINE ILUSOLVDS
      SUBROUTINE INITP(IFLG1,N,NUMT,KDEG,COEF,
     &                              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/OR 
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
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
      USE HOMOTOPY
      USE REAL_PRECISION
C DECLARATIONS OF INPUT AND OUTPUT:
      INTEGER, INTENT(IN):: IFLG1,N,NUMT(:)
      INTEGER, INTENT(IN OUT):: KDEG(:,:,:)
      REAL (KIND=R8), INTENT(IN OUT):: COEF(:,:)
      INTEGER, INTENT(OUT):: IDEG(N)
      REAL (KIND=R8), INTENT(OUT):: 
     &  FACV(N),CL(2,N+1),PDG(2,N),QDG(2,N),R(2,N)
C
C DECLARATIONS OF LOCAL VARIABLES:
      INTEGER:: IERR,J,JJ,MAXT,N2,NP1
      REAL (KIND=R8):: CCL(2,11),P(2,10),Q(2,10),ZERO
C
      INTERFACE
        SUBROUTINE DIVP(XXXX,YYYY,ZZZZ,IERR)
        USE REAL_PRECISION
        REAL (KIND=R8), DIMENSION(2), INTENT(IN):: XXXX,YYYY
        INTEGER, INTENT(OUT):: IERR
        REAL (KIND=R8), DIMENSION(2), INTENT(OUT):: ZZZZ
        END SUBROUTINE DIVP
        SUBROUTINE MULP(XXXX,YYYY,ZZZZ)
        USE REAL_PRECISION
        REAL (KIND=R8), DIMENSION(2), INTENT(IN):: XXXX,YYYY
        REAL (KIND=R8), DIMENSION(2), INTENT(OUT):: ZZZZ
        END SUBROUTINE MULP
        SUBROUTINE POWP(NNNN,XXXX,YYYY)
        USE REAL_PRECISION
        INTEGER, INTENT(IN):: NNNN
        REAL (KIND=R8), DIMENSION(2), INTENT(IN):: XXXX
        REAL (KIND=R8), DIMENSION(2), INTENT(IN OUT):: YYYY
        END SUBROUTINE POWP
        SUBROUTINE SCLGNP(N,MAXT,NUMT,DEG,MODE,EPS0,COEF,
     &    NNUMT,DDEG,CCOEF,ALPHA,BETA,RWORK,XWORK,
     &    FACV,FACE,COESCL,IERR)
        USE REAL_PRECISION
        INTEGER, INTENT(IN):: N,MAXT,NUMT(:),DEG(:,:,:),MODE
        REAL (KIND=R8), INTENT(IN):: EPS0,COEF(:,:)
        INTEGER, INTENT(IN OUT):: NNUMT(N),DDEG(N,N+1,MAXT)
        REAL (KIND=R8), INTENT(IN OUT):: CCOEF(N,MAXT),ALPHA(2*N,2*N),
     &    BETA(2*N),RWORK(N*(2*N+1)),XWORK(2*N)
        REAL (KIND=R8), INTENT(OUT):: FACV(N),FACE(N),COESCL(N,MAXT)
        INTEGER, INTENT(OUT):: IERR
        END SUBROUTINE SCLGNP
      END INTERFACE
C
      MAXT = MAXVAL(NUMT)
      N2 =2*N
      NP1=N+1
      ZERO=0.0
      DO J=1,N
        IDEG(J)=MAXVAL(SUM(KDEG(J,1:N,1:NUMT(J)),DIM=1))
      END DO
      DO J=1,N
        KDEG(J,NP1,1:NUMT(J))=IDEG(J)-SUM(KDEG(J,1:N,1:NUMT(J)),DIM=1)
      END DO
      IF ( IFLG1 .EQ. 10  .OR.  IFLG1 .EQ. 00) THEN
C
C       DON'T SCALE THE COEFFICIENTS.  SET  FACV  EQUAL TO NOMINAL 
C       VALUES.
C
        FACV = 0.0
      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*MAXT        1
C    2   ALPHA       4*N**2        1+N*MAXT
C    3   BETA        2*N           1+N*MAXT+4*N**2
C    4   RWORK       N*(2*N+1)     1+N*MAXT+4*N**2+2*N
C    5   XWORK       2*N           1+N*MAXT+4*N**2+2*N+N*(2*N+1)
C    6   FACE        N             1+N*MAXT+4*N**2+4*N+N*(2*N+1)
C    7   COESCL      N*MAXT        1+N*MAXT+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)*MAXT      1+N
C
C*****************************************************************
C
        CALL SCLGNP(N,MAXT,NUMT,KDEG,0,ZERO,COEF,
     &    IPAR(1:N),
     &    IPAR(1+N:N+N*(N+1)*MAXT),
     &    PAR(1:N*MAXT),
     &    PAR(1+N*MAXT:N*MAXT+4*N**2),
     &    PAR(1+N*MAXT+4*N**2:N*MAXT+4*N**2+2*N),
     &    PAR(1+N*MAXT+4*N**2+2*N:N*MAXT+4*N**2+2*N+N*(2*N+1)),
     &    PAR(1+N*MAXT+4*N**2+2*N+N*(2*N+1):
     &        N*MAXT+4*N**2+4*N+N*(2*N+1)),
     &    FACV,
     &    PAR(1+N*MAXT+4*N**2+4*N+N*(2*N+1):
     &        N*MAXT+4*N**2+5*N+N*(2*N+1)),
     &    PAR(1+N*MAXT+4*N**2+5*N+N*(2*N+1):
     &        2*N*MAXT+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
          COEF(:,1:MAXT) = RESHAPE(PAR(1+N*MAXT+4*N**2+5*N+N*(2*N+1):
     &      2*N*MAXT+4*N**2+5*N+N*(2*N+1)), (/N,MAXT/) )
        END IF
      END IF
C
      P(1, 1)= .12324754231_R8
          P(2, 1)= .76253746298_R8
      P(1, 2)= .93857838950_R8
          P(2, 2)=-.99375892810_R8
      P(1, 3)=-.23467908356_R8
          P(2, 3)= .39383930009_R8
      P(1, 4)= .83542556622_R8
          P(2, 4)=-.10192888288_R8
      P(1, 5)=-.55763522521_R8
          P(2, 5)=-.83729899911_R8
      P(1, 6)=-.78348738738_R8
          P(2, 6)=-.10578234903_R8
      P(1, 7)= .03938347346_R8
          P(2, 7)= .04825184716_R8
      P(1, 8)=-.43428734331_R8
          P(2, 8)= .93836289418_R8
      P(1, 9)=-.99383729993_R8
          P(2, 9)=-.40947822291_R8
      P(1,10)= .09383736736_R8
          P(2,10)= .26459172298_R8
C
      Q(1, 1)= .58720452864_R8
          Q(2, 1)= .01321964722_R8
      Q(1, 2)= .97884134700_R8
          Q(2, 2)=-.14433009712_R8
      Q(1, 3)= .39383737289_R8
          Q(2, 3)= .41543223411_R8
      Q(1, 4)=-.03938376373_R8
          Q(2, 4)=-.61253112318_R8
      Q(1, 5)= .39383737388_R8
          Q(2, 5)=-.26454678861_R8
      Q(1, 6)=-.00938376766_R8
          Q(2, 6)= .34447867861_R8
      Q(1, 7)=-.04837366632_R8
          Q(2, 7)= .48252736790_R8
      Q(1, 8)= .93725237347_R8
          Q(2, 8)=-.54356527623_R8
      Q(1, 9)= .39373957747_R8
          Q(2, 9)= .65573434564_R8
      Q(1,10)=-.39380038371_R8
          Q(2,10)= .98903450052_R8
C
      CCL(1, 1)=-.03485644332_R8
          CCL(2, 1)= .28554634336_R8
      CCL(1, 2)= .91453454766_R8
          CCL(2, 2)= .35354566613_R8
      CCL(1, 3)=-.36568737635_R8
          CCL(2, 3)= .45634642477_R8
      CCL(1, 4)=-.89089767544_R8
          CCL(2, 4)= .34524523544_R8
      CCL(1, 5)= .13523462465_R8
          CCL(2, 5)= .43534535555_R8
      CCL(1, 6)=-.34523544445_R8
          CCL(2, 6)= .00734522256_R8
      CCL(1, 7)=-.80004678763_R8
          CCL(2, 7)=-.009387123644_R8
      CCL(1, 8)=-.875432124245_R8
          CCL(2, 8)= .00045687651_R8
      CCL(1, 9)= .65256352333_R8
          CCL(2, 9)=-.12356777452_R8
      CCL(1,10)= .09986798321548_R8
          CCL(2,10)=-.56753456577_R8
      CCL(1,11)= .29674947394739_R8
          CCL(2,11)= .93274302173_R8
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 
        CL(1:2,1:N)=0.0
        CL(1,NP1)=1.0
        CL(2,NP1)=0.0
      ELSE
        DO J=1,NP1
          JJ=MOD(J-1,11)+1
          CL(1:2,J)=CCL(1:2,JJ)
        END DO
      END IF
C
C COMPUTE POWERS OF P AND Q, AND R=Q/P
      DO 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)
      END DO
      RETURN
      END SUBROUTINE INITP
      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
      USE REAL_PRECISION
      REAL (KIND=R8), DIMENSION(2), INTENT(IN):: XXXX,YYYY
C
C DECLARATION OF OUTPUT
      REAL (KIND=R8), DIMENSION(2), INTENT(OUT):: ZZZZ
C
      ZZZZ(1) = XXXX(1)*YYYY(1) - XXXX(2)*YYYY(2)
      ZZZZ(2) = XXXX(1)*YYYY(2) + XXXX(2)*YYYY(1)
      RETURN
      END SUBROUTINE MULP
      SUBROUTINE MULT2DS(Y, B, X, ROWPOS, COLPOS, N, LENB)
C
C     Returns B*X as Y.
C---------------------------------------------------------------------
C
C     Input variables:
C
C       B       matrix stored in the sparse row scheme.
C       ROWPOSP  indices of row-starts within B.
C       COLPOSP  column indices for matrix B stored in the general
C                sparse row scheme.
C       N       logical row dimension of B
C       LENB    number of data entries in B.
C       X       source vector -- should be compatible with B.
C       Y       target vector -- should have dimension N.
C
C     Output variables:
C
C       Y       value of B*X.
C
C---------------------------------------------------------------------
C
      USE REAL_PRECISION
      INTEGER, INTENT (IN):: LENB, N, ROWPOS(N+1), COLPOS(LENB)
      REAL (KIND=R8), INTENT(IN):: X(:), B(LENB)
      REAL (KIND=R8), INTENT (OUT) :: Y(N)
C
C LOCAL VARIABLES.
C
      INTEGER:: I, FIN, STRT, K
      REAL (KIND=R8):: TMP
C
        DO I = 1, N
         STRT = ROWPOS(I)
         FIN = ROWPOS(I+1)-1
         TMP = 0.0
         DO K = STRT, FIN
            TMP = TMP + B(K)*X(COLPOS(K))
         END DO 
         Y(I) = TMP
        END DO
      RETURN
      END SUBROUTINE MULT2DS
      SUBROUTINE MULTDS(Y,AA,X,MAXA,NN,LENAA)
C
C     This subroutine accepts a matrix, AA, in packed skyline storage form and
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 in 
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
      USE REAL_PRECISION
      INTEGER, INTENT(IN):: LENAA,NN,MAXA(NN+1)
      REAL (KIND=R8), INTENT(IN):: AA(LENAA),X(NN)
      REAL (KIND=R8), INTENT(OUT):: Y(NN)
      INTEGER:: I,II,KK,KL,KU
      REAL (KIND=R8):: B,CC
      IF (LENAA .LE. NN) THEN
        DO I=1,NN
          Y(I)=AA(I)*X(I)
        END DO
        RETURN
      END IF
      DO I=1,NN
        Y(I)=0.00
      END DO
      DO I=1,NN
        KL=MAXA(I)
        KU=MAXA(I+1)-1
        II=I+1
        CC=X(I)
        DO KK=KL,KU
          II=II-1
          Y(II)=Y(II)+AA(KK)*CC
        END DO
      END DO
      IF (NN .EQ. 1) RETURN
      DO I=2,NN
        KL=MAXA(I)+1
        KU=MAXA(I+1)-1
        IF (KU-KL .LT. 0) CYCLE
        II=I
        B=0.00
        DO KK=KL,KU
          II=II-1
          B=B+AA(KK)*X(II)
        END DO
        Y(I)=Y(I)+B
      END DO
      RETURN
      END SUBROUTINE MULTDS
      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
      USE REAL_PRECISION
C
      INTERFACE
        SUBROUTINE DIVP(XXXX,YYYY,ZZZZ,IERR)
        USE REAL_PRECISION
        REAL (KIND=R8), DIMENSION(2), INTENT(IN):: XXXX,YYYY
        INTEGER, INTENT(OUT):: IERR
        REAL (KIND=R8), DIMENSION(2), INTENT(OUT):: ZZZZ
        END SUBROUTINE DIVP
        SUBROUTINE MULP(XXXX,YYYY,ZZZZ)
        USE REAL_PRECISION
        REAL (KIND=R8), DIMENSION(2), INTENT(IN):: XXXX,YYYY
        REAL (KIND=R8), DIMENSION(2), INTENT(OUT):: ZZZZ
        END SUBROUTINE MULP
        SUBROUTINE POWP(NNNN,XXXX,YYYY)
        USE REAL_PRECISION
        INTEGER, INTENT(IN):: NNNN
        REAL (KIND=R8), DIMENSION(2), INTENT(IN):: XXXX
        REAL (KIND=R8), DIMENSION(2), INTENT(IN OUT):: YYYY
        END SUBROUTINE POWP
      END INTERFACE
C
C DECLARATIONS OF INPUT, WORKSPACE, AND OUTPUT:
      INTEGER, INTENT(IN):: N,NUMPAT
      REAL (KIND=R8), INTENT(IN):: CL(2,N+1),FACV(N)
      REAL (KIND=R8), INTENT(IN OUT):: CLX(2,N),X(2,N),XNP1(2)
C
C DECLARATION OF LOCAL VARIABLES
      INTEGER:: I,IERR,J,NP1 
      REAL (KIND=R8):: FAC,TEMP(2)
C
      NP1=N+1
C COMPUTE XNP1
      DO J=1,N
        CALL MULP(CL(1,J),X(1,J),CLX(1,J))
      END DO
      XNP1 = CL(:,NP1) + SUM(CLX,DIM=2)
C UNTRANSFORM VARIABLES
      DO J=1,N
        CALL DIVP(X(1,J),XNP1,TEMP,IERR)
        X(1,J)=TEMP(1)
        X(2,J)=TEMP(2)
      END DO
C UNSCALE VARIABLES
      TEMP(1) = HUGE(1.0_R8)
      DO J=1,N
        FAC=10.**FACV(J)
        DO I=1,2
          IF( (ABS(X(I,J))/TEMP(1))*FAC .LT. 1.0 ) X(I,J)=FAC*X(I,J)
        END DO
      END DO
      RETURN
      END SUBROUTINE OTPUTP
      SUBROUTINE PCGDS(NN,LENAA,IFLAG,START,RHS)
C
C     PCGDS computes a tangent vector or normal flow correction using
C     a preconditioned conjugate gradient method (adaptive GMRES(k)).
C
C     The system to be solved is in the form Bx=b, where
C
C        +--          --+        +-   -+    +-    -+
C        |        |     |        |  0  |    |      | 
C        |   AA   | -PP |        | ... |    | -RHS |
C    B = |        |     | ,  b = |  0  | or |      |, 
C        +--------+-----+        +-----+    +------+ 
C        |    E(k)**t   |        |  T  |    |  T   | 
C        +--          --+        +-   -+    +-    -+
C
C        T = START(k), where |START(k)|=     max    |START(i)|.
C                                        1<=i<=NN+1
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 |                                |  d'   |
C       +-        -+                                +-     -+
C
C   d = 1 and d' = 0 if k = NN+1, otherwise d = -d' = 1 + 1/M(k,k).
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 GMRES algorithm.
C
C  Input variables:
C
C        NN -- dimension of the matrix packed in AA.
C
C        LENAA -- number of elements in the packed array AA.
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        RHS -- optional vector of length NN, used to define right hand
C               side for normal flow correction calculation.  It is
C               assumed that PCGDS is called without RHS present before
C               it is called with RHS present.  A Gill-Murray LL^t
C               factorization based preconditioner is computed only when
C               RHS is not present.
C
C  Input variables defined in module HOMOTOPY:
C
C        AA -- one dimensional real array containing the leading NN x NN
C              submatrix of B in packed skyline storage form.
C
C        ROWPOS -- 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                  ROWPOS(NN+1) = LENAA + 1 and ROWPOS(NN+2) = 
C                  LENAA + NN + 3 - k (k as defined above) by convention.
C                  (NOTE:  The value of ROWPOS(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, ROWPOS=(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  Output variables:
C
C        START -- solution vector x of  B x = b  (defined above).
C
C        IFLAG -- normally unchanged on output.  If the GMRES
C                 iteration fails to converge in 10*(NN+1) iterations (most
C                 likely due to a singular Jacobian matrix), PCGDS returns
C                 with  IFLAG = 4 , and does not compute x.
C
C    Calls subroutines GMFADS and GMRES.
C
      USE HOMOTOPY, AA => QRSPARSE, WORK => PAR
      USE REAL_PRECISION
      INTEGER, INTENT(IN):: LENAA, NN
      INTEGER, INTENT(IN OUT):: IFLAG
      REAL (KIND=R8), INTENT(IN OUT):: START(NN+1)
      REAL (KIND=R8), INTENT(IN), OPTIONAL:: RHS(NN)
C
C LOCAL VARIABLES.
C
      INTEGER:: ITMAX, K, KD, NP1, QIND, ZBIND, ZUIND
      REAL (KIND=R8):: STARTK
      REAL (KIND=R8):: RHSC(NN+1)            ! RIGHT-HAND SIDE FOR GMRES.
C
C GMRES PARAMETERS.
C 
      INTEGER, PARAMETER:: SUBSPACE=8        ! KRYLOV SUBSPACE VALUE.
C
      INTERFACE 
        SUBROUTINE GMFADS(NN,A,NWK,MAXA)
          USE REAL_PRECISION
          INTEGER, INTENT(IN):: NN,NWK,MAXA(NN+1)
          REAL (KIND=R8), INTENT(IN OUT):: A(NWK)
        END SUBROUTINE GMFADS
        SUBROUTINE GMRES(N, KDMAX, ITMAX, RHSC, X, KVAL,
     &                Q, IFLAG, ROWPOSP, COLPOSP)
          USE HOMOTOPY
          USE REAL_PRECISION
          INTEGER, INTENT(IN):: KVAL, N
          INTEGER, INTENT(IN OUT):: IFLAG, ITMAX, KDMAX
          REAL (KIND=R8), INTENT(IN):: Q(:), RHSC(N)
          REAL (KIND=R8), INTENT(IN OUT):: X(N)
          INTEGER, INTENT(IN), OPTIONAL:: COLPOSP(:), ROWPOSP(:)
        END SUBROUTINE GMRES
      END INTERFACE
C    
      NP1 = NN+1
C
C     INITIALIZE START POSITIONS WITHIN WORK.
C
      ZBIND = 1
      ZUIND = NP1+1
      QIND = 2*NP1+1
C
      IF (.NOT. ALLOCATED(WORK)) THEN
        ALLOCATE(WORK(2*NP1+LENAA+NN+1))
        WORK(1:2*NP1) = 0.0
      END IF
C
C     FIND THE ELEMENT OF LARGEST MAGNITUDE IN THE INITIAL VECTOR, AND
C     RECORD ITS POSITION IN K.
C 
      K = MAXVAL(MAXLOC(ABS(START)))
      STARTK = START(K)
C
C     SET VALUES OF ROWPOS(NN+1) AND ROWPOS(NN+2), AND
C     COMPUTE THE PRECONDITIONER Q FOR M.
C
      IF (.NOT. PRESENT(RHS)) THEN
        WORK(QIND:QIND+LENAA-1) = AA(1:LENAA)
        ROWPOS(NP1) = LENAA+1
        ROWPOS(NN+2) = LENAA+NN+3-K
        WORK(QIND+LENAA+NN+1-K) = 1.0
        IF (K .LT. NP1) THEN
          WORK(QIND+LENAA) = 1.0 + 1.0/ABS(AA(ROWPOS(K)))
          WORK(QIND+LENAA+1:QIND+LENAA+NN-K) = 0.0
        END IF
        CALL GMFADS(NP1, WORK(QIND:QIND+LENAA+NP1-K),
     &            ROWPOS(NN+2)-1, ROWPOS(1:NN+2))
      END IF
C
C     COMPUTE RIGHT HAND SIDE FOR MZ=B.
C
      RHSC(NP1) = STARTK
      IF (PRESENT(RHS))  THEN
        RHSC(1:NN) = -RHS
      ELSE
        RHSC(1:NN) = 0.0
      END IF
C
C CALL TO GMRES (MZ=B SYSTEM). 
C
      ITMAX = 30*NP1
      KD = SUBSPACE          
      CALL GMRES(NP1, KD, ITMAX, RHSC, WORK(ZBIND:ZBIND+NN),  
     &           K, WORK(QIND:QIND+LENAA+NP1-K), IFLAG) 
      IF ( IFLAG .GT. 0) RETURN
C
C COMPUTE RIGHT HAND SIDE FOR  MZ=U.
C
      RHSC(1:NN) = -PP(1:NN)
      IF (K .LT. NP1) THEN 
        RHSC(K) = RHSC(K)-1.0
        RHSC(NP1) = -(1.0+1.0/ABS(AA(ROWPOS(K))))
      ELSE
        RHSC(NP1) = 0.0
      END IF
C
C CALL TO GMRES (MZ=U SYSTEM).      
C
      ITMAX = 30*NP1-ITMAX
      KD = SUBSPACE
      CALL GMRES(NP1, KD, ITMAX, RHSC, WORK(ZUIND:ZUIND+NN),  
     &           K, WORK(QIND:QIND+LENAA+NP1-K), IFLAG) 
      IF ( IFLAG .GT. 0) RETURN
C
C COMPUTE THE FINAL SOLUTION BY SHERMAN-MORRISON FORMULA.
C
      STARTK = -WORK(ZBIND+NN)/(1.0+WORK(ZUIND+NN))
      START(1:NP1) = WORK(ZBIND:ZBIND+NN) + STARTK*WORK(ZUIND:ZUIND+NN)
      RETURN
      END SUBROUTINE PCGDS
      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
      USE REAL_PRECISION
      INTEGER, INTENT(IN):: NNNN
      REAL (KIND=R8), DIMENSION(2), INTENT(IN):: XXXX
C
C DECLARATION OF OUTPUT
      REAL (KIND=R8), DIMENSION(2), INTENT(IN OUT):: YYYY
C
C DECLARATION OF VARIABLES
      REAL (KIND=R8):: R,RR,T,TT
C
C DECLARATION OF FUNCTIONS
      REAL (KIND=R8)::  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 POWP
      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
      USE REAL_PRECISION
      REAL (KIND=R8):: A,ABSERR,ACBS,ACMB,AE,B,C,CMB,FA,FB,
     &  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=EPSILON(1.0_R8)
      RE=MAX(RELERR,U)
      AE=MAX(ABSERR,0.0_R8)
      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.0_R8,FB).NE.SIGN(1.0_R8,FC))GO TO 1
      C=A
      FC=FA
      GO TO 1
C
C FINISHED.  SET IFLAG.
C
    8 IF(SIGN(1.0_R8,FB).EQ.SIGN(1.0_R8,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 ROOT
      SUBROUTINE ROOTNF(N,NFE,IFLAG,RELERR,ABSERR,Y,YP,YOLD,
     &   YPOLD,A,QR,ALPHA,TZ,PIVOT,W,WP)
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 SECANT ESTIMATES OF  YBAR  AND NEWTON ITERATION UNTIL
C CONVERGENCE.
C
C THE FOLLOWING INTERFACE BLOCK SHOULD BE INCLUDED IN THE CALLING
C PROGRAM:
C
C     INTERFACE
C       SUBROUTINE ROOTNF(N,NFE,IFLAG,RELERR,ABSERR,Y,YP,YOLD,
C    &    YPOLD,A,QR,ALPHA,TZ,PIVOT,W,WP)
C       USE REAL_PRECISION
C       REAL (KIND=R8):: ABSERR,RELERR
C       INTEGER:: IFLAG,N,NFE
C       REAL (KIND=R8):: A(:),ALPHA(3*N+3),QR(N,N+2),TZ(N+1),W(N+1),
C    &    WP(N+1),Y(:),YOLD(N+1),YP(N+1),YPOLD(N+1)
C       INTEGER:: PIVOT(N+1)
C       END SUBROUTINE ROOTNF
C     END INTERFACE
C
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(:) = PARAMETER VECTOR IN THE HOMOTOPY MAP.
C
C QR(1:N,1:N+2), ALPHA(1:3*N+3), 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
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  DNRM2 , ROOT , TANGNF .
C
      USE REAL_PRECISION
      REAL (KIND=R8):: ABSERR,AERR,
     &   DD001,DD0011,DD01,DD011,DELS,F0,F1,FP0,FP1,
     &   QOFS,QSOUT,RELERR,RERR,S,SA,SB,SOUT,U
      INTEGER:: IFLAG,JUDY,JW,LCODE,LIMIT,N,NFE,NP1
      LOGICAL:: BRACK
C
C ***** ARRAY DECLARATIONS. *****
C
      REAL (KIND=R8):: A(:),ALPHA(3*N+3),QR(N,N+2),TZ(N+1),W(N+1),
     &   WP(N+1),Y(:),YOLD(N+1),YP(N+1),YPOLD(N+1)
      INTEGER:: PIVOT(N+1)
C
C ***** END OF DIMENSIONAL INFORMATION. *****
C
      INTERFACE
        FUNCTION DNRM2(N,X,STRIDE)
        USE REAL_PRECISION
        INTEGER:: N,STRIDE
        REAL (KIND=R8):: DNRM2,X(N)
        END FUNCTION DNRM2
        SUBROUTINE TANGNF(RHOLEN,Y,YP,YPOLD,A,QR,ALPHA,TZ,PIVOT,
     &    NFE,N,IFLAG)
        USE REAL_PRECISION
        REAL (KIND=R8):: RHOLEN
        INTEGER:: IFLAG,N,NFE
        REAL (KIND=R8):: A(:),Y(:),YP(N+1),YPOLD(N+1)
        REAL (KIND=R8):: ALPHA(3*N+3),QR(N,N+2),TZ(N+1)
        INTEGER:: PIVOT(N+1)
        END SUBROUTINE TANGNF
      END INTERFACE
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=EPSILON(1.0_R8)
      RERR=MAX(RELERR,U)
      AERR=MAX(ABSERR,0.0_R8)
      NP1=N+1
C
C THE LIMIT ON THE NUMBER OF ITERATIONS ALLOWED MAY BE CHANGED BY
C CHANGING THE FOLLOWING PARAMETER STATEMENT:
      LIMIT=2*(INT(ABS(LOG10(AERR+RERR)))+1)
C
      TZ=Y - YOLD
      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 JW=1,NP1
        W(JW)=QOFS(YOLD(JW),YPOLD(JW),Y(JW),YP(JW),DELS,SA)
      END DO
C
C ***** END OF CALCULATION OF CUBIC INTERPOLANT. *****
C
C TANGENT INFORMATION  YP  IS NO LONGER NEEDED.  HEREAFTER,  YP
C REPRESENTS THE MOST RECENT POINT WHICH IS ON THE OPPOSITE SIDE OF
C THE HYPERPLANE  LAMBDA = 1 FROM  Y.
C
C    PREPARE FOR MAIN LOOP.
C
      YP=YOLD
C
C INITIALIZE  BRACK  TO INDICATE THAT THE POINTS  Y  AND  YOLD  BRACKET
C LAMBDA = 1,  THUS  YOLD = YP .
C
      BRACK = .TRUE.
C
C ***** MAIN LOOP. *****
      DO JUDY = 1,LIMIT
C CALCULATE NEWTON STEP AT CURRENT ESTIMATE  W .
      CALL TANGNF(SA,W,WP,YPOLD,A,QR,ALPHA,TZ,PIVOT,NFE,N,IFLAG)
      IF (IFLAG .GT. 0) RETURN
C
C NEXT POINT = CURRENT POINT + NEWTON STEP.
C
      W = W + TZ
C
C CHECK FOR CONVERGENCE.
C
      IF ((ABS(W(1)-1.0) .LE. RERR+AERR) .AND.
     &    (DNRM2(NP1,TZ,1) .LE. RERR*DNRM2(N,W(2:NP1),1)+AERR)) THEN
        Y = W
        RETURN
      ENDIF
C
C PREPARE FOR NEXT ITERATION.
C
      IF (ABS(W(1)-1.0) .LE. RERR+AERR) THEN
         YPOLD=WP
         CYCLE
      ENDIF
C
C    UPDATE  Y  AND  YOLD .
C
      YOLD=Y
      Y=W
C
C    UPDATE  YP  SUCH THAT  YP  IS THE MOST RECENT POINT
C    OPPOSITE OF  LAMBDA = 1  FROM  Y .  SET  BRACK = .TRUE.  IFF
C    Y  AND  YOLD  BRACKET  LAMBDA = 1  SO THAT  YP = YOLD .
C
          IF ((Y(1)-1.0)*(YOLD(1)-1.0) .GT. 0) THEN
            BRACK = .FALSE.
          ELSE
            BRACK = .TRUE.
            YP=YOLD
          END IF
C
C    COMPUTE  DELS = ||Y-YP||.
C
          TZ=Y - YP
          DELS=DNRM2(NP1,TZ,1)
C
C       COMPUTE  TZ  FOR THE LINEAR PREDICTOR   W = Y + TZ,
C           WHERE  TZ = SA*(YOLD-Y).
C
          SA = (1.0-Y(1))/(YOLD(1)-Y(1))
          TZ = SA*(YOLD - Y)
C
C       TO INSURE STABILITY, THE LINEAR PREDICTION MUST BE NO FARTHER
C       FROM  Y  THAN  YP  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,TZ,1) .GT. DELS) THEN
C
C             COMPUTE  TZ = SA*(YP-Y).
C
              SA = (1.0-Y(1))/(YP(1)-Y(1))
              TZ = SA*(YP - Y)
            END IF
          END IF
C
C       COMPUTE ESTIMATE  W = Y + TZ  AND SAVE OLD TANGENT VECTOR.
C
           W = W + TZ
           YPOLD = WP
       END DO
C
C ***** END OF MAIN LOOP. *****
C
C THE ALTERNATING SECANT ESTIMATION AND NEWTON ITERATION
C HAS NOT CONVERGED IN  LIMIT  STEPS.  ERROR RETURN.
      IFLAG=6
      RETURN
      END SUBROUTINE ROOTNF
      SUBROUTINE ROOTNS(N,NFE,IFLAG,RELERR,ABSERR,Y,YP,YOLD,YPOLD,
     &   A,MODE,LENQR)
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 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 THE FOLLOWING INTERFACE BLOCK SHOULD BE INCLUDED IN THE CALLING
C PROGRAM:
C
C     INTERFACE
C       SUBROUTINE ROOTNS(NC,NFEC,IFLAGC,ANSRE,ANSAE,Y,YP,YOLD,YPOLD,
C    &     A,MODE,LENQR)
C       USE REAL_PRECISION
C       INTEGER, INTENT(IN):: LENQR,MODE,NC
C       INTEGER, INTENT(IN OUT):: IFLAGC,NFEC
C       REAL (KIND=R8), INTENT(IN):: A(:)
C       REAL (KIND=R8), INTENT(IN):: ANSAE,ANSRE
C       REAL (KIND=R8), DIMENSION(:), INTENT(IN OUT):: Y,YOLD,YP,YPOLD
C       END SUBROUTINE ROOTNS
C     END INTERFACE
C
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(:) = PARAMETER VECTOR IN THE HOMOTOPY MAP.
C
C MODE = 1 IF THE JACOBIAN MATRIX IS SYMMETRIC AND STORED IN A PACKED
C          SKYLINE FORMAT;
C      = 2 IF THE JACOBIAN MATRIX IS STORED IN A SPARSE ROW FORMAT.
C
C LENQR  IS THE NUMBER OF NONZERO ENTRIES IN THE SPARSE JACOBIAN
C    MATRICES, USED TO DETERMINE THE SPARSE MATRIX DATA STRUCTURES.
C
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  DNRM2 , ROOT , TANGNS .
C
      USE REAL_PRECISION
      INTEGER, INTENT(IN):: LENQR,MODE,N
      INTEGER, INTENT(IN OUT):: IFLAG,NFE
      REAL (KIND=R8), INTENT(IN):: A(:)
      REAL (KIND=R8), INTENT(IN):: ABSERR,RELERR
      REAL (KIND=R8), DIMENSION(:), INTENT(IN OUT):: Y,YOLD,YP,YPOLD
C
C ***** LOCAL VARIABLES. *****
C
      REAL (KIND=R8):: AERR,DD001,DD0011,DD01,DD011,DELS,
     &   F0,F1,FP0,FP1,QOFS,QSOUT,RERR,S,SA,SB,SOUT,U
      INTEGER:: JUDY,JW,LCODE,NP1
      LOGICAL:: BRACK
      INTERFACE
        FUNCTION DNRM2(N,X,STRIDE)
        USE REAL_PRECISION
        INTEGER:: N,STRIDE
        REAL (KIND=R8):: DNRM2,X(N)
        END FUNCTION DNRM2
      END INTERFACE
C
C ***** AUTOMATIC WORK ARRAYS. *****
C
      REAL (KIND=R8):: TZ(N+1),W(N+1),WP(N+1)
C
C THE LIMIT ON THE NUMBER OF ITERATIONS ALLOWED MAY BE CHANGED BY
C CHANGING THE FOLLOWING PARAMETER STATEMENT:
      INTEGER, PARAMETER:: LIMIT=20
C
      INTERFACE
        SUBROUTINE TANGNS(RHOLEN,Y,YP,TZ,YPOLD,A,MODE,LENQR,
     &    NFE,N,IFLAG)
        USE REAL_PRECISION
        REAL (KIND=R8), INTENT(IN), DIMENSION(:):: A,Y,YPOLD
        REAL (KIND=R8), INTENT(IN OUT):: RHOLEN
        REAL (KIND=R8), INTENT(OUT), DIMENSION(:):: TZ,YP
        INTEGER, INTENT(IN):: LENQR,MODE,N
        INTEGER, INTENT(IN OUT):: IFLAG,NFE
        END SUBROUTINE TANGNS
      END INTERFACE
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 ***** END OF SPECIFICATION INFORMATION. *****
C
      U=EPSILON(1.0_R8)
      RERR=MAX(RELERR,U)
      AERR=MAX(ABSERR,0.0_R8)
      NP1=N+1
      TZ=Y - YOLD
      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(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 JW=1,NP1
        W(JW)=QOFS(YOLD(JW),YPOLD(JW),Y(JW),YP(JW),DELS,SA)
      END DO
C
C ***** END OF CALCULATION OF CUBIC INTERPOLANT. *****
C
C TANGENT INFORMATION  YP  IS NO LONGER NEEDED.  HEREAFTER,  YP
C REPRESENTS THE MOST RECENT POINT WHICH IS ON THE OPPOSITE SIDE OF
C THE HYPERPLANE  LAMBDA = 1 FROM  Y.
C
C    PREPARE FOR MAIN LOOP.
C
      YP=YOLD
C
C INITIALIZE  BRACK  TO INDICATE THAT THE POINTS  Y  AND  YOLD  BRACKET
C LAMBDA = 1,  THUS  YOLD = YP .
C
      BRACK = .TRUE.
C
      DO JUDY = 1,LIMIT         ! ***** MAIN LOOP. *****
C CALCULATE NEWTON STEP AT CURRENT ESTIMATE  W .
      SA = -1.0
      CALL TANGNS(SA,W,WP,TZ,YPOLD,A,MODE,LENQR,NFE,N,IFLAG)
      IF (IFLAG .GT. 0) RETURN
C
C NEXT POINT = CURRENT POINT + NEWTON STEP.
C
      W = W + TZ
C
C CHECK FOR CONVERGENCE.
C
      IF ((ABS(W(NP1)-1.0) .LE. RERR+AERR) .AND.
     &    (DNRM2(NP1,TZ,1) .LE. RERR*DNRM2(N,W(1:N),1)+AERR)) THEN
        Y = W
        RETURN
      ENDIF
C
C PREPARE FOR NEXT ITERATION.
C
      IF (ABS(W(NP1)-1.0) .LE. RERR+AERR) THEN
         YPOLD=WP
         CYCLE
      ENDIF
C
C    UPDATE  Y  AND  YOLD .
C
      YOLD=Y
      Y=W
C
C    UPDATE  YP  SUCH THAT  YP  IS THE MOST RECENT POINT
C    OPPOSITE OF  LAMBDA = 1  FROM  Y .  SET  BRACK = .TRUE.  IFF
C    Y  AND  YOLD  BRACKET  LAMBDA = 1  SO THAT  YP = YOLD .
C
          IF ((Y(NP1)-1.0)*(YOLD(NP1)-1.0) .GT. 0) THEN
            BRACK = .FALSE.
          ELSE
            BRACK = .TRUE.
            YP=YOLD
          END IF
C
C    COMPUTE  DELS = ||Y-YP||.
C
          TZ=Y - YP
          DELS=DNRM2(NP1,TZ,1)
C
C       COMPUTE  TZ  FOR THE LINEAR PREDICTOR   W = Y + TZ,
C           WHERE  TZ = SA*(YOLD-Y).
C
          SA = (1.0-Y(NP1))/(YOLD(NP1)-Y(NP1))
          TZ = SA*(YOLD - Y)
C
C       TO INSURE STABILITY, THE LINEAR PREDICTION MUST BE NO FARTHER
C       FROM  Y  THAN  YP  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,TZ,1) .GT. DELS) THEN
C
C             COMPUTE  TZ = SA*(YP-Y).
C
              SA = (1.0-Y(NP1))/(YP(NP1)-Y(NP1))
              TZ = SA*(YP - Y)
            END IF
          END IF
C
C       COMPUTE ESTIMATE  W = Y + TZ  AND SAVE OLD TANGENT VECTOR.
C
           W = W + TZ
           YPOLD = WP
       END DO          ! ***** END OF MAIN LOOP. *****
C
C THE ALTERNATING SECANT ESTIMATION AND NEWTON ITERATION
C HAS NOT CONVERGED IN  LIMIT  STEPS.  ERROR RETURN.
      IFLAG=6
      RETURN
      END SUBROUTINE ROOTNS
      SUBROUTINE ROOTNX(N,NFE,IFLAG,RELERR,ABSERR,Y,YP,YOLD,
     &   YPOLD,A,GOFW,TZ,W,WP)
C
C  ROOTNX  is an expert user version of ROOTN(F|S), written using the
C reverse call protocol.  All matrix data structures and numerical linear
C algebra are the responsibility of the calling program.  ROOTNX
C indicates to the calling program, via flags, at which points
C RHO(A,LAMBDA,X)  and [ D RHO(A,LAMBDA,X)/D LAMBDA, D RHO(A,LAMBDA,X)/DX ] 
C must be evaluated, and what linear algebra must be done with these
C functions.  ROOTNX  solves the following problem:  given
C YOLD = (LAMBDA(S1),X(S1)), YPOLD = (LAMBDA'(S1),X'(S1)),
C Y = (LAMBDA(S2),X(S2)), YP = (LAMBDA'(S2),X'(S2)), S1 < S2, and a
C continuous function G(Y) = G(LAMBDA,X) such that  G(YOLD) G(Y) <= 0,
C find the point Y(S) = (LAMBDA(S),X(S)), S1 <= S <= S2, such that
C G(Y(S)) = 0.  ROOTNX  alternates between secant estimates of  Y(S)
C and Newton iteration until convergence.
C
C The following interface block should be inserted in the calling
C program:
C
C     INTERFACE
C       SUBROUTINE ROOTNX(N,NFE,IFLAG,RELERR,ABSERR,Y,YP,YOLD,
C    &   YPOLD,A,GOFW,TZ,W,WP)
C       USE HOMOTOPY
C       USE REAL_PRECISION
C       INTEGER, INTENT(IN):: N
C       INTEGER, INTENT(IN OUT):: NFE,IFLAG
C       REAL (KIND=R8), INTENT(IN):: RELERR,ABSERR
C       REAL (KIND=R8), DIMENSION(:), INTENT(IN):: A
C       REAL (KIND=R8), INTENT(IN OUT):: GOFW
C       REAL (KIND=R8), DIMENSION(:), INTENT(IN OUT):: Y,YP,YOLD,YPOLD,
C    &    TZ,W,WP
C       END SUBROUTINE ROOTNX
C     END INTERFACE
C
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, on the first
C         call to  ROOTNX .  ROOTNX  does not distinguish between
C         these values, but they are permitted for consistency with
C         the rest of HOMPACK.
C
C       = 0-10*R, -1-10*R, OR -2-10*R, R = 1,...,5, indicate to  ROOTNX
C         where to resume after a reverse call.  The calling program
C         must not modify  IFLAG  after a reverse call.
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    | G(Y(S)) | <= RELERR*||Y|| + ABSERR       and
C
C    ||Z|| <= RELERR*||Y|| + 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(:) = parameter vector in the homotopy map.
C
C GOFW = G(W), the value requested by some reverse calls.
C
C TZ(1:N+1), W(1:N+1), and WP(1:N+1)  are work arrays used for the
C    Newton step calculation and the interpolation.  On reentry after
C    a reverse call,  WP  and  TZ  contain the tangent vector and
C    Newton step, respectively, at the point  W .  Precisely,
C    D RHO(A,W)/DW WP = 0,  WP^T YPOLD > 0,  ||WP|| = 1,
C    and  TZ  is the minimum norm solution of
C    D RHO(A,W)/DW TZ = - RHO(A,W).
C
C
C ON OUTPUT:
C
C N , RELERR , ABSERR , A  are unchanged.
C
C NFE  has been updated.
C
C IFLAG 
C    = -52, -51, or -50 requests the calling program to
C      return the unit tangent vector in  WP  and the normal flow Newton
C      step in  TZ , all evaluated at the point  W .
C
C    = 0-10*R, -1-10*R, or -2-10*R, R = 1,...,4, requests the calling
C      program to return in  GOFW  the scalar function  G(Y)  evaluated
C      at  W .  The calling program must not modify  IFLAG  after a
C      reverse call.
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.  Y  and  YOLD  contain
C        the last two points found on the zero curve.
C
C    = 7 if input arguments or array sizes are invalid, or  IFLAG  was
C        changed during a reverse call.
C
C Y  is the point on the zero curve of the homotopy map such that
C    G(Y) = 0.
C
C
C Calls  DNRM2 , ROOT .
C
      USE HOMOTOPY
      USE REAL_PRECISION
      INTEGER, INTENT(IN):: N
      INTEGER, INTENT(IN OUT):: NFE,IFLAG
      REAL (KIND=R8), INTENT(IN):: RELERR,ABSERR
      REAL (KIND=R8), DIMENSION(:), INTENT(IN):: A
      REAL (KIND=R8), INTENT(IN OUT):: GOFW
      REAL (KIND=R8), DIMENSION(:), INTENT(IN OUT):: Y,YP,YOLD,YPOLD,
     &    TZ,W,WP
C
C ***** LOCAL VARIABLES. *****
C
      REAL (KIND=R8), SAVE:: AERR,DELS,F0,F1,FP0,FP1,GOFY,
     &  GOFYOLD,GOFYP,RERR,S,SA,SB,SOUT,U
      REAL (KIND=R8):: DD001,DD0011,DD01,DD011,DNRM2,QOFS
      INTEGER, SAVE:: IFLAGC,JUDY,JW,LCODE,LIMIT,NP1
      LOGICAL, SAVE:: BRACK
C
C ***** END OF SPECIFICATION INFORMATION. *****
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
      NP1=N+1
      IF (IFLAG > 0) RETURN
      IF ((MOD(-IFLAG,10) > 2) .OR. SIZE(Y) /= NP1 .OR.
     &  SIZE(YP) /= NP1 .OR. SIZE(YOLD) /= NP1 .OR.
     &  SIZE(YPOLD) /= NP1 .OR. SIZE(TZ) /= NP1 .OR.
     &  SIZE(W) /= NP1 .OR. SIZE(WP) /= NP1 .OR.
     &  (IFLAG < -2 .AND. IFLAG /= IFLAGC)) THEN
        IFLAG=7
        RETURN
      ENDIF
      IFLAGC=-MOD(-IFLAG,10)
C
C PICK UP EXECUTION WEHRE IT LEFT OFF AFTER A REVERSE CALL.
C
      IF (IFLAG < -2) THEN
        GO TO (100,110,130,210,200), ABS(IFLAG)/10
      ENDIF
      U=EPSILON(1.0_R8)
      RERR=MAX(RELERR,U)
      AERR=MAX(ABSERR,0.0_R8)
C
C THE LIMIT ON THE NUMBER OF ITERATIONS ALLOWED MAY BE CHANGED BY
C CHANGING THE FOLLOWING STATEMENT:
      LIMIT=2*(INT(ABS(LOG10(AERR+RERR)))+1)
C
      TZ=Y - YOLD
      DELS=DNRM2(NP1,TZ,1)
C EVALUATE  G  AT  YOLD  AND  Y .
      W = YOLD
      IFLAG = IFLAGC - 10
      IFLAGC = IFLAG
      RETURN
 100  GOFYOLD = GOFW
      W = Y
      IFLAG = IFLAGC - 20
      IFLAGC = IFLAG
      RETURN
 110  GOFY = GOFW
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  G(Q(S)) = 0 .  THE TWO POINTS ON THE ZERO CURVE ARE
C ALWAYS CHOSEN TO BRACKET  G(Y(S)) = 0, WITH THE BRACKETING INTERVAL
C ALWAYS BEING [0, DELS].
C
      SA=0.0
      SB=DELS
      LCODE=1
130   DO
        CALL ROOT(SOUT,GOFW,SA,SB,RERR,AERR,LCODE)
        IF (LCODE .GT. 0) EXIT
        DO JW=1,NP1
          W(JW)=QOFS(YOLD(JW),YPOLD(JW),Y(JW),YP(JW),DELS,SOUT)
        END DO
C REQUEST VALUE  G(Q(SOUT))  BY REVERSE CALL.
        IFLAG = IFLAGC - 30
        IFLAGC = IFLAG
        RETURN
      END DO
C IF G(Y(S)) = 0 WERE BRACKETED,  ROOT  CANNOT FAIL.
      IF (LCODE .GT. 2) THEN
        IFLAG=6
        RETURN
      ENDIF
C
C CALCULATE Q(SA) AS THE INITIAL POINT FOR A NEWTON ITERATION.
      DO JW=1,NP1
        W(JW)=QOFS(YOLD(JW),YPOLD(JW),Y(JW),YP(JW),DELS,SA)
      END DO
C
C ***** END OF CALCULATION OF CUBIC INTERPOLANT. *****
C
C TANGENT INFORMATION  YP  IS NO LONGER NEEDED.  HEREAFTER,  YP
C REPRESENTS THE MOST RECENT POINT WHICH IS ON THE OPPOSITE SIDE OF
C THE SOLUTION TO  G(Y(S)) = 0 FROM  Y.
C
C    PREPARE FOR MAIN LOOP.
C
      YP=YOLD
      GOFYP=GOFYOLD
C
C INITIALIZE  BRACK  TO INDICATE THAT THE POINTS  Y  AND  YOLD  BRACKET
C G(Y(S)) = 0,  THUS  YOLD = YP .
C
      BRACK = .TRUE.
C
C ***** MAIN LOOP. *****
      JUDY=1                                  ! DO JUDY = 1,LIMIT
 170  IF (JUDY > LIMIT) GO TO 600
C CALCULATE NEWTON STEP  TZ  AT CURRENT ESTIMATE  W .
      IFLAG = IFLAGC - 50
      IFLAGC = IFLAG
      NFE = NFE+1
      RETURN
C
C NEXT POINT = CURRENT POINT + NEWTON STEP.
C
 200  W = W + TZ
C
C GET FUNCTION VALUE  G(W) .
C
      IFLAG = IFLAGC - 40
      IFLAGC = IFLAG
      RETURN
C
C CHECK FOR CONVERGENCE.
C
 210  SA = RERR*DNRM2(NP1,W,1)+AERR
      IF ((ABS(GOFW) .LE. SA) .AND. (DNRM2(NP1,TZ,1) .LE. SA)) THEN
        Y = W
        IFLAG = IFLAGC
        RETURN
      ENDIF
C
C PREPARE FOR NEXT ITERATION.
C
      IF (ABS(GOFW) .LE. SA) THEN
         YPOLD=WP
         GO TO 590    ! CYCLE
      ENDIF
C
C    UPDATE  Y  AND  YOLD .
C
      YOLD=Y
      Y=W
      GOFYOLD=GOFY
      GOFY=GOFW
C
C    UPDATE  YP  SUCH THAT  YP  IS THE MOST RECENT POINT
C    OPPOSITE OF  G(Y(S)) = 0  FROM  Y .  SET  BRACK = .TRUE.  IFF
C    Y  AND  YOLD  BRACKET  G(Y(S)) = 0  SO THAT  YP = YOLD .
C
      IF ( GOFY * GOFYOLD .GT. 0) THEN
        BRACK = .FALSE.
      ELSE
        BRACK = .TRUE.
        YP=YOLD
        GOFYP=GOFYOLD
      END IF
C
C    COMPUTE  DELS = ||Y-YP||.
C
      TZ=Y - YP
      DELS=DNRM2(NP1,TZ,1)
C
C     COMPUTE  TZ  FOR THE LINEAR PREDICTOR   W = Y + TZ,
C     WHERE  TZ = SA*(YOLD-Y).
C
      S = ABS(GOFY - GOFYOLD)
      IF (S .GE. 1.0) THEN
        SA = GOFY/(GOFY - GOFYOLD)
        TZ = SA*(YOLD - Y)
      ELSE IF (ANY(ABS(GOFY*(YOLD-Y)) .GE. S*HUGE(1.0_R8))) THEN
        TZ = DELS
      ELSE
        SA = GOFY/(GOFY - GOFYOLD)
        TZ = SA*(YOLD - Y)
      END IF
C
C     TO INSURE STABILITY, THE LINEAR PREDICTION MUST BE NO FARTHER
C     FROM  Y  THAN  YP  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,TZ,1) .GT. DELS) THEN
C
C         COMPUTE  TZ = SA*(YP-Y).
C
          SA = GOFY/(GOFY - GOFYP)
          TZ = SA*(YP - Y)
        END IF
      END IF
C
C     COMPUTE ESTIMATE  W = Y + TZ  AND SAVE OLD TANGENT VECTOR.
C
      W = W + TZ
      YPOLD = WP
 590  JUDY=JUDY+1
      GO TO 170                          ! END DO
C
C ***** END OF MAIN LOOP. *****
C
C THE ALTERNATING SECANT ESTIMATION AND NEWTON ITERATION
C HAS NOT CONVERGED IN  LIMIT  STEPS.  ERROR RETURN.
 600  IFLAG=6
      RETURN
      END SUBROUTINE ROOTNX
      SUBROUTINE ROOTQF(N,NFE,IFLAG,RELERR,ABSERR,Y,YP,YOLD,
     &   YPOLD,A,Q,R,DZ,Z,W,T,F0,F1)
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 THE FOLLOWING INTERFACE BLOCK SHOULD BE INCLUDED IN THE CALLING
C PROGRAM:
C
C     INTERFACE
C       SUBROUTINE ROOTQF(N,NFE,IFLAG,RELERR,ABSERR,Y,YP,YOLD,
C    &    YPOLD,A,Q,R,DZ,Z,W,T,F0,F1)
C       USE REAL_PRECISION
C       REAL (KIND=R8):: RELERR, ABSERR
C       INTEGER:: N, NFE, IFLAG
C       REAL (KIND=R8):: A(:), DZ(N+1), F0(N+1), F1(N+1), 
C    &    Q(N+1,N+1), R((N+1)*(N+2)/2), T(N+1), W(N+1),
C    &    Y(:), YOLD(N+1), YP(N+1), YPOLD(N+1), Z(N+1)
C       END SUBROUTINE ROOTQF
C     END INTERFACE
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(:) = PARAMETER VECTOR IN THE HOMOTOPY MAP.
C
C Q(1:N+1,1:N+1) CONTAINS  Q  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    THE QR FACTORIZATION, STORED BY COLUMNS.
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
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  DGEMV, DNRM2, DTPSV, F (OR RHO), ROOT, UPQRQF.
C
C ***** DECLARATIONS ***** 
      USE HOMOTOPY
      USE REAL_PRECISION
C
C FUNCTION DECLARATIONS 
C
      INTERFACE
        FUNCTION DNRM2(N,X,STRIDE)
        USE REAL_PRECISION
        INTEGER:: N,STRIDE
        REAL (KIND=R8):: DNRM2,X(N)
        END FUNCTION DNRM2
      END INTERFACE
      REAL (KIND=R8):: QOFS
C
C LOCAL VARIABLES 
C
      REAL (KIND=R8):: 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
      REAL (KIND=R8):: RELERR, ABSERR
      INTEGER:: N, NFE, IFLAG
C
C ARRAY DECLARATIONS 
C
      REAL (KIND=R8):: A(:), DZ(N+1), F0(N+1), F1(N+1), 
     &   Q(N+1,N+1), R((N+1)*(N+2)/2), T(N+1), W(N+1),
     &   Y(:), YOLD(N+1), YP(N+1), YPOLD(N+1), Z(N+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=EPSILON(1.0_R8)
      RERR=MAX(RELERR,U)
      AERR=MAX(ABSERR,ZERO)
      NP1=N+1
      ETA = 100.0*U
      LIMIT = 2*(INT(ABS(LOG10(AERR+RERR)))+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:NP1),F0(1:N))
      ELSE IF (IFLAG .EQ. -1) THEN
C
C ZERO FINDING PROBLEM.
C
        CALL F(Y(2:NP1),F0(1:N))
        F0(1:N) = Y(1)*F0(1:N) + (1.0-Y(1))*(Y(2:NP1)-A(1:N))
      ELSE
C
C FIXED POINT PROBLEM.
C
        CALL F(Y(2:NP1),F0(1:N))
        F0(1:N) = Y(1)*(A(1:N)-F0(1:N))+Y(2:NP1)-A(1:N)
      END IF
      F0(NP1) = DOT_PRODUCT(YP,Y)
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
      DZ = Y - YOLD
      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 I=1,NP1
        Z(I)=QOFS(YOLD(I),YPOLD(I),Y(I),YP(I),DELS,SA)
      END DO
C
C CALCULATE DZ = Z-Y.
C
      DZ = Z - Y
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
      YPOLD = YOLD
C
C INITIALIZE  BRACK  TO INDICATE THAT THE POINTS  Y  AND  YOLD  BRACKET
C LAMBDA=1,  THUS YOLD = YPOLD.
C
      BRACK = .TRUE.
C
      DO ISTEP=1,LIMIT   ! ***** MAIN LOOP *****
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:NP1),F1(1:N))
        ELSE IF (IFLAG .EQ. -1) THEN
          CALL F(Z(2:NP1),F1(1:N))
          F1(1:N) = Z(1)*F1(1:N) + (1.0-Z(1))*(Z(2:NP1)-A(1:N))
        ELSE
          CALL F(Z(2:NP1),F1(1:N))
          F1(1:N) = Z(1)*(A(1:N)-F1(1:N))+Z(2:NP1)-A(1:N)
        END IF
        F1(NP1) = DOT_PRODUCT(YP,Z)
C
C
C PERFORM BROYDEN UPDATE.
C
        CALL UPQRQF(NP1,ETA,DZ,F0,F1,Q,R,W,T)
C
C QUASI-NEWTON STEP.
C
C COMPUTE NEWTON STEP.
C
        T(1:N) = -F1(1:N)
        T(NP1) = 0.0
        CALL DGEMV('T',NP1,NP1,ONE,Q,NP1,T,1,ZERO,DZ,1)
        CALL DTPSV('U', 'N', 'N', NP1, R, DZ, 1)
C
C TAKE NEWTON STEP.
C
        W = Z
        Z = Z + DZ
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
           Y = Z
           RETURN
        END IF
C
C PREPARE FOR NEXT ITERATION.
C
        F0 = F1  
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
           DZ = Z - W
           CYCLE
        END IF
C
C       UPDATE  Y  AND  YOLD.
C
        YOLD = Y
        Y = Z
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.
          YPOLD = YOLD
        END IF
C
C COMPUTE DELS = ||Y-YPOLD||.
C              
        DZ = Y - YPOLD
        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))
        DZ = SA*(YOLD - Y)
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 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))
            DZ = SA*(YPOLD - Y)
          END IF
        END IF
C
C COMPUTE PREDICTOR Z = Y+DZ, AND DZ = NEW Z  - OLD Z (USED FOR
C QUASI-NEWTON UPDATE).
C
        Z = Z + DZ
        DZ = Z - W
      END DO  ! ***** 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
      END SUBROUTINE ROOTQF
      SUBROUTINE SCLGNP(N,MAXT,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  DGEQRF).  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 CALLS DIRECTLY: THE LAPACK ROUTINES  DGEQRF,  DORMQR,  THE BLAS 
C ROUTINE  DTRSV.
C
C N  IS THE NUMBER OF EQUATIONS AND THE NUMBER OF VARIABLES.
C
C MAXT  IS THE LEAST UPPER BOUND OF 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
      USE REAL_PRECISION
C
C DECLARATION OF INPUT
      INTEGER, INTENT(IN):: N,MAXT,NUMT(:),DEG(:,:,:),MODE
      REAL (KIND=R8), INTENT(IN):: EPS0,COEF(:,:)
C
C DECLARATION OF WORKSPACE
      INTEGER, INTENT(IN OUT):: NNUMT(N),DDEG(N,N+1,MAXT)
      REAL (KIND=R8), INTENT(IN OUT):: CCOEF(N,MAXT),ALPHA(2*N,2*N),
     &  BETA(2*N),RWORK(N*(2*N+1)),XWORK(2*N)
C
C DECLARATION OF OUTPUT
      REAL (KIND=R8), INTENT(OUT):: FACV(N),FACE(N),COESCL(N,MAXT)
      INTEGER, INTENT(OUT):: IERR
C
C DECLARATION OF LOCAL VARIABLES
      INTEGER:: I,IDAMAX,ICMAX,IRMAX,J,JJ,K,LENR,N2,S
      REAL (KIND=R8):: DUM,LMFPN,NTUR,RTOL,TUM
C
      SAVE
C
      IERR=0
      N2=2*N
      LMFPN=HUGE(1.0_R8)
      NTUR=EPSILON(1.0_R8)*N
      LENR=N*(N+1)/2
C
C  DELETE NEAR ZERO TERMS
      NNUMT = 0
      DO I=1,N
        JJ=0
        DO 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)
            DDEG(I,1:N,JJ)=DEG(I,1:N,J)
          END IF
        END DO
      END DO
      DO I=1,N
        COESCL(I,1:NNUMT(I)) = LOG10(ABS(CCOEF(I,1:NNUMT(I))))
      END DO
C
C SKIP OVER THE GENERATION AND DECOMPOSITON OF MATRIX ALPHA IF MODE=1
      MODE0: IF (MODE .EQ. 0) THEN
C
C GENERATE THE MATRIX ALPHA
      ALPHA(1:N,1:N) = 0.0
      DO S=1,N
        ALPHA(S,S)=NNUMT(S)
      END DO
      DO I=1,N
        ALPHA(N+1:2*N,I) = SUM(DDEG(I,1:N,1:NNUMT(I)),DIM=2)
      END DO
      DO S=1,N
        DO K=1,N
          TUM=0
          DO I=1,N
            DO J=1,NNUMT(I)
              TUM=TUM+DDEG(I,S,J)*DDEG(I,K,J)
            END DO
          END DO
          ALPHA(N+S,N+K)=TUM
        END DO
      END DO
      DO S=1,N
        ALPHA(S,N+1:2*N) = SUM(DDEG(S,1:N,1:NNUMT(S)),DIM=2)
      END DO
C
C COMPUTE QR FACTORIZATION OF MATRIX ALPHA
      CALL DGEQRF(2*N,2*N,ALPHA,2*N,XWORK,BETA,2*N,I)
C
C REPAIR ILL-CONDITIONED SCALING MATRIX
      IRMAX=1        
      ICMAX=1
      DO J=2,N
        I=IDAMAX(J,ALPHA(1,J),1)
        IF (ABS(ALPHA(I,J)) .GT. ABS(ALPHA(IRMAX,ICMAX))) THEN 
          IRMAX=I
          ICMAX=J
        ENDIF
      END DO
      RTOL=ABS(ALPHA(IRMAX,ICMAX))*NTUR
      DO I=N,1,-1
        IF (ABS(ALPHA(I,I)) .LT. RTOL) THEN
          ALPHA(I,I)=LMFPN
          IERR=1
        ENDIF
      END DO
C      
      ENDIF MODE0
C
C CONTROL PASSES HERE IF MODE=1
C
C
C GENERATE THE COLUMN BETA
      DO S=1,N
        BETA(S)=-SUM(COESCL(S,1:NNUMT(S)))
      END DO
      DO S=1,N
        TUM=0
        DO I=1,N
          TUM = TUM + DOT_PRODUCT(COESCL(I,1:NNUMT(I)),
     &      DDEG(I,S,1:NNUMT(I)))
        END DO
        BETA(N+S)=-TUM
      END DO
C
C SOLVE THE LINEAR SYSTEM ALPHA * X = BETA
      CALL DORMQR('L','T',2*N,1,2*N-1,ALPHA,2*N,XWORK,BETA,2*N,RWORK,
     &  N*(2*N+1),I) 
      CALL DTRSV('U','N','N',2*N,ALPHA,2*N,BETA,1) 
C
C GENERATE FACE, FACV, AND THE MATRIX COESCL
      FACE(1:N)=BETA(1:N)
      FACV(1:N)=BETA(N+1:2*N)
      DO I=1,N
        DO J=1,NUMT(I)
          DUM = ABS(COEF(I,J))
          IF (DUM .EQ. 0.0) THEN
            COESCL(I,J) = 0.0
          ELSE
            TUM = FACE(I) + LOG10( DUM ) + DOT_PRODUCT(FACV(1:N),
     &        DEG(I,1:N,J))
            COESCL(I,J) = SIGN(10.0**(TUM), COEF(I,J))
          ENDIF
        END DO
      END DO
      RETURN
      END SUBROUTINE SCLGNP
      SUBROUTINE SINTRP(X,Y,XOUT,YOUT,YPOUT,NEQN,KOLD,PHI,IVC,IV,KGI,GI,
     &                                                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 
      USE REAL_PRECISION
      REAL (KIND=R8):: ALP,ALPHA,C,G,GAMMA,GDI,GDIF,GI,GTEMP,
     &  H,HI,HMU,P,PHI,RMU,SIGMA,TEMP1,TEMP2,TEMP3,W,WTEMP,
     &  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),
     &          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 IQ = 1,KP1
        XIQ = XI*XIQ
        TEMP1 = IQ*(IQ+1) 
        WTEMP(IQ) = XIQ/TEMP1 
      END DO
C 
C   COMPUTE THE DOUBLE INTEGRAL TERM GDI
C 
      IF (KOLD .LE. KGI) THEN
        GDI = GI(KOLD)
      ELSE
        IF (IVC .GT. 0) THEN
          IW = IV(IVC)
          GDI = W(IW)
          M = KOLD - IW + 3 
        ELSE
          GDI = 1.0/TEMP1 
          M = 2 
        END IF
        IF (M .LE. KOLD) THEN
          DO I = M,KOLD
            GDI = W(KP2-I) - ALPHA(I)*GDI
          END DO
        END IF
      END IF
C 
C   COMPUTE GTEMP(*) AND C(*) 
C 
      GTEMP(1) = XI 
      GTEMP(2) = 0.5*XI*XI
      C(1) = 1.0
      C(2) = XI 
      IF (KOLD .GE. 2) THEN
        DO I = 2,KOLD
          ALP = ALPHA(I)
          GAMMA = 1.0 + XIM1*ALP
          L = KP2 - I 
          DO JQ = 1,L
            WTEMP(JQ) = GAMMA*WTEMP(JQ) - ALP*WTEMP(JQ+1) 
          END DO
          GTEMP(I+1) = WTEMP(1) 
          C(I+1) = GAMMA*C(I) 
        END DO
      END IF
C 
C   DEFINE INTERPOLATION PARAMETERS 
C 
      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 
      YOUT = 0.0 
      YPOUT = 0.0
      DO 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
        YOUT = YOUT + TEMP2*PHI(:,I)
        YPOUT = YPOUT + TEMP3*PHI(:,I)
      END DO
      YOUT = ((1.0 - SIGMA)*P + SIGMA*Y) +
     &             H*(YOUT + (GTEMP(1) - SIGMA*G(1))*PHI(:,1))
      YPOUT = HMU*(P - Y) + (YPOUT + (C(1) + RMU*G(1))*PHI(:,1))
C 
      RETURN
      END SUBROUTINE SINTRP
      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
      USE REAL_PRECISION
      INTEGER, INTENT(IN):: NN,MAXA(NN+1),NWK
      REAL (KIND=R8), INTENT(IN):: A(NWK)
      REAL (KIND=R8), INTENT(IN OUT):: V(NN)
C local variables.
      INTEGER:: K,KK,KL,KU,L,N
      REAL (KIND=R8):: C
      DO N=1,NN
         KL=MAXA(N)+1
         KU=MAXA(N+1)-1
         IF (KU-KL < 0) CYCLE
         K=N
         C=0.0
         DO KK=KL,KU
            K=K-1
            C=C+A(KK)*V(K)
         END DO
         V(N)=V(N)-C
      END DO
      DO N=1,NN
         K=MAXA(N)
         V(N)=V(N)/A(K)
      END DO
      IF (NN.EQ.1) RETURN
      N=NN
      DO L=2,NN
         KL=MAXA(N) + 1
         KU=MAXA(N+1) - 1
         IF (KU-KL .GE. 0) THEN
           K=N
           DO KK=KL,KU
             K=K - 1
             V(K)=V(K) - A(KK)*V(N)
           END DO
         END IF
         N = N - 1
      END DO
      RETURN
      END SUBROUTINE SOLVDS
      SUBROUTINE STEPDS(F,NEQN,Y,X,H,EPS,WT,START,HOLD,K,KOLD,
     &   CRASH,PHI,P,YP,ALPHA,W,G,KSTEPS,XOLD,IVC,IV,KGI,GI,  
     &   IFLAGC,YPOLD,A,NDIMA,LENQR,MODE,NFEC)
C 
C   STEPDS  IS A MODIFIED FORTRAN 90 VERSION OF  STEPS
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  YPOLD  AND  A  AND INTEGER CONSTANTS IFLAGC, NDIMA,
C   LENQR, MODE, NFEC ARE WORKING STORAGE PASSED DIRECTLY THROUGH TO
C   FODEDS.
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    &  ALPHA(12),W(12),G(13),GI(11),IV(10), YPOLD(NEQN),A(NDIMA)
C
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,NEQN-1,IFLAGC,YPOLD,A,NDIMA,LENQR,MODE,NFEC)
C   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 FORTRAN 90 INTRINSIC FUNCTION EPSILON.  U IS THE SMALLEST
C   POSITIVE NUMBER SUCH 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 
      USE REAL_PRECISION
      REAL (KIND=R8):: ABSH,EPS,ERK,ERKM1,ERKM2,ERKP1,ERR,FOURU,H,
     &  HNEW,HOLD,P5EPS,R,REALI,REALNS,RHO,ROUND,SUM,TAU,
     &  TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,TEMP6,TWOU,X,XOLD
      INTEGER:: I,IFAIL,IFLAGC,IM1,IP1,IQ,IV(10),IVC,J,JV,K,KGI,
     &  KM1,KM2,KNEW,KOLD,KP1,KP2,KPREV,KSTEPS,L,LENQR,LIMIT1,LIMIT2,
     &  MODE,NDIMA,NEQN,NFEC,NS,NSM2,NSP1,NSP2
      LOGICAL:: CRASH,NORND,PHASE1,START
C
      REAL (KIND=R8):: A(NDIMA),ALPHA(12),BETA(12),G(13),GI(11),
     &  P(NEQN),PHI(NEQN,16),PSI(12),SIG(13),V(12),W(12),
     &  WT(NEQN),Y(NEQN),YP(NEQN),YPOLD(NEQN)
C
C   ALL LOCAL VARIABLES ARE SAVED, RATHER THAN PASSED, IN THIS
C   SPECIALIZED VERSION OF STEPS.
C
      SAVE
C
      INTERFACE
        SUBROUTINE F(S,Y,YP,N,IFLAG,YPOLD,A,NDIMA,LENQR,MODE,NFE)
        USE REAL_PRECISION
        INTEGER:: IFLAG,LENQR,MODE,N,NDIMA,NFE
        REAL (KIND=R8):: A(NDIMA),S,Y(N+1),YP(N+1),YPOLD(N+1)
        END SUBROUTINE F
      END INTERFACE
C 
      REAL (KIND=R8), DIMENSION(13)::
     &  TWO=(/2.0,4.0,8.0,16.0,32.0,64.0,128.0,256.0,512.0,1024.0,
     &  2048.0,4096.0,8192.0/),
     &  GSTR=(/0.500,0.0833,0.0417,0.0264,0.0188,0.0143,0.0114,0.00936,
     &  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 * EPSILON(1.0_R8)
      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 L = 1,NEQN
        ROUND = ROUND + (Y(L)/WT(L))**2 
      END DO
      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,NEQN-1,IFLAGC,YPOLD,A,NDIMA,LENQR,MODE,NFEC)
      IF (IFLAGC .GT. 0) RETURN
      SUM = 0.0 
      DO L = 1,NEQN
        PHI(L,1) = YP(L)
        PHI(L,2) = 0.0
        SUM = SUM + (YP(L)/WT(L))**2
      END DO
      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)
      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. 
      PHI(1:NEQN,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 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 
        SIG(I+1) = REALI*ALPHA(I)*SIG(I)
      END DO
 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 IQ = 1,K 
        TEMP3 = IQ*(IQ+1) 
        V(IQ) = 1.0/TEMP3 
        W(IQ) = V(IQ) 
      END DO
      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 J = JV,NSM2
        I = K-J 
        V(I) = V(I) - ALPHA(J+1)*V(I+1) 
        W(I) = V(I) 
      END DO
      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 IQ = 1,LIMIT1
        V(IQ) = V(IQ) - TEMP5*V(IQ+1) 
        W(IQ) = V(IQ) 
      END DO
      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 .GE. NSP2) THEN
        DO I = NSP2,KP1 
          LIMIT2 = KP2 - I
          TEMP6 = ALPHA(I-1)
          DO IQ = 1,LIMIT2
            W(IQ) = W(IQ) - TEMP6*W(IQ+1) 
          END DO
          G(I) = W(1) 
        END DO
      END IF
 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 I = NSP1,K 
        PHI(1:NEQN,I) = BETA(I)*PHI(1:NEQN,I) 
      END DO
C 
C   PREDICT SOLUTION AND DIFFERENCES
C 
 215  PHI(1:NEQN,KP2) = PHI(1:NEQN,KP1) 
      PHI(1:NEQN,KP1) = 0.0
      P(1:NEQN) = 0.0
      DO J = 1,K
        I = KP1 - J 
        IP1 = I+1 
        P(1:NEQN) = P(1:NEQN) + G(I)*PHI(1:NEQN,I)
        PHI(1:NEQN,I) = PHI(1:NEQN,I) + PHI(1:NEQN,IP1)
      END DO
      IF (NORND) THEN
        P(1:NEQN) = Y(1:NEQN) + H*P(1:NEQN)
      ELSE
        DO L = 1,NEQN 
          TAU = H*P(L) - PHI(L,15)
          P(L) = Y(L) + TAU 
          PHI(L,16) = (P(L) - Y(L)) - TAU 
        END DO
      END IF
      XOLD = X
      X = X + H 
      ABSH = ABS(H) 
      CALL F(X,P,YP,NEQN-1,IFLAGC,YPOLD,A,NDIMA,LENQR,MODE,NFEC)
      IF (IFLAGC .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 L = 1,NEQN 
        TEMP3 = 1.0/WT(L) 
        TEMP4 = YP(L) - PHI(L,1)
        IF (KM2 > 0) ERKM2 = ERKM2 + ((PHI(L,KM1)+TEMP4)*TEMP3)**2 
        IF (KM2 .GE. 0) ERKM1 = ERKM1 + ((PHI(L,K)+TEMP4)*TEMP3)**2 
        ERK = ERK + (TEMP4*TEMP3)**2
      END DO
      IF (KM2 > 0) ERKM2 = ABSH*SIG(KM1)*GSTR(KM2)*SQRT(ERKM2) 
      IF (KM2 .GE. 0) ERKM1 = ABSH*SIG(K)*GSTR(KM1)*SQRT(ERKM1) 
      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 > 0) THEN
        IF(MAX(ERKM1,ERKM2) .LE. ERK) KNEW = KM1
      ELSE IF (KM2 .EQ. 0) THEN
        IF(ERKM1 .LE. 0.5*ERK) KNEW = KM1 
      END IF
C 
C   TEST IF STEP SUCCESSFUL 
C 
      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 I = 1,K
        TEMP1 = 1.0/BETA(I) 
        IP1 = I+1 
        PHI(1:NEQN,I) = TEMP1*(PHI(1:NEQN,I) - PHI(1:NEQN,IP1))
      END DO
      IF (K .GE. 2) THEN
        DO I = 2,K
          PSI(I-1) = PSI(I) - H 
        END DO
      END IF
C 
C   ON THIRD FAILURE, SET ORDER TO ONE.  THEREAFTER, USE OPTIMAL STEP 
C   SIZE
C 
      IFAIL = IFAIL + 1 
      TEMP2 = 0.5 
      IF (IFAIL > 3) THEN
        IF (P5EPS .LT. 0.25*ERK) TEMP2 = SQRT(P5EPS/ERK) 
      ENDIF
      IF (IFAIL .GE. 3) KNEW = 1
      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) THEN
        DO L = 1,NEQN 
          TEMP3 = Y(L)
          Y(L) = P(L) + TEMP1*(YP(L) - PHI(L,1))
          P(L) = TEMP3
        END DO
      ELSE
        DO 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 
          P(L) = TEMP3
        END DO
      END IF
      CALL F(X,Y,YP,NEQN-1,IFLAGC,YPOLD,A,NDIMA,LENQR,MODE,NFEC)
      IF (IFLAGC .GT. 0) RETURN
C 
C   UPDATE DIFFERENCES FOR NEXT STEP
C 
      PHI(1:NEQN,KP1) = YP(1:NEQN) - PHI(1:NEQN,1) 
      PHI(1:NEQN,KP2) = PHI(1:NEQN,KP1) - PHI(1:NEQN,KP2)
      DO I = 1,K
        PHI(1:NEQN,I) = PHI(1:NEQN,I) + PHI(1:NEQN,KP1)
      END DO
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 L = 1,NEQN 
        ERKP1 = ERKP1 + (PHI(L,KP2)/WT(L))**2 
      END DO
      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.5_R8,MIN(0.9_R8,R)) 
      HNEW = SIGN(MAX(HNEW,FOURU*ABS(X)),H) 
 465  H = HNEW
      RETURN
C       ***     END BLOCK 4     *** 
      END SUBROUTINE STEPDS
      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)
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 THE FOLLOWING INTERFACE BLOCK SHOULD BE INCLUDED IN THE CALLING
C PROGRAM:
C
C     INTERFACE
C       SUBROUTINE STEPNF(N,NFE,IFLAG,START,CRASH,HOLD,H,RELERR,
C    &    ABSERR,S,Y,YP,YOLD,YPOLD,A,QR,ALPHA,TZ,PIVOT,W,WP,
C    &    Z0,Z1,SSPAR)
C       USE REAL_PRECISION
C       REAL (KIND=R8):: ABSERR,H,HOLD,RELERR,S
C       INTEGER:: IFLAG,N,NFE
C       LOGICAL:: CRASH,START
C       REAL (KIND=R8):: A(:),ALPHA(3*N+3),QR(N,N+2),SSPAR(8),TZ(N+1),
C    &    W(N+1),WP(N+1),Y(:),YOLD(N+1),YP(N+1),YPOLD(N+1),
C    &    Z0(N+1),Z1(N+1)
C       INTEGER:: PIVOT(N+1)
C       END SUBROUTINE STEPNF
C     END INTERFACE
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(:) = PARAMETER VECTOR IN THE HOMOTOPY MAP.
C
C QR(1:N,1:N+2), ALPHA(1:3*N+3), 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
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  DNRM2 , TANGNF .
C
      USE REAL_PRECISION
      REAL (KIND=R8):: ABSERR,DCALC,DD001,DD0011,DD01,
     &   DD011,DELS,F0,F1,FOURU,FP0,FP1,H,HFAIL,HOLD,HT,
     &   LCALC,QOFS,RCALC,RELERR,RHOLEN,S,TEMP,TWOU
      INTEGER:: IFLAG,ITNUM,J,JUDY,N,NFE,NP1
      LOGICAL:: CRASH,FAIL,START
C
C ***** ARRAY DECLARATIONS. *****
C
      REAL (KIND=R8):: A(:),ALPHA(3*N+3),QR(N,N+2),SSPAR(8),TZ(N+1),
     &  W(N+1),WP(N+1),Y(:),YOLD(N+1),YP(N+1),YPOLD(N+1),
     &  Z0(N+1),Z1(N+1)
      INTEGER:: PIVOT(N+1)
C
C ***** END OF DIMENSIONAL INFORMATION. *****
C
      INTERFACE
        FUNCTION DNRM2(N,X,STRIDE)
        USE REAL_PRECISION
        INTEGER:: N,STRIDE
        REAL (KIND=R8):: DNRM2,X(N)
        END FUNCTION DNRM2
        SUBROUTINE TANGNF(RHOLEN,Y,YP,YPOLD,A,QR,ALPHA,TZ,PIVOT,
     &    NFE,N,IFLAG)
        USE REAL_PRECISION
        REAL (KIND=R8):: RHOLEN
        INTEGER:: IFLAG,N,NFE
        REAL (KIND=R8):: A(:),Y(:),YP(N+1),YPOLD(N+1)
        REAL (KIND=R8):: ALPHA(3*N+3),QR(N,N+2),TZ(N+1)
        INTEGER:: PIVOT(N+1)
        END SUBROUTINE TANGNF
      END INTERFACE
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:
      INTEGER, 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*EPSILON(1.0_R8)
      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)+1.0
      IF (.5*(RELERR*TEMP+ABSERR) .LT. TWOU*TEMP) THEN
        IF (RELERR .NE. 0.0) THEN
          RELERR=FOURU*(1.0+FOURU)
          ABSERR=MAX(ABSERR,0.0_R8)
        ELSE
          ABSERR=FOURU*TEMP
        ENDIF
        RETURN
      ENDIF
      CRASH=.FALSE.
      STARTUP: IF (START) THEN
C
C *****  STARTUP SECTION (FIRST STEP ALONG ZERO CURVE).  *****
C
      FAIL=.FALSE.
      START=.FALSE.
C DETERMINE SUITABLE INITIAL STEP SIZE.
      H=MIN(H, .10_R8, SQRT(SQRT(RELERR*TEMP+ABSERR)))
C USE LINEAR PREDICTOR ALONG TANGENT DIRECTION TO START NEWTON ITERATION.
      YPOLD(1)=1.0
      YPOLD(2:NP1)=0.0
      CALL TANGNF(S,Y,YP,YPOLD,A,QR,ALPHA,TZ,PIVOT,NFE,N,IFLAG)
      IF (IFLAG .GT. 0) RETURN
      LP: DO
      W=Y + H*YP
      Z0=W
      DO 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)
        IF (IFLAG .GT. 0) RETURN
C
C TAKE NEWTON STEP AND CHECK CONVERGENCE.
        W=W + TZ
        ITNUM=JUDY
C COMPUTE QUANTITIES USED FOR OPTIMAL STEP SIZE ESTIMATION.
        IF (JUDY .EQ. 1) THEN
          LCALC=DNRM2(NP1,TZ,1)
          RCALC=RHOLEN
          Z1=W
        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
      END DO
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
      END DO LP
      END IF STARTUP
C
C ***** END OF STARTUP SECTION. *****
C
C ***** PREDICTOR SECTION. *****
C
      FAIL=.FALSE.
C COMPUTE POINT PREDICTED BY HERMITE INTERPOLANT.  USE STEP SIZE  H
C COMPUTED ON LAST CALL TO  STEPNF .
      HP: DO
      DO J=1,NP1
        W(J)=QOFS(YOLD(J),YPOLD(J),Y(J),YP(J),HOLD,HOLD+H)
      END DO
      Z0=W 
C
C ***** END OF PREDICTOR SECTION. *****
C
C ***** CORRECTOR SECTION. *****
C
      CORRECTOR: DO 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)
        IF (IFLAG .GT. 0) RETURN
C
C TAKE NEWTON STEP AND CHECK CONVERGENCE.
        W=W + TZ
        ITNUM=JUDY
C COMPUTE QUANTITIES USED FOR OPTIMAL STEP SIZE ESTIMATION.
        IF (JUDY .EQ. 1) THEN
          LCALC=DNRM2(NP1,TZ,1)
          RCALC=RHOLEN
          Z1=W
        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
      END DO CORRECTOR
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
      END DO HP
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   YPOLD=YP
      YOLD=Y
      Y=W
      YP=WP
      W=Y - YOLD
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 .
      TZ=Z0 - Y
      W=Z1 - Y
      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 STEPNF
      SUBROUTINE STEPNS(N,NFE,IFLAG,START,CRASH,HOLD,H,RELERR,
     &   ABSERR,S,Y,YP,YOLD,YPOLD,A,MODE,LENQR,SSPAR,TZ,W,WP,Z0,Z1)
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.  SEE ALSO THE REVERSE CALL ROUTINE  STEPNX .
C
C THE CALLING PROGRAM MUST INCLUDE THE FOLLOWING INTERFACE BLOCK:
C
C     INTERFACE
C       SUBROUTINE STEPNS(N,NFE,IFLAG,START,CRASH,HOLD,H,RELERR,
C    &    ABSERR,S,Y,YP,YOLD,YPOLD,A,MODE,LENQR,SSPAR,TZ,W,WP,Z0,Z1)
C       USE REAL_PRECISION
C       INTEGER, INTENT(IN):: LENQR,MODE,N
C       INTEGER, INTENT(IN OUT):: IFLAG,NFE
C       LOGICAL, INTENT(IN OUT):: CRASH,START
C       REAL (KIND=R8), INTENT(IN):: A(:),SSPAR(8)
C       REAL (KIND=R8), INTENT(IN OUT):: ABSERR,H,HOLD,RELERR,S,
C    &    Y(:),YOLD(:),YP(:),YPOLD(:)
C       REAL (KIND=R8), INTENT(OUT), DIMENSION(:):: TZ,W,WP,Z0,Z1
C       END SUBROUTINE STEPNS
C     END INTERFACE
C
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(:) = PARAMETER VECTOR IN THE HOMOTOPY MAP.
C
C MODE = 1 IF THE JACOBIAN MATRIX IS SYMMETRIC AND STORED IN A PACKED
C          SKYLINE FORMAT;
C      = 2 IF THE JACOBIAN MATRIX IS STORED IN A SPARSE ROW FORMAT.
C
C LENQR  IS THE NUMBER OF NONZERO ENTRIES IN THE SPARSE JACOBIAN
C    MATRICES, USED TO DETERMINE THE SPARSE MATRIX DATA STRUCTURES.
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 TZ(1:N+1), W(1:N+1), WP(1:N+1), Z0(1:N+1), AND  Z1(1:N+1)  ARE WORK
C    ARRAYS USED FOR THE CALCULATION OF THE JACOBIAN MATRIX KERNEL, THE
C    NEWTON STEP, INTERPOLATION, AND THE ESTIMATION OF THE NEXT STEP
C    SIZE  H .
C
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  DNRM2 , TANGNS .
C
      USE REAL_PRECISION
      INTEGER, INTENT(IN):: LENQR,MODE,N
      INTEGER, INTENT(IN OUT):: IFLAG,NFE
      LOGICAL, INTENT(IN OUT):: CRASH,START
      REAL (KIND=R8), INTENT(IN):: A(:),SSPAR(8)
      REAL (KIND=R8), INTENT(IN OUT):: ABSERR,H,HOLD,RELERR,S,
     &  Y(:),YOLD(:),YP(:),YPOLD(:)
      REAL (KIND=R8), INTENT(OUT), DIMENSION(:):: TZ,W,WP,Z0,Z1
C
C *****  LOCAL VARIABLES.  *****
C
      REAL (KIND=R8):: DCALC,DD001,DD0011,DD01,DD011,DELS,F0,F1,
     &   FOURU,FP0,FP1,HFAIL,HT,LCALC,QOFS,RCALC,RHOLEN,TEMP,TWOU
      INTEGER:: ITNUM,J,JUDY,NP1
      LOGICAL:: FAIL
C
      INTERFACE
        FUNCTION DNRM2(N,X,STRIDE)
        USE REAL_PRECISION
        INTEGER:: N,STRIDE
        REAL (KIND=R8):: DNRM2,X(N)
        END FUNCTION DNRM2
        SUBROUTINE TANGNS(RHOLEN,Y,YP,TZ,YPOLD,A,MODE,LENQR,
     &    NFE,N,IFLAG)
        USE REAL_PRECISION
        REAL (KIND=R8), INTENT(IN), DIMENSION(:):: A,Y,YPOLD
        REAL (KIND=R8), INTENT(IN OUT):: RHOLEN
        REAL (KIND=R8), INTENT(OUT), DIMENSION(:):: TZ,YP
        INTEGER, INTENT(IN):: LENQR,MODE,N
        INTEGER, INTENT(IN OUT):: IFLAG,NFE
        END SUBROUTINE TANGNS
      END INTERFACE
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:
      INTEGER, 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 ***** END OF SPECIFICATION INFORMATION. *****
C
C
      TWOU=2.0*EPSILON(1.0_R8)
      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)+1.0
      IF (.5*(RELERR*TEMP+ABSERR) .LT. TWOU*TEMP) THEN
        IF (RELERR .NE. 0.0) THEN
          RELERR=FOURU*(1.0+FOURU)
          ABSERR=MAX(ABSERR,0.0_R8)
        ELSE
          ABSERR=FOURU*TEMP
        ENDIF
        RETURN
      ENDIF
      CRASH=.FALSE.
      STARTUP: IF (START) THEN
C
C *****  STARTUP SECTION (FIRST STEP ALONG ZERO CURVE).  *****
C
      FAIL=.FALSE.
      START=.FALSE.
C DETERMINE SUITABLE INITIAL STEP SIZE.
      H=MIN(H, .10_R8, SQRT(SQRT(RELERR*TEMP+ABSERR)))
C USE LINEAR PREDICTOR ALONG TANGENT DIRECTION TO START NEWTON ITERATION.
      YPOLD(NP1)=1.0
      YPOLD(1:N)=0.0
      CALL TANGNS(S,Y,YP,TZ,YPOLD,A,MODE,LENQR,NFE,N,IFLAG)
      IF (IFLAG .GT. 0) RETURN
      LP: DO
      W=Y + H*YP
      Z0=W
      DO JUDY=1,LITFH
        RHOLEN=-1.0
C CALCULATE THE NEWTON STEP  TZ  AT THE CURRENT POINT  W .
        CALL TANGNS(RHOLEN,W,WP,TZ,YPOLD,A,MODE,LENQR,NFE,N,IFLAG)
        IF (IFLAG .GT. 0) RETURN
C
C TAKE NEWTON STEP AND CHECK CONVERGENCE.
        W=W + TZ
        ITNUM=JUDY
C COMPUTE QUANTITIES USED FOR OPTIMAL STEP SIZE ESTIMATION.
        IF (JUDY .EQ. 1) THEN
          LCALC=DNRM2(NP1,TZ,1)
          RCALC=RHOLEN
          Z1=W
        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
      END DO
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
      END DO LP
      END IF STARTUP
C
C ***** END OF STARTUP SECTION. *****
C
C ***** PREDICTOR SECTION. *****
C
      FAIL=.FALSE.
C COMPUTE POINT PREDICTED BY HERMITE INTERPOLANT.  USE STEP SIZE  H
C COMPUTED ON LAST CALL TO  STEPNF .
      HP: DO
      DO J=1,NP1
        W(J)=QOFS(YOLD(J),YPOLD(J),Y(J),YP(J),HOLD,HOLD+H)
      END DO
      Z0=W 
C
C ***** END OF PREDICTOR SECTION. *****
C
C ***** CORRECTOR SECTION. *****
C
      CORRECTOR: DO JUDY=1,LITFH
        RHOLEN=-1.0
C CALCULATE THE NEWTON STEP  TZ  AT THE CURRENT POINT  W .
        CALL TANGNS(RHOLEN,W,WP,TZ,YP,A,MODE,LENQR,NFE,N,IFLAG)
        IF (IFLAG .GT. 0) RETURN
C
C TAKE NEWTON STEP AND CHECK CONVERGENCE.
        W=W + TZ
        ITNUM=JUDY
C COMPUTE QUANTITIES USED FOR OPTIMAL STEP SIZE ESTIMATION.
        IF (JUDY .EQ. 1) THEN
          LCALC=DNRM2(NP1,TZ,1)
          RCALC=RHOLEN
          Z1=W
        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
      END DO CORRECTOR
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
      END DO HP
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   YPOLD=YP
      YOLD=Y
      Y=W
      YP=WP
      W=Y - YOLD
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 .
      TZ=Z0 - Y
      W=Z1 - Y
      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
      SUBROUTINE STEPNX(N,NFE,IFLAG,START,CRASH,HOLD,H,RELERR,
     &   ABSERR,S,Y,YP,YOLD,YPOLD,A,TZ,W,WP,RHOLEN,SSPAR)
C
C  STEPNX  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.  STEPNX  also estimates a
C step size H for the next step along the zero curve.  STEPNX  is an
C expert user version of STEPN(F|S), written using the reverse call
C protocol.  All matrix data structures and numerical linear algebra
C are the responsibility of the calling program.  STEPNX  indicates to
C the calling program, via flags, at which points  RHO(A,LAMBDA,X)  and
C [ D RHO(A,LAMBDA,X)/D LAMBDA, D RHO(A,LAMBDA,X)/DX ]  must be
C evaluated, and what linear algebra must be done with these functions.
C Out of range arguments can also be signaled to  STEPNX , which will
C attempt to modify its steplength algorithm to reflect this
C information.
C
C The following interface block should be inserted in the calling
C program:
C
C     INTERFACE
C       SUBROUTINE STEPNX(N,NFE,IFLAG,START,CRASH,HOLD,H,RELERR,
C    &    ABSERR,S,Y,YP,YOLD,YPOLD,A,TZ,W,WP,RHOLEN,SSPAR)
C       USE HOMOTOPY
C       USE REAL_PRECISION
C       INTEGER, INTENT(IN):: N
C       INTEGER, INTENT(IN OUT):: NFE,IFLAG
C       LOGICAL, INTENT(IN OUT):: START,CRASH
C       REAL (KIND=R8), INTENT(IN OUT):: HOLD,H,RELERR,ABSERR,S,RHOLEN,
C    &    SSPAR(8)
C       REAL (KIND=R8), DIMENSION(:), INTENT(IN):: A
C       REAL (KIND=R8), DIMENSION(:), INTENT(IN OUT):: Y,YP,YOLD,YPOLD,
C    &    TZ,W,WP
C       REAL (KIND=R8), DIMENSION(:), ALLOCATABLE, SAVE:: Z0,Z1
C       END SUBROUTINE STEPNX
C     END INTERFACE
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, on the first
C         call to  STEPNX .  STEPNX  does not distinguish between
C         these values, but they are permitted for consistency with
C         the rest of HOMPACK.
C
C       = 0-10*R, -1-10*R, or -2-10*R, R = 1,2,3, indicate to  STEPNX
C         where to resume after a reverse call.  The calling program
C         must not modify  IFLAG  after a reverse call, except as
C         noted next.
C
C       = -40, -41, or -42, used for a final call to deallocate working
C         storage, after all path tracking is finished.  START  and
C         IFLAG  are reset on return.
C
C       = -100-10*R, -101-10*R, -102-10*R, R = 1,2,3, indicate to
C         STEPNX  where to resume after a reverse call, and that the
C         requested evaluation point was out of range.  STEPNX  will
C         reduce  H  and try again.
C
C START = .TRUE. on first call to  STEPNX , .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  STEPNX .
C    Thereafter  STEPNX  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(:) = parameter vector in the homotopy map.
C
C TZ(1:N+1), W(1:N+1), and WP(1:N+1)  are work arrays used for the
C    Newton step calculation and the interpolation.  On reentry after
C    a reverse call,  WP  and  TZ  contain the tangent vector and
C    Newton step, respectively, at the point  W .  Precisely,
C    D RHO(A,W)/DW WP = 0,  WP^T YP > 0,  ||WP|| = 1,
C    and  TZ  is the minimum norm solution of
C    D RHO(A,W)/DW TZ = - RHO(A,W).
C
C RHOLEN = ||RHO(A,W)||_2 is required by some reverse calls.
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  STEPNX .  Otherwise the input value of  SSPAR(J)  is used.
C    See the comments below in  STEPNX  for more information about
C    these constants.
C
C
C ON OUTPUT:
C
C N  and  A  are unchanged.
C
C NFE  has been updated.
C
C IFLAG  
C    = -22, -21, -20, -32, -31, or -30 requests the calling program to
C      return the unit tangent vector in  WP , the normal flow Newton
C      step in  TZ , and the 2-norm of the homotopy map in  RHOLEN ,
C      all evaluated at the point  W .
C
C    = -12, -11, or -10 requests the calling program to return in  WP
C      the unit tangent vector at  W .
C
C    = -2, -1, or 0 (unchanged) on a normal return after a successful
C      step.
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    = 7 if input arguments or array sizes are invalid, or  IFLAG  was
C        changed during a reverse call.
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  STEPNX  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  STEPNX  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 SSPAR  may have been changed to default values.
C
C
C Z0(1:N+1), Z1(1:N+1)  are allocatable work arrays used for the
C    estimation of the next step size  H .
C
C Calls  DNRM2 .
C
      USE HOMOTOPY
      USE REAL_PRECISION
      INTEGER, INTENT(IN):: N
      INTEGER, INTENT(IN OUT):: NFE,IFLAG
      LOGICAL, INTENT(IN OUT):: START,CRASH
      REAL (KIND=R8), INTENT(IN OUT):: HOLD,H,RELERR,ABSERR,S,RHOLEN,
     &  SSPAR(8)
      REAL (KIND=R8), DIMENSION(:), INTENT(IN):: A
      REAL (KIND=R8), DIMENSION(:), INTENT(IN OUT):: Y,YP,YOLD,YPOLD,
     &  TZ,W,WP
      REAL (KIND=R8), DIMENSION(:), ALLOCATABLE, SAVE:: Z0,Z1
C
C ***** LOCAL VARIABLES. *****
C
      REAL (KIND=R8), SAVE:: DCALC,DELS,F0,F1,FOURU,FP0,FP1,
     &  HFAIL,HT,LCALC,RCALC,TEMP,TWOU
      INTEGER, SAVE:: IFLAGC,ITNUM,J,JUDY,NP1
      LOGICAL, SAVE:: FAIL
C
C ***** END OF SPECIFICATION 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:
      INTEGER, PARAMETER:: LITFH=4
C
C DEFINITION OF HERMITE CUBIC INTERPOLANT VIA DIVIDED DIFFERENCES.
C
      REAL (KIND=R8):: DD001,DD0011,DD01,DD011,DNRM2,QOFS
      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
      NP1=N+1
      IF (IFLAG > 0) RETURN
      IF ((START .AND. IFLAG < -2) .OR. SIZE(Y) /= NP1 .OR.
     &  SIZE(YP) /= NP1 .OR. SIZE(YOLD) /= NP1 .OR.
     &  SIZE(YPOLD) /= NP1 .OR. SIZE(TZ) /= NP1 .OR.
     &  SIZE(W) /= NP1 .OR. SIZE(WP) /= NP1 .OR.
     &  (.NOT. START .AND. -MOD(-IFLAG,100) /= IFLAGC .AND.
     &  ABS(IFLAG)/10 /= 4)) THEN
        IFLAG=7
        RETURN
      ENDIF
      IFLAGC=-MOD(-IFLAG,10)
C
C PICK UP EXECUTION WEHRE IT LEFT OFF AFTER A REVERSE CALL.
C
      IF (IFLAG < -2) THEN
        GO TO (50,100,400,700), MOD(ABS(IFLAG),100)/10
      ENDIF
      TWOU=2.0*EPSILON(1.0_R8)
      FOURU=TWOU+TWOU
      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)+1.0
      IF (.5*(RELERR*TEMP+ABSERR) .LT. TWOU*TEMP) THEN
        IF (RELERR .NE. 0.0) THEN
          RELERR=FOURU*(1.0+FOURU)
          ABSERR=MAX(ABSERR,0.0_R8)
        ELSE
          ABSERR=FOURU*TEMP
        ENDIF
        RETURN
      ENDIF
      CRASH=.FALSE.
      IF (.NOT. START) GO TO 300
C
C *****  STARTUP SECTION (FIRST STEP ALONG ZERO CURVE).  *****
C
      FAIL=.FALSE.
      START=.FALSE.
      IF (ALLOCATED(Z0)) DEALLOCATE(Z0)
      IF (ALLOCATED(Z1)) DEALLOCATE(Z1)
      ALLOCATE(Z0(NP1),Z1(NP1))
C
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)*EPSILON(1.0_R8)
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_R8
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 DETERMINE SUITABLE INITIAL STEP SIZE.
      H=MIN(H, .10_R8, SQRT(SQRT(RELERR*TEMP+ABSERR)))
C USE LINEAR PREDICTOR ALONG TANGENT DIRECTION TO START NEWTON ITERATION.
      YPOLD(1)=1.0
      YPOLD(2:NP1)=0.0
C REQUEST TANGENT VECTOR AT Y VIA REVERSE CALL.
      W=Y
      YP=YPOLD
      IFLAG=IFLAGC-10
      IFLAGC=IFLAG
      NFE=NFE+1
      RETURN
 50   YP=WP
C IF THE STARTING POINT IS OUT OF RANGE, GIVE UP.
      IF (IFLAG .LE. -100) THEN
        IFLAG=6
        RETURN
      ENDIF
 70   W=Y + H*YP
      Z0=W
      JUDY=1                                    ! DO JUDY=1,LITFH
 80   IF (JUDY > LITFH) GO TO 200
C REQUEST THE CALCULATION OF THE NEWTON STEP  TZ  AT THE CURRENT
C POINT  W  VIA REVERSE CALL.
        IFLAG=IFLAGC-20
        IFLAGC=IFLAG
        NFE=NFE+1
        RETURN
100     IF (IFLAG .LE. -100) GO TO 200
C
C TAKE NEWTON STEP AND CHECK CONVERGENCE.
        W=W + TZ
        ITNUM=JUDY
C COMPUTE QUANTITIES USED FOR OPTIMAL STEP SIZE ESTIMATION.
        IF (JUDY .EQ. 1) THEN
          LCALC=DNRM2(NP1,TZ,1)
          RCALC=RHOLEN
          Z1=W
        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
        JUDY=JUDY+1
      GO TO 80                                   ! END DO
C
C NO CONVERGENCE IN  LITFH  ITERATIONS.  REDUCE  H  AND TRY AGAIN.
200   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  STEPNX .
320   DO J=1,NP1
        W(J)=QOFS(YOLD(J),YPOLD(J),Y(J),YP(J),HOLD,HOLD+H)
      END DO
      Z0=W 
C
C ***** END OF PREDICTOR SECTION. *****
C
C ***** CORRECTOR SECTION. *****
C
      JUDY=1                          ! CORRECTOR: DO JUDY=1,LITFH
350   IF (JUDY > LITFH) GO TO 500
C REQUEST THE CALCULATION OF THE NEWTON STEP  TZ  AT THE CURRENT
C POINT  W  VIA REVERSE CALL.
        IFLAG=IFLAGC-30
        IFLAGC=IFLAG
        NFE=NFE+1
        RETURN
400     IF (IFLAG .LE. -100) GO TO 500
C
C TAKE NEWTON STEP AND CHECK CONVERGENCE.
        W=W + TZ
        ITNUM=JUDY
C COMPUTE QUANTITIES USED FOR OPTIMAL STEP SIZE ESTIMATION.
        IF (JUDY .EQ. 1) THEN
          LCALC=DNRM2(NP1,TZ,1)
          RCALC=RHOLEN
          Z1=W
        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
        JUDY=JUDY+1
      GO TO 350                              ! END DO CORRECTOR
C
C NO CONVERGENCE IN  LITFH  ITERATIONS.  RECORD FAILURE AT CALCULATED  H , 
C SAVE THIS STEP SIZE, REDUCE  H  AND TRY AGAIN.
500   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   YPOLD=YP
      YOLD=Y
      Y=W
      YP=WP
      W=Y - YOLD
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 .
      TZ=Z0 - Y
      W=Z1 - Y
      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
      IFLAG=IFLAGC
      RETURN
C CLEAN UP ALLOCATED WORKING STORAGE.
 700  START=.TRUE.
      IFLAG=IFLAGC
      IF (ALLOCATED(Z0)) DEALLOCATE(Z0)
      IF (ALLOCATED(Z1)) DEALLOCATE(Z1)
      RETURN
      END SUBROUTINE STEPNX
      SUBROUTINE STEPQF(N,NFE,IFLAG,START,CRASH,HOLD,H,
     &   WK,RELERR,ABSERR,S,Y,YP,YOLD,YPOLD,A,Q,R,
     &   F0,F1,Z0,DZ,W,T,SSPAR)
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 THE FOLLOWING INTERFACE BLOCK SHOULD BE INCLUDED IN THE CALLING
C PROGRAM:
C
C     INTERFACE
C       SUBROUTINE STEPQF(N,NFE,IFLAG,START,CRASH,HOLD,H,
C    &    WK,RELERR,ABSERR,S,Y,YP,YOLD,YPOLD,A,Q,R,
C    &    F0,F1,Z0,DZ,W,T,SSPAR)
C       USE REAL_PRECISION
C       INTEGER:: N, NFE, IFLAG
C       LOGICAL:: START, CRASH
C       REAL (KIND=R8):: HOLD, H, WK, RELERR, ABSERR, S
C       REAL (KIND=R8):: A(:), DZ(N+1), F0(N+1), F1(N+1), 
C    &    Q(N+1,N+1), R((N+1)*(N+2)/2), SSPAR(4), T(N+1), W(N+1),
C    &    Y(:), YOLD(N+1), YP(N+1), YPOLD(N+1), Z0(N+1)
C       END SUBROUTINE STEPQF
C     END INTERFACE
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(:) = PARAMETER VECTOR IN THE HOMOTOPY MAP.
C
C Q(1:N+1,1:N+1) =  Q  OF THE QR FACTORIZATION OF
C    THE AUGMENTED JACOBIAN MATRIX AT  Y.
C
C R((N+1)*(N+2)/2) = THE UPPER TRIANGLE  R  OF THE QR 
C    FACTORIZATION, STORED BY COLUMNS.
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
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 Q, R  STORE THE QR FACTORIZATION OF THE AUGMENTED JACOBIAN MATRIX 
C     EVALUATED AT  Y.
C
C
C CALLS  DGEMV, DGEQRF, DNRM2, DORGQR, DTPSV, F (OR RHO),
C     FJAC (OR RHOJAC), TANGQF, UPQRQF.
C
C ***** DECLARATIONS *****
      USE HOMOTOPY
      USE REAL_PRECISION
C
C     FUNCTION DECLARATIONS  
C
      INTERFACE
        FUNCTION DNRM2(N,X,STRIDE)
        USE REAL_PRECISION
        INTEGER:: N,STRIDE
        REAL (KIND=R8):: DNRM2,X(N)
        END FUNCTION DNRM2
      END INTERFACE
      REAL (KIND=R8):: DD001, DD0011, DD01, DD011, QOFS
C
C     LOCAL VARIABLES
C
      REAL (KIND=R8):: ALPHA, DELS, ETA, FOURU, GAMMA, HFAIL, HTEMP,
     &  IDLERR, ONE, P0, P1, PP0, PP1, TEMP, TWOU, WKOLD, ZERO         
      INTEGER:: I, ITCNT, LITFH, J, JP1, NP1
      LOGICAL:: FAILED
C
C     SCALAR ARGUMENTS 
C
      INTEGER:: N, NFE, IFLAG
      LOGICAL:: START, CRASH
      REAL (KIND=R8):: HOLD, H, WK, RELERR, ABSERR, S
C
C     ARRAY DECLARATIONS
C
      REAL (KIND=R8):: A(:), DZ(N+1), F0(N+1), F1(N+1), 
     &   Q(N+1,N+1), R((N+1)*(N+2)/2), SSPAR(4), T(N+1), W(N+1),
     &   Y(:), YOLD(N+1), YP(N+1), YPOLD(N+1), Z0(N+1)
C
      SAVE
C
C ***** END OF DECLARATIONS *****
C
      INTERFACE
        SUBROUTINE TANGQF(Y,YP,YPOLD,A,Q,R,W,S,T,N,IFLAG,NFE)
        USE HOMOTOPY
        USE REAL_PRECISION
        INTEGER:: N, IFLAG, NFE
        REAL (KIND=R8):: A(:), Q(N+1,N+1), R((N+1)*(N+2)/2),
     &    S(N+1), T(N+1), W(N+1), Y(:), YP(N+1), YPOLD(N+1)
        END SUBROUTINE TANGQF
      END INTERFACE
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
      ZERO = 0.0
      TWOU = 2.0*EPSILON(1.0_R8)
      FOURU = TWOU + TWOU
      NP1 = N+1
      FAILED = .FALSE.
      CRASH = .TRUE.
      ETA = 50.0*TWOU
      LITFH = 2*(INT(ABS(LOG10(ABSERR+RELERR)))+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,Q,R,W,DZ,T,N,IFLAG,NFE)
        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:NP1),F0(1:N))
      ELSE IF (IFLAG .EQ. -1) THEN
C
C ZERO FINDING PROBLEM.
C
        CALL F(Y(2:NP1),F0(1:N))
        F0(1:N) = Y(1)*F0(1:N) + (1.0-Y(1))*(Y(2:NP1)-A(1:N))
      ELSE
C
C FIXED POINT PROBLEM.
C
        CALL F(Y(2:NP1),F0(1:N))
        F0(1:N) = Y(1)*(A(1:N)-F0(1:N))+Y(2:NP1)-A(1:N)
      END IF
C
C DEFINE LAST ROW OF F0  =  YP*Y.
C
       F0(NP1) = DOT_PRODUCT(YP,Y)
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
        Z0 = Y + H*YP
C         
      ELSE
C
C COMPUTE Z0 WITH CUBIC PREDICTOR.
C
        DO I=1,NP1
          Z0(I) = QOFS(YOLD(I),YPOLD(I),Y(I),YP(I),HOLD,HOLD+H) 
        END DO
C
      END IF
C
C F1 = (RHO(Z0), YP*Z0) TRANSPOSE.
C
      IF (IFLAG .EQ. -2) THEN
        CALL RHO(A,Z0(1),Z0(2:NP1),F1(1:N))
      ELSE IF (IFLAG .EQ. -1) THEN
        CALL F(Z0(2:NP1),F1(1:N))
        F1(1:N) = Z0(1)*F1(1:N) + (1.0-Z0(1))*(Z0(2:NP1)-A(1:N))
      ELSE
        CALL F(Z0(2:NP1),F1(1:N))
        F1(1:N) = Z0(1)*(A(1:N)-F1(1:N))+Z0(2:NP1)-A(1:N)
      END IF
      F1(NP1) = DOT_PRODUCT(YP,Z0)
C
C ***** END OF PREDICTOR SECTION *****
C
C ***** SET-UP FOR QUASI-NEWTON ITERATION *****
C
      IF (FAILED) THEN
C        
C GENERATE Q = 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 J = 1,NP1
            CALL RHOJAC(A,Z0(1),Z0(2:NP1),Q(1:N,J),J)
          END DO
        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:NP1),Q(1:N,1))
          Q(1:N,1) = A - Z0(2:NP1) + Q(1:N,1)
          DO J= 1,N
            JP1 = J+1
            CALL FJAC(Z0(2:NP1),Q(1:N,JP1),J)
            Q(1:N,JP1) = Z0(1)*Q(1:N,JP1)
            Q(J,JP1) = 1.0 - Z0(1) + Q(J,JP1)
          END DO
        ELSE 
C 
C FIXED POINT PROBLEM:
C D(RHO) = (A - F(X), I - LAMBDA*DF(X)).
C
          CALL F(Z0(2:NP1),Q(1:N,1))
          Q(1:N,1) = A - Q(1:N,1)
          DO J=1,N
            JP1 = J+1
            CALL FJAC(Z0(2:NP1),Q(1:N,JP1),J)
            Q(1:N,JP1) = -Z0(1)*Q(1:N,JP1)
            Q(J,JP1) = 1.0 + Q(J,JP1)
          END DO
        END IF
C
C DEFINE LAST ROW OF Q = YP.
C
        Q(NP1,:) = YP
C
C COUNT JACOBIAN EVALUATION.
C
        NFE = NFE+1
C
C DO FIRST QUASI-NEWTON STEP.
C
C FACTOR AUG.
C
        CALL DGEQRF(NP1,NP1,Q,NP1,T,W,NP1,I)
C
C PACK UPPER TRIANGLE INTO ARRAY R.
C
        DO I=1,NP1
          R((I*(I-1))/2 + 1:(I*(I-1))/2 + I) = Q(1:I,I)
        END DO
C
C CHECK FOR SINGULARITY.
C
        J = 1
        DO I = 1, N
          IF( R(J+I-1) .EQ. ZERO ) THEN
            IFLAG = 4
            RETURN
          END IF
          J = J + I
        END DO
C
C EXPAND HOUSEHOLDER REFLECTIONS INTO FULL MATRIX Q .
C
        CALL DORGQR(NP1, NP1, N, Q, NP1, T, W, NP1, I)
C
C COMPUTE NEWTON STEP.
C
        T(1:N) = -F1(1:N)
        T(NP1) = 0.0
        CALL DGEMV('T',NP1,NP1,ONE,Q,NP1,T,1,ZERO,DZ,1)
        CALL DTPSV('U', 'N', 'N', NP1, R, DZ, 1)
C
C TAKE STEP AND SET F0 = F1.
C
        Z0 = Z0 + DZ
        F0 = F1
C
C F1 = (RHO(Z0), YP*Z0) TRANSPOSE.
C
        IF (IFLAG .EQ. -2) THEN
          CALL RHO(A,Z0(1),Z0(2:NP1),F1(1:N))
        ELSE IF (IFLAG .EQ. -1) THEN
          CALL F(Z0(2:NP1),F1(1:N))
          F1(1:N) = Z0(1)*F1(1:N) + (1.0-Z0(1))*(Z0(2:NP1)-A(1:N))
        ELSE
          CALL F(Z0(2:NP1),F1(1:N))
          F1(1:N) = Z0(1)*(A(1:N)-F1(1:N))+Z0(2:NP1)-A(1:N)
        END IF
        F1(NP1) = DOT_PRODUCT(YP,Z0)
C
      ELSE
C
C IF NOT FAILED THEN DEFINE  DZ=Z0-Y  PRIOR TO MAIN LOOP.
C
        DZ = Z0 - Y
      END IF
C
C ***** END OF PREPARATION FOR QUASI-NEWTON ITERATION *****
C
      DO ITCNT = 1,LITFH  ! ***** QUASI-NEWTON ITERATION *****
C
C PERFORM UPDATE FOR NEWTON STEP JUST TAKEN.
C
        CALL UPQRQF(NP1,ETA,DZ,F0,F1,Q,R,W,T)
C
C COMPUTE NEXT NEWTON STEP.
C
        T(1:N) = -F1(1:N)
        T(NP1) = 0.0
        CALL DGEMV('T',NP1,NP1,ONE,Q,NP1,T,1,ZERO,DZ,1)
        CALL DTPSV('U', 'N', 'N', NP1, R, DZ, 1)
C
C TAKE STEP.
C
        Z0 = Z0 + DZ
C
C CHECK FOR CONVERGENCE.
C
        IF (DNRM2(NP1,DZ,1) .LE. RELERR*DNRM2(NP1,Z0,1)+ABSERR) THEN
           GO TO 180
        END IF
C
C IF NOT CONVERGED, PREPARE FOR NEXT ITERATION.
C
        F0 = F1
C
C F1 = (RHO(Z0), YP*Z0) TRANSPOSE.
C
        IF (IFLAG .EQ. -2) THEN
          CALL RHO(A,Z0(1),Z0(2:NP1),F1(1:N))
        ELSE IF (IFLAG .EQ. -1) THEN
          CALL F(Z0(2:NP1),F1(1:N))
          F1(1:N) = Z0(1)*F1(1:N) + (1.0-Z0(1))*(Z0(2:NP1)-A(1:N))
        ELSE
          CALL F(Z0(2:NP1),F1(1:N))
          F1(1:N) = Z0(1)*(A(1:N)-F1(1:N))+Z0(2:NP1)-A(1:N)
        END IF
        F1(NP1) = DOT_PRODUCT(YP,Z0)
C
      END DO  ! ***** 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      
 170  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
 180  CALL TANGQF(Z0,T,YP,A,Q,R,W,DZ,F1,N,IFLAG,NFE)
      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 = DOT_PRODUCT(T,YP)
      IF (ALPHA .LT. 0.5) GOTO 170
      ALPHA = ACOS(ALPHA)
C
C SET UP VARIABLES FOR NEXT CALL.
C
      YOLD = Y
      Y = Z0
      YPOLD = YP
      YP = T
C
C UPDATE ARCLENGTH   S = S + ||Y-YOLD||.
C
      HTEMP = HOLD
      Z0 = Z0 - YOLD
      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
      IF (.NOT. START) 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
      END SUBROUTINE STEPQF
      SUBROUTINE STEPQS(N,NFE,IFLAG,MODE,LENQR,START,CRASH,HOLD,H,
     &  WK,RELERR,ABSERR,S,Y,YP,YOLD,YPOLD,A,Z0,DZ,T,SSPAR)
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.  SEE ALSO THE REVERSE CALL ROUTINE  STEPNX .
C 
C THE CALLING PROGRAM MUST CONTAIN THE FOLLOWING INTERFACE BLOCK:
C
C     INTERFACE
C       SUBROUTINE STEPQS(N,NFE,IFLAG,MODE,LENQR,START,CRASH,HOLD,H,
C    &    WK,RELERR,ABSERR,S,Y,YP,YOLD,YPOLD,A,Z0,DZ,T,SSPAR)
C       USE REAL_PRECISION
C       INTEGER, INTENT(IN):: LENQR,MODE,N
C       INTEGER, INTENT(IN OUT):: IFLAG,NFE
C       LOGICAL, INTENT(IN OUT):: CRASH,START
C       REAL (KIND=R8), INTENT(IN):: A(:),SSPAR(4)
C       REAL (KIND=R8), INTENT(IN OUT):: ABSERR,H,HOLD,RELERR,S,WK,
C    &    Y(:),YOLD(:),YP(:),YPOLD(:)
C       REAL (KIND=R8), INTENT(OUT), DIMENSION(:):: DZ,T,Z0
C       END SUBROUTINE STEPQS
C     END INTERFACE
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 MODE = 1 IF THE JACOBIAN MATRIX IS SYMMETRIC AND STORED IN A PACKED
C          SKYLINE FORMAT;
C      = 2 IF THE JACOBIAN MATRIX IS STORED IN A SPARSE ROW FORMAT.
C
C LENQR  IS THE NUMBER OF NONZERO ENTRIES IN THE SPARSE JACOBIAN
C    MATRICES, USED TO DETERMINE THE SPARSE MATRIX DATA STRUCTURES.
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(:) = PARAMETER VECTOR IN THE HOMOTOPY MAP.
C
C QR(1:LENQR), PP(1:N), ROWPOS(1:N+2), COLPOS(1:LENQR) ARE ALL WORK
C    ARRAYS USED TO DEFINE THE SPARSE JACOBIAN MATRICES, ALLOCATED
C    IN FIXPQS, AND DISTRIBUTED VIA THE MODULE  HOMOTOPY .
C
C Z0(1:N+1), DZ(1:N+1), T(1:N+1)  ARE ALL WORK ARRAYS USED TO
C    CALCULATE THE TANGENT VECTORS AND NEWTON STEPS.
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
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  DNRM2, TANGNS.
C
      USE REAL_PRECISION
      INTEGER, INTENT(IN):: LENQR,MODE,N
      INTEGER, INTENT(IN OUT):: IFLAG,NFE
      LOGICAL, INTENT(IN OUT):: CRASH,START
      REAL (KIND=R8), INTENT(IN):: A(:),SSPAR(4)
      REAL (KIND=R8), INTENT(IN OUT):: ABSERR,H,HOLD,RELERR,S,WK,
     &    Y(:),YOLD(:),YP(:),YPOLD(:)
      REAL (KIND=R8), INTENT(OUT), DIMENSION(:):: DZ,T,Z0
C
C     FUNCTION DECLARATIONS.  
C
      INTERFACE
        FUNCTION DNRM2(N,X,STRIDE)
        USE REAL_PRECISION
        INTEGER:: N,STRIDE
        REAL (KIND=R8):: DNRM2,X(N)
        END FUNCTION DNRM2
      END INTERFACE
      REAL (KIND=R8):: DD001,DD0011,DD01,DD011,QOFS
C
C     LOCAL VARIABLES.
C
      REAL (KIND=R8), SAVE:: ACOF(12), ALPHA, CORDIS, DELS, FOURU,
     &  GAMMA, HFAIL, HTEMP, IDLERR, OMEGA, P0, P1, PP0, PP1, 
     &  SIGMA, TEMP, THETA, TWOU, WKOLD, WRGE(8), XSTEP
      INTEGER:: I, ITCNT, LK, LST, NP1
      LOGICAL:: FAILED
      DATA WRGE  /
     &   .8735115E+00_R8, .1531947E+00_R8, .3191815E-01_R8,
     &   .3339946E-10_R8, .4677788E+00_R8, .6970123E-03_R8,
     &   .1980863E-05_R8, .1122789E-08_R8/
      DATA ACOF  /
     &   .9043128E+00_R8, -.7075675E+00_R8, -.4667383E+01_R8,
     &  -.3677482E+01_R8,  .8516099E+00_R8, -.1953119E+00_R8,
     &  -.4830636E+01_R8, -.9770528E+00_R8,  .1040061E+01_R8,
     &   .3793395E-01_R8,  .1042177E+01_R8,  .4450706E-01_R8/
C
      INTERFACE
        SUBROUTINE TANGNS(RHOLEN,Y,YP,TZ,YPOLD,A,MODE,LENQR,
     &    NFE,N,IFLAG)
        USE REAL_PRECISION
        REAL (KIND=R8), INTENT(IN), DIMENSION(:):: A,Y,YPOLD
        REAL (KIND=R8), INTENT(IN OUT):: RHOLEN
        REAL (KIND=R8), INTENT(OUT), DIMENSION(:):: TZ,YP
        INTEGER, INTENT(IN):: LENQR,MODE,N
        INTEGER, INTENT(IN OUT):: IFLAG,NFE
        END SUBROUTINE TANGNS
      END INTERFACE
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:
      INTEGER, PARAMETER:: LITFH = 10
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 ***** END OF SPECIFICATION SECTION. *****
C
C ***** INITIALIZATION. *****
C
      TWOU = 2.0*EPSILON(1.0_R8)
      FOURU = TWOU + TWOU
      NP1 = N+1
      FAILED = .FALSE.
      CRASH = .TRUE.
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
          CALL TANGNS(S,Y,YP,DZ,YPOLD,A,MODE,LENQR,NFE,N,IFLAG)
          IF (IFLAG .GT. 0) RETURN
      END IF
C
      CONV: DO
C
C ***** COMPUTE PREDICTOR POINT Z0. *****
C
        IF (START) THEN
C           
C         COMPUTE Z0 WITH LINEAR PREDICTOR USING Y, YP --
C         
          Z0 = Y + H*YP
        ELSE
C
C         COMPUTE Z0 WITH CUBIC PREDICTOR.
C
          DO I=1,NP1
            Z0(I) = QOFS(YOLD(I),YPOLD(I),Y(I),YP(I),HOLD,HOLD+H) 
          END DO
        END IF
C
C ***** END OF PREDICTOR SECTION. *****
C
        NEWTON: DO ITCNT = 1,LITFH   ! ***** NEWTON ITERATION. *****
C
C COMPUTE TANGENT  T  AND MINIMUM NORM NEWTON STEP  DZ  AT THE
C CURRENT POINT  Z0 .
C
          TEMP = -1.0
          CALL TANGNS(TEMP,Z0,T,DZ,YP,A,MODE,LENQR,NFE,N,IFLAG)
          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 = DOT_PRODUCT(T,YP)
          IF (ALPHA < 0.5) EXIT NEWTON
C
C MAKE  DZ  ORTHOGONAL TO TANGENT DIRECTION  YP .
C
          SIGMA = -DOT_PRODUCT(DZ,YP)/DOT_PRODUCT(T,YP)
          DZ = DZ + SIGMA*T
C
C TAKE NEWTON STEP.
C
          Z0 = Z0 + DZ
C
C CHECK FOR CONVERGENCE.
C
          XSTEP=DNRM2(NP1,DZ,1)
          IF (XSTEP .LE. RELERR*DNRM2(NP1,Z0,1)+ABSERR) EXIT CONV
C
        END DO NEWTON   ! ***** 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      
        FAILED = .TRUE.
        HFAIL = H
        IF (H .LE. FOURU*(1.0 + S)) THEN
          IFLAG = 6
          RETURN
        ELSE
          H = .5 * H
        END IF
C
C END OF CONVERGENCE FAILURE SECTION.
C
      END DO CONV
C
C ***** CONVERGED -- MOP UP AND RETURN. *****
C
C COMPUTE TANGENT  T  AT  Z0 .
C
      CALL TANGNS(S,Z0,T,DZ,YP,A,MODE,LENQR,NFE,N,IFLAG)
      IF (IFLAG .GT. 0) RETURN
      ALPHA = DOT_PRODUCT(T,YP)
      ALPHA = ACOS(ALPHA)
C
C COMPUTE CORRECTOR DISTANCE.
C
      IF (START) THEN
        DZ = Y + H*YP
      ELSE
        DO I=1,NP1
          DZ(I)=QOFS(YOLD(I),YPOLD(I),Y(I),YP(I),HOLD,HOLD+H)
        END DO
      ENDIF
      DZ = DZ - Z0
      CORDIS = DNRM2(NP1,DZ,1)
C
C SET UP VARIABLES FOR NEXT CALL.
C
      YOLD = Y
      Y = Z0
      YPOLD = YP
      YP = T
C
C UPDATE ARCLENGTH   S = S + ||Y-YOLD||.
C
      HTEMP = HOLD
      Z0 = Z0 - YOLD
      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
      IF (.NOT. START) 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_R8)
      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
      END SUBROUTINE STEPQS
      SUBROUTINE STEPS(FODE,NEQN,Y,X,H,EPS,WT,START,HOLD,K,KOLD,CRASH,
     &  PHI,P,YP,ALPHA,W,G,KSTEPS,XOLD,IVC,IV,KGI,GI, 
     &  FPWA1,FPWA2,FPWA3,FPWA4,FPWA5,IFPWA1,IFPC1,IFPC2)
C 
C   FORTRAN 90 MODIFICATION OF THE SUBROUTINE  STEP  WRITTEN BY
C   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      FODE -- 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.
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(3*NEQN),
C    3  FPWA5(NEQN),IFPWA1(NEQN)
C                              --                --    **NOTE** 
C 
C   THE USER MUST ALSO DECLARE  START  AND  CRASH 
C   LOGICAL VARIABLES AND  FODE  AN EXTERNAL SUBROUTINE, SUPPLY THE
C   SUBROUTINE  FODE(X,Y,YP,FPWA1,FPWA2,FPWA3,FPWA4,FPWA5,IFPWA1,IFPC1,
C                 NEQN-1,IFPC2) 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 INTRINSIC FUNCTION  EPSILON(1.0_R8), 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 
      USE REAL_PRECISION
      REAL (KIND=R8):: ABSH,ALPHA,BETA,EPS,ERK,ERKM1,ERKM2,
     &  ERKP1,ERR,FOURU,FPWA1,FPWA2,FPWA3,FPWA4,FPWA5,G,GI,GSTR,H,
     &  HNEW,HOLD,P,P5EPS,PHI,PSI,R,REALI,REALNS,RHO,ROUND,SIG,
     &  SUM,TAU,TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,TEMP6,TWO,TWOU,V,
     &  W,WT,X,XOLD,Y,YP
      INTEGER I,IFAIL,IFPC1,IFPC2,IFPWA1,IM1,IP1,IQ,IV,IVC,
     &  J,JV,K,KGI,KM1,KM2,KNEW,KOLD,KP1,KP2,KPREV,KSTEPS,
     &  L,LIMIT1,LIMIT2,NEQN,NS,NSM2,NSP1,NSP2
      LOGICAL START,CRASH,PHASE1,NORND
C
      DIMENSION Y(:),WT(NEQN),PHI(NEQN,16),P(NEQN),YP(NEQN),PSI(12), 
     &  ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13),GI(11),IV(10), 
     &  FPWA1(NEQN),FPWA2(:),FPWA3(NEQN-1,NEQN),FPWA4(3*NEQN),
     &  FPWA5(NEQN),IFPWA1(NEQN)
      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
      INTERFACE
        SUBROUTINE FODE(S,Y,YP,YPOLD,A,QR,ALPHA,TZ,PIVOT,NFE,N,IFLAG)
        USE REAL_PRECISION
        REAL (KIND=R8):: S
        INTEGER:: IFLAG,N,NFE
        REAL (KIND=R8):: A(:),Y(:),YP(N+1),YPOLD(N+1)
        REAL (KIND=R8):: ALPHA(3*N+3),QR(N,N+1),TZ(N+1)
        INTEGER, DIMENSION(N+1):: PIVOT
        END SUBROUTINE FODE
      END INTERFACE
C
      DATA TWO /2.0_R8, 4.0_R8, 8.0_R8, 16.0_R8, 32.0_R8, 64.0_R8,
     &  128.0_R8, 256.0_R8, 512.0_R8, 1024.0_R8, 2048.0_R8,
     &  4096.0_R8, 8192.0_R8/
      DATA GSTR /0.500_R8, 0.0833_R8, 0.0417_R8, 0.0264_R8,
     &  0.0188_R8, 0.0143_R8, 0.0114_R8, 0.00936_R8, 0.00789_R8,
     &  0.00679_R8, 0.00592_R8, 0.00524_R8, 0.00468_R8/
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 * EPSILON(1.0_R8)
      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 L = 1,NEQN
        ROUND = ROUND + (Y(L)/WT(L))**2 
      END DO
      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 FODE(X,Y,YP,FPWA1,FPWA2,FPWA3,FPWA4,FPWA5,IFPWA1,
     &       IFPC1,NEQN-1,IFPC2)
      IF (IFPC2 .GT. 0) RETURN
      SUM = 0.0 
      DO L = 1,NEQN
        PHI(L,1) = YP(L)
        PHI(L,2) = 0.0
        SUM = SUM + (YP(L)/WT(L))**2
      END DO
      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 L = 1,NEQN
        PHI(L,15) = 0.0 
      END DO
 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 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 
        SIG(I+1) = REALI*ALPHA(I)*SIG(I)
      END DO
 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 IQ = 1,K 
        TEMP3 = IQ*(IQ+1) 
        V(IQ) = 1.0/TEMP3 
        W(IQ) = V(IQ) 
      END DO
      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 J = JV,NSM2
        I = K-J 
        V(I) = V(I) - ALPHA(J+1)*V(I+1) 
        W(I) = V(I) 
      END DO
      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 IQ = 1,LIMIT1
        V(IQ) = V(IQ) - TEMP5*V(IQ+1) 
        W(IQ) = V(IQ) 
      END DO
      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 I = NSP2,KP1 
        LIMIT2 = KP2 - I
        TEMP6 = ALPHA(I-1)
        DO IQ = 1,LIMIT2
          W(IQ) = W(IQ) - TEMP6*W(IQ+1) 
        END DO
        G(I) = W(1) 
      END DO
 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 I = NSP1,K 
        TEMP1 = BETA(I) 
        DO L = 1,NEQN 
          PHI(L,I) = TEMP1*PHI(L,I) 
        END DO
      END DO
C 
C   PREDICT SOLUTION AND DIFFERENCES
C 
 215  DO L = 1,NEQN 
        PHI(L,KP2) = PHI(L,KP1) 
        PHI(L,KP1) = 0.0
        P(L) = 0.0
      END DO
      DO J = 1,K
        I = KP1 - J 
        IP1 = I+1 
        TEMP2 = G(I)
        DO L = 1,NEQN 
          P(L) = P(L) + TEMP2*PHI(L,I)
          PHI(L,I) = PHI(L,I) + PHI(L,IP1)
        END DO
      END DO
      IF(NORND) GO TO 240 
      DO L = 1,NEQN 
        TAU = H*P(L) - PHI(L,15)
        P(L) = Y(L) + TAU 
        PHI(L,16) = (P(L) - Y(L)) - TAU 
      END DO
      GO TO 250 
 240  DO L = 1,NEQN 
        P(L) = Y(L) + H*P(L)
      END DO
 250  XOLD = X
      X = X + H 
      ABSH = ABS(H) 
      CALL FODE(X,P,YP,FPWA1,FPWA2,FPWA3,FPWA4,FPWA5,IFPWA1,
     &       IFPC1,NEQN-1,IFPC2)
      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 L = 1,NEQN 
        TEMP3 = 1.0/WT(L) 
        TEMP4 = YP(L) - PHI(L,1)
        IF (KM2 .GT. 0) ERKM2 = ERKM2 + ((PHI(L,KM1)+TEMP4)*TEMP3)**2
        IF (KM2 .GE. 0) ERKM1 = ERKM1 + ((PHI(L,K)+TEMP4)*TEMP3)**2 
        ERK = ERK + (TEMP4*TEMP3)**2
      END DO
      IF (KM2 .GT. 0) ERKM2 = ABSH*SIG(KM1)*GSTR(KM2)*SQRT(ERKM2) 
      IF (KM2 .GE. 0) ERKM1 = ABSH*SIG(K)*GSTR(KM1)*SQRT(ERKM1) 
      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 > 0) THEN
        IF(MAX(ERKM1,ERKM2) .LE. ERK) KNEW = KM1
      ELSE IF (KM2 == 0) THEN
        IF(ERKM1 .LE. 0.5*ERK) KNEW = KM1 
      ENDIF
C 
C   TEST IF STEP SUCCESSFUL 
C 
      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 I = 1,K
        TEMP1 = 1.0/BETA(I) 
        IP1 = I+1 
        DO L = 1,NEQN 
          PHI(L,I) = TEMP1*(PHI(L,I) - PHI(L,IP1))
        END DO
      END DO
      IF(K .LT. 2) GO TO 320
      DO I = 2,K
        PSI(I-1) = PSI(I) - H 
      END DO
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 .GT. 0) THEN
        IF(P5EPS .LT. 0.25*ERK) TEMP2 = SQRT(P5EPS/ERK) 
      ENDIF
      IF (IFAIL-3 .GE. 0) KNEW = 1
      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) THEN
        DO L = 1,NEQN 
          TEMP3 = Y(L)
          Y(L) = P(L) + TEMP1*(YP(L) - PHI(L,1))
          P(L) = TEMP3
        END DO
      ELSE
        DO 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 
          P(L) = TEMP3
        END DO
      ENDIF
      CALL FODE(X,Y,YP,FPWA1,FPWA2,FPWA3,FPWA4,FPWA5,IFPWA1,
     &       IFPC1,NEQN-1,IFPC2)
      IF (IFPC2 .GT. 0) RETURN
C 
C   UPDATE DIFFERENCES FOR NEXT STEP
C 
      DO L = 1,NEQN 
        PHI(L,KP1) = YP(L) - PHI(L,1) 
        PHI(L,KP2) = PHI(L,KP1) - PHI(L,KP2)
      END DO
      DO I = 1,K
        DO L = 1,NEQN 
          PHI(L,I) = PHI(L,I) + PHI(L,KP1)
        END DO
      END DO
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 L = 1,NEQN 
        ERKP1 = ERKP1 + (PHI(L,KP2)/WT(L))**2 
      END DO
      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.5_R8,MIN(0.9_R8,R)) 
      HNEW = SIGN(MAX(HNEW,FOURU*ABS(X)),H) 
 465  H = HNEW
      RETURN
C       ***     END BLOCK 4     *** 
      END SUBROUTINE STEPS
      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  POLSYS1H .
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(1:2*N)  IS INITIALIZED TO THE START VALUES FOR THE CURRENT PATH,
C   WITH X(2*J-1) AND X(2*J) THE REAL AND IMAGINARY PARTS OF THE 
C   J-TH VARIABLE, RESPECTIVELY.
C
C FUNCTIONS USED:  ATAN, COS, SIN.
C
      USE REAL_PRECISION
C DECLARATION OF INPUT AND OUTPUT:
      INTEGER:: N,ICOUNT(N),IDEG(N)
      REAL (KIND=R8):: R(2,N),X(2*N)
C
C DECLARATION OF LOCAL VARIABLES:
      INTEGER:: J
      REAL (KIND=R8):: ANGLE,TWOPI
      COMPLEX (KIND=R8):: XXXX
C
      DO J=1,N
        IF (ICOUNT(J) .GE. IDEG(J)) THEN
          ICOUNT(J)=1
        ELSE
          ICOUNT(J)=ICOUNT(J)+1
          EXIT
        END IF
      END DO
      TWOPI = 8.0_R8*ATAN(1.0_R8)
      DO J=1,N
        ANGLE = ( TWOPI/IDEG(J) )*ICOUNT(J)
        XXXX = CMPLX(COS(ANGLE),SIN(ANGLE),KIND=R8)*
     &        CMPLX(R(1,J),R(2,J),KIND=R8)
        X(2*J-1) = REAL(XXXX)
        X(2*J) = AIMAG(XXXX)
      END DO
      RETURN
      END SUBROUTINE STRPTP
      SUBROUTINE TANGNF(RHOLEN,Y,YP,YPOLD,A,QR,ALPHA,TZ,PIVOT,
     &   NFE,N,IFLAG)
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 THE FOLLOWING INTERFACE BLOCK SHOULD BE INCLUDED IN THE CALLING
C PROGRAM:
C
C     INTERFACE
C       SUBROUTINE TANGNF(RHOLEN,Y,YP,YPOLD,A,QR,ALPHA,TZ,PIVOT,
C    &    NFE,N,IFLAG)
C       USE REAL_PRECISION
C       REAL (KIND=R8):: RHOLEN
C       INTEGER:: IFLAG,N,NFE
C       REAL (KIND=R8):: A(:),Y(:),YP(N+1),YPOLD(N+1)
C       REAL (KIND=R8):: ALPHA(3*N+3),QR(N,N+2),TZ(N+1)
C       INTEGER:: PIVOT(N+1)
C       END SUBROUTINE TANGNF
C     END INTERFACE
C
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(:) = PARAMETER VECTOR IN THE HOMOTOPY MAP.
C
C QR(1:N,1:N+2), ALPHA(1:3*N+3), TZ(1:N+1), PIVOT(1:N+1)  ARE WORK
C    ARRAYS 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
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  DGEQPF , DNRM2 , DORMQR , F (OR  RHO ), FJAC (OR  RHOJAC ).
C
      USE HOMOTOPY
      USE REAL_PRECISION
      REAL (KIND=R8):: LAMBDA,RHOLEN,SIGMA,YPNORM
      INTEGER:: I,IFLAG,J,K,KP1,N,NFE,NP1,NP2
      INTERFACE
        FUNCTION DNRM2(N,X,STRIDE)
        USE REAL_PRECISION
        INTEGER:: N,STRIDE
        REAL (KIND=R8):: DNRM2,X(N)
        END FUNCTION DNRM2
      END INTERFACE
C
C *****  ARRAY DECLARATIONS.  *****
C
      REAL (KIND=R8):: A(:),Y(:),YP(N+1),YPOLD(N+1)
C
C ARRAYS AND FLAG FOR COMPUTING THE JACOBIAN MATRIX AND ITS KERNEL.
      REAL (KIND=R8):: ALPHA(3*N+3),QR(N,N+2),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 K=1,NP1
          CALL RHOJAC(A,LAMBDA,Y(2:NP1),QR(:,K),K)
        END DO
        CALL RHO(A,LAMBDA,Y(2:NP1),QR(:,NP2))
      ELSE
        CALL F(Y(2:NP1),TZ(1:N))
        IF (IFLAG .EQ. 0) THEN
C
C      QR = ( A - F(X), I - LAMBDA*DF(X) ,
C                                 X - A + LAMBDA*(A - F(X)) )  .
C
          QR(:,1)=A - TZ(1:N)
          QR(:,NP2)=Y(2:NP1) - A + LAMBDA*QR(:,1)
          DO K=1,N
            CALL FJAC(Y(2:NP1),TZ(1:N),K)
            KP1=K+1
            QR(:,KP1)=-LAMBDA*TZ(1:N)
            QR(K,KP1)=1.0+QR(K,KP1)
          END DO
        ELSE
C
C   QR = ( F(X) - X + A, LAMBDA*DF(X) + (1 - LAMBDA)*I ,
C                                  X - A + LAMBDA*(F(X) - X + A) )  .
C
          QR(:,1)=TZ(1:N) - Y(2:NP1) + A
          QR(:,NP2)=Y(2:NP1) - A + LAMBDA*QR(:,1)
          DO K=1,N
            CALL FJAC(Y(2:NP1),TZ(1:N),K)
            KP1=K+1
            QR(:,KP1)=LAMBDA*TZ(1:N)
            QR(K,KP1)=1.0-LAMBDA+QR(K,KP1)
          END DO
        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(:,NP2),1)
C
C REDUCE THE JACOBIAN MATRIX TO UPPER TRIANGULAR FORM.
C
      PIVOT = 0
C
      CALL DGEQPF(N,NP1,QR,N,PIVOT,YP,ALPHA,K)
C
      IF (ABS(QR(N,N)) .LE. ABS(QR(1,1))*EPSILON(1.0_R8)) THEN 
        IFLAG=4
        RETURN
      ENDIF
C
      CALL DORMQR('L','T',N,1,N,QR,N,YP,QR(:,NP2),N,
     &           ALPHA,3*N+3,K)
C
      DO I=1,N
        ALPHA(I)=QR(I,I)
      END DO
C
C COMPUTE KERNEL OF JACOBIAN, WHICH SPECIFIES YP=DY/DS.
      TZ(NP1)=1.0
      DO I=N,1,-1
        J=I+1
        TZ(I)=-DOT_PRODUCT(QR(I,J:NP1),TZ(J:NP1))/ALPHA(I)
      END DO
      YPNORM=DNRM2(NP1,TZ,1)
      YP(PIVOT)=TZ/YPNORM
      IF (DOT_PRODUCT(YP,YPOLD) .LT. 0.0) YP = -YP
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
      ALPHA(NP1)=1.0
      DO I=N,1,-1
        J=I+1
        ALPHA(I)=-(DOT_PRODUCT(QR(I,J:NP1),ALPHA(J:NP1)) + QR(I,NP2))
     &          /ALPHA(I)
      END DO
      TZ(PIVOT)=ALPHA(1:NP1)
C TZ NOW CONTAINS A PARTICULAR SOLUTION P, AND YP CONTAINS A VECTOR Q
C IN THE KERNEL(THE TANGENT).
      SIGMA=DOT_PRODUCT(TZ,YP)
      TZ=TZ - SIGMA*YP
C TZ IS THE NEWTON STEP FROM THE CURRENT POINT Y(S) = (LAMBDA(S), X(S)).
      RETURN
      END SUBROUTINE TANGNF
      SUBROUTINE TANGNS(RHOLEN,Y,YP,TZ,YPOLD,A,MODE,LENQR,NFE,N,IFLAG)
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 THE CALLING PROGRAM MUST CONTAIN THE FOLLOWING INTERFACE BLOCK:
C
C     INTERFACE
C       SUBROUTINE TANGNS(RHOLEN,Y,YP,TZ,YPOLD,A,MODE,LENQR,
C    &    NFE,N,IFLAG)
C       USE HOMOTOPY, QR => QRSPARSE
C       USE REAL_PRECISION
C       REAL (KIND=R8), INTENT(IN), DIMENSION(:):: A,Y,YPOLD
C       REAL (KIND=R8), INTENT(IN OUT):: RHOLEN
C       REAL (KIND=R8), INTENT(OUT), DIMENSION(:):: TZ,YP
C       INTEGER, INTENT(IN):: LENQR,MODE,N
C       INTEGER, INTENT(IN OUT):: IFLAG,NFE
C       END SUBROUTINE TANGNS
C     END INTERFACE
C
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(:) = PARAMETER VECTOR IN THE HOMOTOPY MAP.
C
C MODE = 1 IF THE JACOBIAN MATRIX IS SYMMETRIC AND STORED IN A PACKED
C          SKYLINE FORMAT;
C      = 2 IF THE JACOBIAN MATRIX IS STORED IN A SPARSE ROW FORMAT.
C
C LENQR  IS THE NUMBER OF NONZERO ENTRIES IN THE SPARSE JACOBIAN
C    MATRICES, USED TO DETERMINE THE SPARSE MATRIX DATA STRUCTURES.
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
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)) .  THE NEWTON STEP IS
C    CALCULATED ONLY IF RHOLEN < 0 ON INPUT.
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 , GMRILUDS , AND THE
C    BLAS ROUTINE  DNRM2 .
C
        USE HOMOTOPY, QR => QRSPARSE
        USE REAL_PRECISION
        REAL (KIND=R8), INTENT(IN), DIMENSION(:):: A,Y,YPOLD
        REAL (KIND=R8), INTENT(IN OUT):: RHOLEN
        REAL (KIND=R8), INTENT(OUT), DIMENSION(:):: TZ,YP
        INTEGER, INTENT(IN):: LENQR,MODE,N
        INTEGER, INTENT(IN OUT):: IFLAG,NFE
C
C ***** LOCAL VARIABLES AND AUTOMATIC WORK ARRAYS. *****
C
      REAL (KIND=R8):: LAMBDA,RHOVEC(N),SIGMA,YPNORM
      INTEGER:: J,NP1,JPOS
C
      INTERFACE
        FUNCTION DNRM2(N,X,STRIDE)
          USE REAL_PRECISION
          INTEGER:: N,STRIDE
          REAL (KIND=R8):: DNRM2,X(N)
        END FUNCTION DNRM2
        SUBROUTINE PCGDS(N,LENQR,IFLAG,YP,RHS)
          USE REAL_PRECISION
          INTEGER, INTENT(IN):: LENQR,N
          INTEGER, INTENT(IN OUT):: IFLAG
          REAL (KIND=R8), INTENT(IN OUT):: YP(N+1)
          REAL (KIND=R8), OPTIONAL, INTENT(IN):: RHS(N)
        END SUBROUTINE PCGDS
        SUBROUTINE GMRILUDS(N,LENQR,IFLAG,YP,RHS)
          USE REAL_PRECISION
          INTEGER, INTENT(IN):: LENQR,N
          INTEGER, INTENT(IN OUT):: IFLAG
          REAL (KIND=R8), INTENT(IN OUT):: YP(N+1)
          REAL (KIND=R8), OPTIONAL, INTENT(IN):: RHS(N)
        END SUBROUTINE GMRILUDS
      END INTERFACE
C
C *****  END OF SPECIFICATION INFORMATION.  *****
C
      NP1=N+1
      NFE=NFE+1
C NFE CONTAINS THE NUMBER OF JACOBIAN EVALUATIONS.
      LAMBDA=Y(NP1)
      ROWPOS(NP1)=LENQR+1
C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
C MODE = 1 STORAGE FORMAT.
C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
C
      IF (MODE .EQ. 1) THEN
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  RHOVEC = RHO(A,X,LAMBDA) .
C
C  PP = - (D RHO(A,X,LAMBDA)/D LAMBDA) .
        CALL RHOJS(A,LAMBDA,Y(1:N))
        IF (RHOLEN < 0) CALL RHO(A,LAMBDA,Y(1:N),RHOVEC)
C
      ELSE
        CALL F(Y(1:N),PP)
        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
          PP = PP - A(1:N)
          IF (RHOLEN < 0) RHOVEC = Y(1:N) - A(1:N) - LAMBDA*PP
          CALL FJACS(Y(1:N))
          QR = (-LAMBDA)*QR
          QR(ROWPOS(1:N)) = QR(ROWPOS(1:N)) + 1.0
        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
          PP = Y(1:N) - A(1:N) - PP
          IF (RHOLEN < 0) RHOVEC = Y(1:N) - A(1:N) - LAMBDA*PP
          CALL FJACS(Y(1:N))
          QR = LAMBDA*QR
          QR(ROWPOS(1:N)) = QR(ROWPOS(1:N)) + 1.0 - LAMBDA
        ENDIF
      ENDIF
      ELSE
C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
C MODE = 2 STORAGE FORMAT.
C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
C
      IF (IFLAG .EQ. -2) THEN
C
C  [QR] = [ 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(1:N))
        IF (RHOLEN < 0) CALL RHO(A,LAMBDA,Y(1:N),RHOVEC)
C
      ELSE
        CALL F(Y(1:N),PP)
        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
          PP = PP - A(1:N)
          IF (RHOLEN < 0) RHOVEC = Y(1:N) - A(1:N) - LAMBDA*PP
          CALL FJACS(Y(1:N))
          QR = (-LAMBDA)*QR
C FIND INDEX JPOS OF DIAGONAL ELEMENT IN JTH ROW OF QR.
          DO J=1,N
            JPOS=ROWPOS(J)
            DO
              IF (COLPOS(JPOS) .EQ. J) EXIT
              JPOS=JPOS+1
              IF (JPOS < ROWPOS(J+1)) CYCLE
              IFLAG=4
              RETURN
            END DO
            QR(JPOS) = QR(JPOS) + 1.0
          END DO
        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
          PP = Y(1:N) - A(1:N) - PP
          IF (RHOLEN < 0) RHOVEC = Y(1:N) - A(1:N) - LAMBDA*PP
          CALL FJACS(Y(1:N))
          QR = LAMBDA*QR
C FIND INDEX JPOS OF DIAGONAL ELEMENT IN JTH ROW OF QR.
          DO J=1,N
            JPOS=ROWPOS(J)
            DO
              IF (COLPOS(JPOS) .EQ. J) EXIT
              JPOS=JPOS+1
              IF (JPOS < ROWPOS(J+1)) CYCLE
              IFLAG=4
              RETURN
            END DO
            QR(JPOS) = QR(JPOS) + 1.0 - LAMBDA
          END DO
        ENDIF
      ENDIF
      ENDIF
C
C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
      YP=YPOLD
C COMPUTE KERNEL OF JACOBIAN, WHICH SPECIFIES YP=DY/DS, USING A
C PRECONDITIONED CONJUGATE GRADIENT ALGORITHM.
      SELECT CASE (MODE)
        CASE (1)
        CALL PCGDS(N,LENQR,IFLAG,YP)
        CASE (2)
        CALL GMRILUDS(N,LENQR,IFLAG,YP)
      END SELECT
      IF (IFLAG .GT. 0) RETURN
C
C NORMALIZE TANGENT VECTOR YP.
      YPNORM=DNRM2(NP1,YP,1)
      YP = (1.0/YPNORM)*YP
C
C CHOOSE UNIT TANGENT VECTOR DIRECTION TO MAINTAIN CONTINUITY.
      IF (DOT_PRODUCT(YP,YPOLD) .LT. 0.0) YP = -YP
C
C COMPUTE THE NORM OF THE HOMOTOPY MAP AND THE NEWTON STEP
C IF IT WAS REQUESTED.
      IF (RHOLEN < 0.0) THEN
        RHOLEN=DNRM2(N,RHOVEC,1)
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].
        TZ=YPOLD
        SELECT CASE (MODE)
          CASE (1)
          CALL PCGDS(N,LENQR,IFLAG,TZ,RHS=RHOVEC)
          CASE (2)
          CALL GMRILUDS(N,LENQR,IFLAG,TZ,RHS=RHOVEC)
        END SELECT
        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=DOT_PRODUCT(TZ(1:NP1),YP(1:NP1))
        TZ = TZ - SIGMA*YP
C TZ IS THE NEWTON STEP FROM THE CURRENT POINT Y(S) = (X(S), LAMBDA(S)).
      END IF
C
      RETURN
      END SUBROUTINE TANGNS
        SUBROUTINE TANGQF(Y,YP,YPOLD,A,Q,R,W,S,T,N,IFLAG,NFE)
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 THE FOLLOWING INTERFACE BLOCK SHOULD BE INCLUDED IN THE CALLING
C PROGRAM:
C
C     INTERFACE
C       SUBROUTINE TANGQF(Y,YP,YPOLD,A,Q,R,W,S,T,N,IFLAG,NFE)
C       USE HOMOTOPY
C       USE REAL_PRECISION
C       INTEGER:: N, IFLAG, NFE
C       REAL (KIND=R8):: A(:), Q(N+1,N+1), R((N+1)*(N+2)/2),
C    &    S(N+1), T(N+1), W(N+1), Y(:), YP(N+1), YPOLD(N+1)
C       END SUBROUTINE TANGQF
C     END INTERFACE
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(:)  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
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 Q(1:N+1,1:N+1)  CONTAINS  Q  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 COLUMNS)
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  DGEQRF, DNRM2, DORGQR, DTPSV, F (OR RHO IF IFLAG = -2),
C FJAC (OR RHOJAC, IF IFLAG = -2),
C R1UPQF (WHICH IS AN ENTRY POINT OF UPQRQF).
C        
C ***** DECLARATIONS *****
      USE HOMOTOPY
      USE REAL_PRECISION
C
C FUNCTION DECLARATIONS
C
      INTERFACE
        FUNCTION DNRM2(N,X,STRIDE)
        USE REAL_PRECISION
        INTEGER:: N,STRIDE
        REAL (KIND=R8):: DNRM2,X(N)
        END FUNCTION DNRM2
      END INTERFACE
C
C LOCAL VARIABLES
C
      REAL (KIND=R8):: LAMBDA, YPNRM
      INTEGER:: I, J, JP1, NP1
C
C SCALAR ARGUMENTS
C
      INTEGER:: N, IFLAG, NFE
C
C ARRAY DECLARATIONS 
C
      REAL (KIND=R8):: A(:), Q(N+1,N+1), R((N+1)*(N+2)/2),
     &  S(N+1), T(N+1), W(N+1), Y(:), YP(N+1), YPOLD(N+1)
C
C ***** END OF DECLARATIONS *****
C
C ***** FIRST EXECUTABLE STATEMENT *****
C
      NFE = NFE + 1
      NP1 = N + 1
      LAMBDA = Y(1)
C        
C ***** DEFINE THE AUGMENTED JACOBIAN MATRIX *****
C
C Q = 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 J = 1,NP1
          CALL RHOJAC(A,LAMBDA,Y(2:NP1),Q(1:N,J),J)
        END DO
      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:NP1),Q(1:N,1))
        Q(1:N,1) = A(1:N) - Y(2:NP1) + Q(1:N,1)
        DO J= 1,N
          JP1 = J+1
          CALL FJAC(Y(2:NP1),Q(1:N,JP1),J)
          Q(1:N,JP1) = LAMBDA*Q(1:N,JP1)
          Q(J,JP1) = 1.0 - LAMBDA + Q(J,JP1)
        END DO
      ELSE 
C
C FIXED POINT PROBLEM:
C         D(RHO) = (A - F(X), I - LAMBDA*DF(X)).
C
        CALL F(Y(2:NP1),Q(1:N,1))
        Q(1:N,1) = A(1:N) - Q(1:N,1)
        DO J=1,N
          JP1 = J+1
          CALL FJAC(Y(2:NP1),Q(1:N,JP1),J)
          Q(1:N,JP1) = -LAMBDA*Q(1:N,JP1)
          Q(J,JP1) = 1.0 + Q(J,JP1)
        END DO
      END IF
C
C DEFINE LAST ROW OF Q = YPOLD.
C
      Q(NP1,:) = YPOLD
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 DGEQRF(NP1,NP1,Q,NP1,T,W,NP1,I)
C
C PACK UPPER TRIANGLE INTO ARRAY R .
C
      DO I=1,NP1
        R((I*(I-1))/2 + 1:(I*(I-1))/2 + I) = Q(1:I,I)
      END DO
C
C IF MATRIX IS SINGULAR, THEN RETURN WITH IFLAG = 4,
C ELSE SOLVE SYSTEM  R*YP = QT*(0,...,0,1)  FOR YP.
C
C
C CHECK FOR SINGULARITY.
C
      J = 1
      DO I = 1, N
        IF( R( J+I-1 ).EQ. 0.0 ) THEN
          IFLAG = 4
          RETURN
        END IF
        J = J + I
      END DO
C
C EXPAND HOUSEHOLDER REFLECTIONS INTO FULL MATRIX Q . 
C
      CALL DORGQR(NP1, NP1, N, Q, NP1, T, W, NP1, I)
C
      YP = Q(NP1,:)
      CALL DTPSV('U', 'N', 'N', NP1, R, YP, 1)
C
C COMPUTE UNIT VECTOR.
C
      YPNRM = 1.0/DNRM2(NP1,YP,1)
      YP = YPNRM*YP
C
C ***** SYSTEM SOLVED *****
C
C ***** UPDATE AUGMENTED SYSTEM SO THAT LAST ROW IS YP *****
C                        
C S=YP-YPOLD,  T = E(NP1)T*Q.
C      
      S = YP - YPOLD
      T = Q(NP1,:)
      CALL R1UPQF(NP1,S,T,Q,R,W)        
C
      RETURN
C
      END SUBROUTINE TANGQF
        SUBROUTINE UPQRQF(N,ETA,S,F0,F1,Q,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 Q(1:N,1:N)  CONTAINS THE OLD Q , WHERE  A = Q*R .
C
C R(1:N*(N+1)/2)  CONTAINS THE OLD R, STORED BY COLUMNS.
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 Q  CONTAINS Q+ .
C
C R   CONTAINS R+, STORED BY COLUMNS.
C
C S, F0, F1, W, AND T  HAVE ALL BEEN CHANGED.
C
C
C CALLS   DGEMV, DNRM2, DTPMV.
C
C ***** DECLARATIONS *****
      USE REAL_PRECISION
C
C FUNCTION DECLARATIONS 
C
      INTERFACE
        FUNCTION DNRM2(N,X,STRIDE)
        USE REAL_PRECISION
        INTEGER:: N,STRIDE
        REAL (KIND=R8):: DNRM2,X(N)
        END FUNCTION DNRM2
      END INTERFACE
C
C LOCAL VARIABLES 
C
      REAL (KIND=R8):: C, DEN, ONE, SS, WW, YY, ZERO
      INTEGER:: I, INDEXC, INDEXD, INDXC2, J, K
      LOGICAL:: SKIPUP
C
C SCALAR ARGUMENTS 
C
      REAL (KIND=R8):: ETA
      INTEGER:: N
C
C ARRAY DECLARATIONS  
C
      REAL (KIND=R8)::  S(N), F0(N), F1(N), Q(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
      ZERO = 0.0
      SKIPUP = .TRUE.
C
C ***** DEFINE T AND S SUCH THAT *****
C
C           A+ = Q*(R + T*ST). 
C
C T = R*S.
C
      T = S
      CALL DTPMV('U','N','N',N,R,T,1)
C
C W = Y - Q*T  = Y - A*S.
C
      W = F1 - F0 - MATMUL(Q,T)
C
C IF W(I) IS NOT SMALL, THEN UPDATE MUST BE PERFORMED,
C OTHERWISE SET W(I) TO 0.
C
      WHERE (ABS(W) .LE. ETA*(ABS(F1) + ABS(F0))) W = 0.0
      IF (ANY(ABS(W) .GT. ETA*(ABS(F1) + ABS(F0)))) SKIPUP = .FALSE.
C
C IF NO UPDATE IS NECESSARY, THEN RETURN.
C
      IF (SKIPUP) RETURN
C
C T = QT*W = QT*Y - R*S.
C
      CALL DGEMV('T',N,N,ONE,Q,N,W,1,ZERO,T,1)
C
C S = S/(ST*S).
C
      S = (1.0/DOT_PRODUCT(S,S))*S
C
C ***** END OF COMPUTATION OF  T & S      *****
C       AT THIS POINT,  A+ = Q*(R + T*ST). 
C
      ENTRY R1UPQF(N,S,T,Q,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
      DO
        IF (T(K) .NE. 0.0 .OR. K .LE. 1) EXIT
        K=K-1
      END DO
C
C COMPUTE THE INDEX OF R(K-1,K-1).
C         
      INDEXD = (K*(K-1))/2
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
      JACOBI: DO 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(INDEXD)
        WW = 0.0
        R(INDEXD) = C*YY - SS*WW
        W(I+1) = SS*YY + C*WW
        DO J= I+1,N
C           YY = R(I,J)
C           WW = R(I+1,J)
            INDEXC = ((J-1)*J)/2 + I 
            INDXC2 = INDEXC + 1
            YY = R(INDEXC)
            WW = R(INDXC2)
C           R(I,J) = C*YY - SS*WW
C           R(I+1,J) = SS*YY + C*WW
            R(INDEXC) = C*YY - SS*WW
            R(INDXC2) = SS*YY + C*WW
        END DO
C
C         MULTIPLY  Q  BY THE JACOBI ROTATION.
C
        DO J=1,N
          YY = Q(J,I)
          WW = Q(J,I+1)
          Q(J,I) = C*YY - SS*WW
          Q(J,I+1) = SS*YY + C*WW
        END DO
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 INDEXD = THE INDEX OF R(I-1,I-1).
C
        INDEXD = INDEXD - I
C
      END DO JACOBI
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
      J=1
      DO I=1,N 
        R(J) = T(1)*S(I) + R(J)
        J=I+J
      END DO
C
C ***** END OF TRANSFORMATION TO UPPER HESSENBERG *****
C
C
C ***** TRANSFORM UPPER HESSENBERG MATRIX INTO UPPER *****
C       TRIANGULAR MATRIX. 
C
C       INDEXD = INDEX OF R(I,I).
C        
      INDEXD = 1
      HESSEN: DO I=1,K-1
C
C         DETERMINE APPROPRIATE JACOBI ROTATION TO ZERO OUT
C         R(I+1,I).
C
        IF (R(INDEXD) .EQ. 0.0) THEN
          C = 0.0
          SS = -SIGN(ONE,W(I+1))
        ELSE
          TT(1) = R(INDEXD)
          TT(2) = W(I+1)
          DEN = DNRM2(2,TT,1)
          C = R(INDEXD) / DEN
          SS = -W(I+1)/DEN
        END IF
C
C         PREMULTIPLY  R  BY JACOBI ROTATION.
C
        YY = R(INDEXD)
        WW = W(I+1)
        R(INDEXD) = C*YY - SS*WW
        W(I+1) = 0.0
        DO J= I+1,N
C           YY = R(I,J)
C           WW = R(I+1,J)  
          INDEXC = ((J-1)*J)/2 + I
          INDXC2 = INDEXC + 1 
          YY = R(INDEXC)
          WW = R(INDXC2)
C           R(I,J) = C*YY -SS*WW
C           R(I+1,J) = SS*YY + C*WW
          R(INDEXC) = C*YY - SS*WW
          R(INDXC2) = SS*YY + C*WW
        END DO
        INDEXD = INDEXD + I + 1
C
C         MULTIPLY  Q  BY JACOBI ROTATION.
C
        DO J=1,N
          YY = Q(J,I)
          WW = Q(J,I+1)
          Q(J,I) = C*YY - SS*WW
          Q(J,I+1) = SS*YY + C*WW
        END DO
      END DO HESSEN
C
C ***** END OF TRANSFORMATION TO UPPER TRIANGULAR *****
C
C
C ***** END OF UPDATE *****
C
C
      RETURN
      END SUBROUTINE UPQRQF
SHAR_EOF
fi # end of overwriting check
if test -f 'blas3.f'
then
	echo shar: will not over-write existing file "'blas3.f'"
else
cat << \SHAR_EOF > 'blas3.f'
      SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB,
     $                   BETA, C, LDC )
*     .. Scalar Arguments ..
      CHARACTER*1        TRANSA, TRANSB
      INTEGER            M, N, K, LDA, LDB, LDC
      DOUBLE PRECISION   ALPHA, BETA
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * )
*     ..
*
*  Purpose
*  =======
*
*  DGEMM  performs one of the matrix-matrix operations
*
*     C := alpha*op( A )*op( B ) + beta*C,
*
*  where  op( X ) is one of
*
*     op( X ) = X   or   op( X ) = X',
*
*  alpha and beta are scalars, and A, B and C are matrices, with op( A )
*  an m by k matrix,  op( B )  a  k by n matrix and  C an m by n matrix.
*
*  Parameters
*  ==========
*
*  TRANSA - CHARACTER*1.
*           On entry, TRANSA specifies the form of op( A ) to be used in
*           the matrix multiplication as follows:
*
*              TRANSA = 'N' or 'n',  op( A ) = A.
*
*              TRANSA = 'T' or 't',  op( A ) = A'.
*
*              TRANSA = 'C' or 'c',  op( A ) = A'.
*
*           Unchanged on exit.
*
*  TRANSB - CHARACTER*1.
*           On entry, TRANSB specifies the form of op( B ) to be used in
*           the matrix multiplication as follows:
*
*              TRANSB = 'N' or 'n',  op( B ) = B.
*
*              TRANSB = 'T' or 't',  op( B ) = B'.
*
*              TRANSB = 'C' or 'c',  op( B ) = B'.
*
*           Unchanged on exit.
*
*  M      - INTEGER.
*           On entry,  M  specifies  the number  of rows  of the  matrix
*           op( A )  and of the  matrix  C.  M  must  be at least  zero.
*           Unchanged on exit.
*
*  N      - INTEGER.
*           On entry,  N  specifies the number  of columns of the matrix
*           op( B ) and the number of columns of the matrix C. N must be
*           at least zero.
*           Unchanged on exit.
*
*  K      - INTEGER.
*           On entry,  K  specifies  the number of columns of the matrix
*           op( A ) and the number of rows of the matrix op( B ). K must
*           be at least  zero.
*           Unchanged on exit.
*
*  ALPHA  - DOUBLE PRECISION.
*           On entry, ALPHA specifies the scalar alpha.
*           Unchanged on exit.
*
*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
*           k  when  TRANSA = 'N' or 'n',  and is  m  otherwise.
*           Before entry with  TRANSA = 'N' or 'n',  the leading  m by k
*           part of the array  A  must contain the matrix  A,  otherwise
*           the leading  k by m  part of the array  A  must contain  the
*           matrix A.
*           Unchanged on exit.
*
*  LDA    - INTEGER.
*           On entry, LDA specifies the first dimension of A as declared
*           in the calling (sub) program. When  TRANSA = 'N' or 'n' then
*           LDA must be at least  max( 1, m ), otherwise  LDA must be at
*           least  max( 1, k ).
*           Unchanged on exit.
*
*  B      - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is
*           n  when  TRANSB = 'N' or 'n',  and is  k  otherwise.
*           Before entry with  TRANSB = 'N' or 'n',  the leading  k by n
*           part of the array  B  must contain the matrix  B,  otherwise
*           the leading  n by k  part of the array  B  must contain  the
*           matrix B.
*           Unchanged on exit.
*
*  LDB    - INTEGER.
*           On entry, LDB specifies the first dimension of B as declared
*           in the calling (sub) program. When  TRANSB = 'N' or 'n' then
*           LDB must be at least  max( 1, k ), otherwise  LDB must be at
*           least  max( 1, n ).
*           Unchanged on exit.
*
*  BETA   - DOUBLE PRECISION.
*           On entry,  BETA  specifies the scalar  beta.  When  BETA  is
*           supplied as zero then C need not be set on input.
*           Unchanged on exit.
*
*  C      - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
*           Before entry, the leading  m by n  part of the array  C must
*           contain the matrix  C,  except when  beta  is zero, in which
*           case C need not be set on entry.
*           On exit, the array  C  is overwritten by the  m by n  matrix
*           ( alpha*op( A )*op( B ) + beta*C ).
*
*  LDC    - INTEGER.
*           On entry, LDC specifies the first dimension of C as declared
*           in  the  calling  (sub)  program.   LDC  must  be  at  least
*           max( 1, m ).
*           Unchanged on exit.
*
*
*  Level 3 Blas routine.
*
*  -- Written on 8-February-1989.
*     Jack Dongarra, Argonne National Laboratory.
*     Iain Duff, AERE Harwell.
*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
*     Sven Hammarling, Numerical Algorithms Group Ltd.
*
*
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     .. Local Scalars ..
      LOGICAL            NOTA, NOTB
      INTEGER            I, INFO, J, L, NCOLA, NROWA, NROWB
      DOUBLE PRECISION   TEMP
*     .. Parameters ..
      DOUBLE PRECISION   ONE         , ZERO
      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Executable Statements ..
*
*     Set  NOTA  and  NOTB  as  true if  A  and  B  respectively are not
*     transposed and set  NROWA, NCOLA and  NROWB  as the number of rows
*     and  columns of  A  and the  number of  rows  of  B  respectively.
*
      NOTA  = LSAME( TRANSA, 'N' )
      NOTB  = LSAME( TRANSB, 'N' )
      IF( NOTA )THEN
         NROWA = M
         NCOLA = K
      ELSE
         NROWA = K
         NCOLA = M
      END IF
      IF( NOTB )THEN
         NROWB = K
      ELSE
         NROWB = N
      END IF
*
*     Test the input parameters.
*
      INFO = 0
      IF(      ( .NOT.NOTA                 ).AND.
     $         ( .NOT.LSAME( TRANSA, 'C' ) ).AND.
     $         ( .NOT.LSAME( TRANSA, 'T' ) )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.NOTB                 ).AND.
     $         ( .NOT.LSAME( TRANSB, 'C' ) ).AND.
     $         ( .NOT.LSAME( TRANSB, 'T' ) )      )THEN
         INFO = 2
      ELSE IF( M  .LT.0               )THEN
         INFO = 3
      ELSE IF( N  .LT.0               )THEN
         INFO = 4
      ELSE IF( K  .LT.0               )THEN
         INFO = 5
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = 8
      ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN
         INFO = 10
      ELSE IF( LDC.LT.MAX( 1, M     ) )THEN
         INFO = 13
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DGEMM ', INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.
     $    ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) )
     $   RETURN
*
*     And if  alpha.eq.zero.
*
      IF( ALPHA.EQ.ZERO )THEN
         IF( BETA.EQ.ZERO )THEN
            DO 20, J = 1, N
               DO 10, I = 1, M
                  C( I, J ) = ZERO
   10          CONTINUE
   20       CONTINUE
         ELSE
            DO 40, J = 1, N
               DO 30, I = 1, M
                  C( I, J ) = BETA*C( I, J )
   30          CONTINUE
   40       CONTINUE
         END IF
         RETURN
      END IF
*
*     Start the operations.
*
      IF( NOTB )THEN
         IF( NOTA )THEN
*
*           Form  C := alpha*A*B + beta*C.
*
            DO 90, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 50, I = 1, M
                     C( I, J ) = ZERO
   50             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 60, I = 1, M
                     C( I, J ) = BETA*C( I, J )
   60             CONTINUE
               END IF
               DO 80, L = 1, K
                  IF( B( L, J ).NE.ZERO )THEN
                     TEMP = ALPHA*B( L, J )
                     DO 70, I = 1, M
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
   70                CONTINUE
                  END IF
   80          CONTINUE
   90       CONTINUE
         ELSE
*
*           Form  C := alpha*A'*B + beta*C
*
            DO 120, J = 1, N
               DO 110, I = 1, M
                  TEMP = ZERO
                  DO 100, L = 1, K
                     TEMP = TEMP + A( L, I )*B( L, J )
  100             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  110          CONTINUE
  120       CONTINUE
         END IF
      ELSE
         IF( NOTA )THEN
*
*           Form  C := alpha*A*B' + beta*C
*
            DO 170, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 130, I = 1, M
                     C( I, J ) = ZERO
  130             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 140, I = 1, M
                     C( I, J ) = BETA*C( I, J )
  140             CONTINUE
               END IF
               DO 160, L = 1, K
                  IF( B( J, L ).NE.ZERO )THEN
                     TEMP = ALPHA*B( J, L )
                     DO 150, I = 1, M
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
  150                CONTINUE
                  END IF
  160          CONTINUE
  170       CONTINUE
         ELSE
*
*           Form  C := alpha*A'*B' + beta*C
*
            DO 200, J = 1, N
               DO 190, I = 1, M
                  TEMP = ZERO
                  DO 180, L = 1, K
                     TEMP = TEMP + A( L, I )*B( J, L )
  180             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  190          CONTINUE
  200       CONTINUE
         END IF
      END IF
*
      RETURN
*
*     End of DGEMM .
*
      END
      SUBROUTINE DTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
     $                   B, LDB )
*     .. Scalar Arguments ..
      CHARACTER*1        SIDE, UPLO, TRANSA, DIAG
      INTEGER            M, N, LDA, LDB
      DOUBLE PRECISION   ALPHA
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
*     ..
*
*  Purpose
*  =======
*
*  DTRMM  performs one of the matrix-matrix operations
*
*     B := alpha*op( A )*B,   or   B := alpha*B*op( A ),
*
*  where  alpha  is a scalar,  B  is an m by n matrix,  A  is a unit, or
*  non-unit,  upper or lower triangular matrix  and  op( A )  is one  of
*
*     op( A ) = A   or   op( A ) = A'.
*
*  Parameters
*  ==========
*
*  SIDE   - CHARACTER*1.
*           On entry,  SIDE specifies whether  op( A ) multiplies B from
*           the left or right as follows:
*
*              SIDE = 'L' or 'l'   B := alpha*op( A )*B.
*
*              SIDE = 'R' or 'r'   B := alpha*B*op( A ).
*
*           Unchanged on exit.
*
*  UPLO   - CHARACTER*1.
*           On entry, UPLO specifies whether the matrix A is an upper or
*           lower triangular matrix as follows:
*
*              UPLO = 'U' or 'u'   A is an upper triangular matrix.
*
*              UPLO = 'L' or 'l'   A is a lower triangular matrix.
*
*           Unchanged on exit.
*
*  TRANSA - CHARACTER*1.
*           On entry, TRANSA specifies the form of op( A ) to be used in
*           the matrix multiplication as follows:
*
*              TRANSA = 'N' or 'n'   op( A ) = A.
*
*              TRANSA = 'T' or 't'   op( A ) = A'.
*
*              TRANSA = 'C' or 'c'   op( A ) = A'.
*
*           Unchanged on exit.
*
*  DIAG   - CHARACTER*1.
*           On entry, DIAG specifies whether or not A is unit triangular
*           as follows:
*
*              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
*
*              DIAG = 'N' or 'n'   A is not assumed to be unit
*                                  triangular.
*
*           Unchanged on exit.
*
*  M      - INTEGER.
*           On entry, M specifies the number of rows of B. M must be at
*           least zero.
*           Unchanged on exit.
*
*  N      - INTEGER.
*           On entry, N specifies the number of columns of B.  N must be
*           at least zero.
*           Unchanged on exit.
*
*  ALPHA  - DOUBLE PRECISION.
*           On entry,  ALPHA specifies the scalar  alpha. When  alpha is
*           zero then  A is not referenced and  B need not be set before
*           entry.
*           Unchanged on exit.
*
*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m
*           when  SIDE = 'L' or 'l'  and is  n  when  SIDE = 'R' or 'r'.
*           Before entry  with  UPLO = 'U' or 'u',  the  leading  k by k
*           upper triangular part of the array  A must contain the upper
*           triangular matrix  and the strictly lower triangular part of
*           A is not referenced.
*           Before entry  with  UPLO = 'L' or 'l',  the  leading  k by k
*           lower triangular part of the array  A must contain the lower
*           triangular matrix  and the strictly upper triangular part of
*           A is not referenced.
*           Note that when  DIAG = 'U' or 'u',  the diagonal elements of
*           A  are not referenced either,  but are assumed to be  unity.
*           Unchanged on exit.
*
*  LDA    - INTEGER.
*           On entry, LDA specifies the first dimension of A as declared
*           in the calling (sub) program.  When  SIDE = 'L' or 'l'  then
*           LDA  must be at least  max( 1, m ),  when  SIDE = 'R' or 'r'
*           then LDA must be at least max( 1, n ).
*           Unchanged on exit.
*
*  B      - DOUBLE PRECISION array of DIMENSION ( LDB, n ).
*           Before entry,  the leading  m by n part of the array  B must
*           contain the matrix  B,  and  on exit  is overwritten  by the
*           transformed matrix.
*
*  LDB    - INTEGER.
*           On entry, LDB specifies the first dimension of B as declared
*           in  the  calling  (sub)  program.   LDB  must  be  at  least
*           max( 1, m ).
*           Unchanged on exit.
*
*
*  Level 3 Blas routine.
*
*  -- Written on 8-February-1989.
*     Jack Dongarra, Argonne National Laboratory.
*     Iain Duff, AERE Harwell.
*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
*     Sven Hammarling, Numerical Algorithms Group Ltd.
*
*
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     .. Local Scalars ..
      LOGICAL            LSIDE, NOUNIT, UPPER
      INTEGER            I, INFO, J, K, NROWA
      DOUBLE PRECISION   TEMP
*     .. Parameters ..
      DOUBLE PRECISION   ONE         , ZERO
      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      LSIDE  = LSAME( SIDE  , 'L' )
      IF( LSIDE )THEN
         NROWA = M
      ELSE
         NROWA = N
      END IF
      NOUNIT = LSAME( DIAG  , 'N' )
      UPPER  = LSAME( UPLO  , 'U' )
*
      INFO   = 0
      IF(      ( .NOT.LSIDE                ).AND.
     $         ( .NOT.LSAME( SIDE  , 'R' ) )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.UPPER                ).AND.
     $         ( .NOT.LSAME( UPLO  , 'L' ) )      )THEN
         INFO = 2
      ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND.
     $         ( .NOT.LSAME( TRANSA, 'T' ) ).AND.
     $         ( .NOT.LSAME( TRANSA, 'C' ) )      )THEN
         INFO = 3
      ELSE IF( ( .NOT.LSAME( DIAG  , 'U' ) ).AND.
     $         ( .NOT.LSAME( DIAG  , 'N' ) )      )THEN
         INFO = 4
      ELSE IF( M  .LT.0               )THEN
         INFO = 5
      ELSE IF( N  .LT.0               )THEN
         INFO = 6
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = 9
      ELSE IF( LDB.LT.MAX( 1, M     ) )THEN
         INFO = 11
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DTRMM ', INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( N.EQ.0 )
     $   RETURN
*
*     And when  alpha.eq.zero.
*
      IF( ALPHA.EQ.ZERO )THEN
         DO 20, J = 1, N
            DO 10, I = 1, M
               B( I, J ) = ZERO
   10       CONTINUE
   20    CONTINUE
         RETURN
      END IF
*
*     Start the operations.
*
      IF( LSIDE )THEN
         IF( LSAME( TRANSA, 'N' ) )THEN
*
*           Form  B := alpha*A*B.
*
            IF( UPPER )THEN
               DO 50, J = 1, N
                  DO 40, K = 1, M
                     IF( B( K, J ).NE.ZERO )THEN
                        TEMP = ALPHA*B( K, J )
                        DO 30, I = 1, K - 1
                           B( I, J ) = B( I, J ) + TEMP*A( I, K )
   30                   CONTINUE
                        IF( NOUNIT )
     $                     TEMP = TEMP*A( K, K )
                        B( K, J ) = TEMP
                     END IF
   40             CONTINUE
   50          CONTINUE
            ELSE
               DO 80, J = 1, N
                  DO 70 K = M, 1, -1
                     IF( B( K, J ).NE.ZERO )THEN
                        TEMP      = ALPHA*B( K, J )
                        B( K, J ) = TEMP
                        IF( NOUNIT )
     $                     B( K, J ) = B( K, J )*A( K, K )
                        DO 60, I = K + 1, M
                           B( I, J ) = B( I, J ) + TEMP*A( I, K )
   60                   CONTINUE
                     END IF
   70             CONTINUE
   80          CONTINUE
            END IF
         ELSE
*
*           Form  B := alpha*A'*B.
*
            IF( UPPER )THEN
               DO 110, J = 1, N
                  DO 100, I = M, 1, -1
                     TEMP = B( I, J )
                     IF( NOUNIT )
     $                  TEMP = TEMP*A( I, I )
                     DO 90, K = 1, I - 1
                        TEMP = TEMP + A( K, I )*B( K, J )
   90                CONTINUE
                     B( I, J ) = ALPHA*TEMP
  100             CONTINUE
  110          CONTINUE
            ELSE
               DO 140, J = 1, N
                  DO 130, I = 1, M
                     TEMP = B( I, J )
                     IF( NOUNIT )
     $                  TEMP = TEMP*A( I, I )
                     DO 120, K = I + 1, M
                        TEMP = TEMP + A( K, I )*B( K, J )
  120                CONTINUE
                     B( I, J ) = ALPHA*TEMP
  130             CONTINUE
  140          CONTINUE
            END IF
         END IF
      ELSE
         IF( LSAME( TRANSA, 'N' ) )THEN
*
*           Form  B := alpha*B*A.
*
            IF( UPPER )THEN
               DO 180, J = N, 1, -1
                  TEMP = ALPHA
                  IF( NOUNIT )
     $               TEMP = TEMP*A( J, J )
                  DO 150, I = 1, M
                     B( I, J ) = TEMP*B( I, J )
  150             CONTINUE
                  DO 170, K = 1, J - 1
                     IF( A( K, J ).NE.ZERO )THEN
                        TEMP = ALPHA*A( K, J )
                        DO 160, I = 1, M
                           B( I, J ) = B( I, J ) + TEMP*B( I, K )
  160                   CONTINUE
                     END IF
  170             CONTINUE
  180          CONTINUE
            ELSE
               DO 220, J = 1, N
                  TEMP = ALPHA
                  IF( NOUNIT )
     $               TEMP = TEMP*A( J, J )
                  DO 190, I = 1, M
                     B( I, J ) = TEMP*B( I, J )
  190             CONTINUE
                  DO 210, K = J + 1, N
                     IF( A( K, J ).NE.ZERO )THEN
                        TEMP = ALPHA*A( K, J )
                        DO 200, I = 1, M
                           B( I, J ) = B( I, J ) + TEMP*B( I, K )
  200                   CONTINUE
                     END IF
  210             CONTINUE
  220          CONTINUE
            END IF
         ELSE
*
*           Form  B := alpha*B*A'.
*
            IF( UPPER )THEN
               DO 260, K = 1, N
                  DO 240, J = 1, K - 1
                     IF( A( J, K ).NE.ZERO )THEN
                        TEMP = ALPHA*A( J, K )
                        DO 230, I = 1, M
                           B( I, J ) = B( I, J ) + TEMP*B( I, K )
  230                   CONTINUE
                     END IF
  240             CONTINUE
                  TEMP = ALPHA
                  IF( NOUNIT )
     $               TEMP = TEMP*A( K, K )
                  IF( TEMP.NE.ONE )THEN
                     DO 250, I = 1, M
                        B( I, K ) = TEMP*B( I, K )
  250                CONTINUE
                  END IF
  260          CONTINUE
            ELSE
               DO 300, K = N, 1, -1
                  DO 280, J = K + 1, N
                     IF( A( J, K ).NE.ZERO )THEN
                        TEMP = ALPHA*A( J, K )
                        DO 270, I = 1, M
                           B( I, J ) = B( I, J ) + TEMP*B( I, K )
  270                   CONTINUE
                     END IF
  280             CONTINUE
                  TEMP = ALPHA
                  IF( NOUNIT )
     $               TEMP = TEMP*A( K, K )
                  IF( TEMP.NE.ONE )THEN
                     DO 290, I = 1, M
                        B( I, K ) = TEMP*B( I, K )
  290                CONTINUE
                  END IF
  300          CONTINUE
            END IF
         END IF
      END IF
*
      RETURN
*
*     End of DTRMM .
*
      END
SHAR_EOF
fi # end of overwriting check
if test -f 'blas2.f'
then
	echo shar: will not over-write existing file "'blas2.f'"
else
cat << \SHAR_EOF > 'blas2.f'
      SUBROUTINE DGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX,
     $                   BETA, Y, INCY )
*     .. Scalar Arguments ..
      DOUBLE PRECISION   ALPHA, BETA
      INTEGER            INCX, INCY, LDA, M, N
      CHARACTER*1        TRANS
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), X( * ), Y( * )
*     ..
*
*  Purpose
*  =======
*
*  DGEMV  performs one of the matrix-vector operations
*
*     y := alpha*A*x + beta*y,   or   y := alpha*A'*x + beta*y,
*
*  where alpha and beta are scalars, x and y are vectors and A is an
*  m by n matrix.
*
*  Parameters
*  ==========
*
*  TRANS  - CHARACTER*1.
*           On entry, TRANS specifies the operation to be performed as
*           follows:
*
*              TRANS = 'N' or 'n'   y := alpha*A*x + beta*y.
*
*              TRANS = 'T' or 't'   y := alpha*A'*x + beta*y.
*
*              TRANS = 'C' or 'c'   y := alpha*A'*x + beta*y.
*
*           Unchanged on exit.
*
*  M      - INTEGER.
*           On entry, M specifies the number of rows of the matrix A.
*           M must be at least zero.
*           Unchanged on exit.
*
*  N      - INTEGER.
*           On entry, N specifies the number of columns of the matrix A.
*           N must be at least zero.
*           Unchanged on exit.
*
*  ALPHA  - DOUBLE PRECISION.
*           On entry, ALPHA specifies the scalar alpha.
*           Unchanged on exit.
*
*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
*           Before entry, the leading m by n part of the array A must
*           contain the matrix of coefficients.
*           Unchanged on exit.
*
*  LDA    - INTEGER.
*           On entry, LDA specifies the first dimension of A as declared
*           in the calling (sub) program. LDA must be at least
*           max( 1, m ).
*           Unchanged on exit.
*
*  X      - DOUBLE PRECISION array of DIMENSION at least
*           ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
*           and at least
*           ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
*           Before entry, the incremented array X must contain the
*           vector x.
*           Unchanged on exit.
*
*  INCX   - INTEGER.
*           On entry, INCX specifies the increment for the elements of
*           X. INCX must not be zero.
*           Unchanged on exit.
*
*  BETA   - DOUBLE PRECISION.
*           On entry, BETA specifies the scalar beta. When BETA is
*           supplied as zero then Y need not be set on input.
*           Unchanged on exit.
*
*  Y      - DOUBLE PRECISION array of DIMENSION at least
*           ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
*           and at least
*           ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
*           Before entry with BETA non-zero, the incremented array Y
*           must contain the vector y. On exit, Y is overwritten by the
*           updated vector y.
*
*  INCY   - INTEGER.
*           On entry, INCY specifies the increment for the elements of
*           Y. INCY must not be zero.
*           Unchanged on exit.
*
*
*  Level 2 Blas routine.
*
*  -- Written on 22-October-1986.
*     Jack Dongarra, Argonne National Lab.
*     Jeremy Du Croz, Nag Central Office.
*     Sven Hammarling, Nag Central Office.
*     Richard Hanson, Sandia National Labs.
*
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE         , ZERO
      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     .. Local Scalars ..
      DOUBLE PRECISION   TEMP
      INTEGER            I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF     ( .NOT.LSAME( TRANS, 'N' ).AND.
     $         .NOT.LSAME( TRANS, 'T' ).AND.
     $         .NOT.LSAME( TRANS, 'C' )      )THEN
         INFO = 1
      ELSE IF( M.LT.0 )THEN
         INFO = 2
      ELSE IF( N.LT.0 )THEN
         INFO = 3
      ELSE IF( LDA.LT.MAX( 1, M ) )THEN
         INFO = 6
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 8
      ELSE IF( INCY.EQ.0 )THEN
         INFO = 11
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DGEMV ', INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.
     $    ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) )
     $   RETURN
*
*     Set  LENX  and  LENY, the lengths of the vectors x and y, and set
*     up the start points in  X  and  Y.
*
      IF( LSAME( TRANS, 'N' ) )THEN
         LENX = N
         LENY = M
      ELSE
         LENX = M
         LENY = N
      END IF
      IF( INCX.GT.0 )THEN
         KX = 1
      ELSE
         KX = 1 - ( LENX - 1 )*INCX
      END IF
      IF( INCY.GT.0 )THEN
         KY = 1
      ELSE
         KY = 1 - ( LENY - 1 )*INCY
      END IF
*
*     Start the operations. In this version the elements of A are
*     accessed sequentially with one pass through A.
*
*     First form  y := beta*y.
*
      IF( BETA.NE.ONE )THEN
         IF( INCY.EQ.1 )THEN
            IF( BETA.EQ.ZERO )THEN
               DO 10, I = 1, LENY
                  Y( I ) = ZERO
   10          CONTINUE
            ELSE
               DO 20, I = 1, LENY
                  Y( I ) = BETA*Y( I )
   20          CONTINUE
            END IF
         ELSE
            IY = KY
            IF( BETA.EQ.ZERO )THEN
               DO 30, I = 1, LENY
                  Y( IY ) = ZERO
                  IY      = IY   + INCY
   30          CONTINUE
            ELSE
               DO 40, I = 1, LENY
                  Y( IY ) = BETA*Y( IY )
                  IY      = IY           + INCY
   40          CONTINUE
            END IF
         END IF
      END IF
      IF( ALPHA.EQ.ZERO )
     $   RETURN
      IF( LSAME( TRANS, 'N' ) )THEN
*
*        Form  y := alpha*A*x + y.
*
         JX = KX
         IF( INCY.EQ.1 )THEN
            DO 60, J = 1, N
               IF( X( JX ).NE.ZERO )THEN
                  TEMP = ALPHA*X( JX )
                  DO 50, I = 1, M
                     Y( I ) = Y( I ) + TEMP*A( I, J )
   50             CONTINUE
               END IF
               JX = JX + INCX
   60       CONTINUE
         ELSE
            DO 80, J = 1, N
               IF( X( JX ).NE.ZERO )THEN
                  TEMP = ALPHA*X( JX )
                  IY   = KY
                  DO 70, I = 1, M
                     Y( IY ) = Y( IY ) + TEMP*A( I, J )
                     IY      = IY      + INCY
   70             CONTINUE
               END IF
               JX = JX + INCX
   80       CONTINUE
         END IF
      ELSE
*
*        Form  y := alpha*A'*x + y.
*
         JY = KY
         IF( INCX.EQ.1 )THEN
            DO 100, J = 1, N
               TEMP = ZERO
               DO 90, I = 1, M
                  TEMP = TEMP + A( I, J )*X( I )
   90          CONTINUE
               Y( JY ) = Y( JY ) + ALPHA*TEMP
               JY      = JY      + INCY
  100       CONTINUE
         ELSE
            DO 120, J = 1, N
               TEMP = ZERO
               IX   = KX
               DO 110, I = 1, M
                  TEMP = TEMP + A( I, J )*X( IX )
                  IX   = IX   + INCX
  110          CONTINUE
               Y( JY ) = Y( JY ) + ALPHA*TEMP
               JY      = JY      + INCY
  120       CONTINUE
         END IF
      END IF
*
      RETURN
*
*     End of DGEMV .
*
      END
      SUBROUTINE DGER  ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
*     .. Scalar Arguments ..
      DOUBLE PRECISION   ALPHA
      INTEGER            INCX, INCY, LDA, M, N
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), X( * ), Y( * )
*     ..
*
*  Purpose
*  =======
*
*  DGER   performs the rank 1 operation
*
*     A := alpha*x*y' + A,
*
*  where alpha is a scalar, x is an m element vector, y is an n element
*  vector and A is an m by n matrix.
*
*  Parameters
*  ==========
*
*  M      - INTEGER.
*           On entry, M specifies the number of rows of the matrix A.
*           M must be at least zero.
*           Unchanged on exit.
*
*  N      - INTEGER.
*           On entry, N specifies the number of columns of the matrix A.
*           N must be at least zero.
*           Unchanged on exit.
*
*  ALPHA  - DOUBLE PRECISION.
*           On entry, ALPHA specifies the scalar alpha.
*           Unchanged on exit.
*
*  X      - DOUBLE PRECISION array of dimension at least
*           ( 1 + ( m - 1 )*abs( INCX ) ).
*           Before entry, the incremented array X must contain the m
*           element vector x.
*           Unchanged on exit.
*
*  INCX   - INTEGER.
*           On entry, INCX specifies the increment for the elements of
*           X. INCX must not be zero.
*           Unchanged on exit.
*
*  Y      - DOUBLE PRECISION array of dimension at least
*           ( 1 + ( n - 1 )*abs( INCY ) ).
*           Before entry, the incremented array Y must contain the n
*           element vector y.
*           Unchanged on exit.
*
*  INCY   - INTEGER.
*           On entry, INCY specifies the increment for the elements of
*           Y. INCY must not be zero.
*           Unchanged on exit.
*
*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
*           Before entry, the leading m by n part of the array A must
*           contain the matrix of coefficients. On exit, A is
*           overwritten by the updated matrix.
*
*  LDA    - INTEGER.
*           On entry, LDA specifies the first dimension of A as declared
*           in the calling (sub) program. LDA must be at least
*           max( 1, m ).
*           Unchanged on exit.
*
*
*  Level 2 Blas routine.
*
*  -- Written on 22-October-1986.
*     Jack Dongarra, Argonne National Lab.
*     Jeremy Du Croz, Nag Central Office.
*     Sven Hammarling, Nag Central Office.
*     Richard Hanson, Sandia National Labs.
*
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
*     .. Local Scalars ..
      DOUBLE PRECISION   TEMP
      INTEGER            I, INFO, IX, J, JY, KX
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF     ( M.LT.0 )THEN
         INFO = 1
      ELSE IF( N.LT.0 )THEN
         INFO = 2
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 5
      ELSE IF( INCY.EQ.0 )THEN
         INFO = 7
      ELSE IF( LDA.LT.MAX( 1, M ) )THEN
         INFO = 9
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DGER  ', INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) )
     $   RETURN
*
*     Start the operations. In this version the elements of A are
*     accessed sequentially with one pass through A.
*
      IF( INCY.GT.0 )THEN
         JY = 1
      ELSE
         JY = 1 - ( N - 1 )*INCY
      END IF
      IF( INCX.EQ.1 )THEN
         DO 20, J = 1, N
            IF( Y( JY ).NE.ZERO )THEN
               TEMP = ALPHA*Y( JY )
               DO 10, I = 1, M
                  A( I, J ) = A( I, J ) + X( I )*TEMP
   10          CONTINUE
            END IF
            JY = JY + INCY
   20    CONTINUE
      ELSE
         IF( INCX.GT.0 )THEN
            KX = 1
         ELSE
            KX = 1 - ( M - 1 )*INCX
         END IF
         DO 40, J = 1, N
            IF( Y( JY ).NE.ZERO )THEN
               TEMP = ALPHA*Y( JY )
               IX   = KX
               DO 30, I = 1, M
                  A( I, J ) = A( I, J ) + X( IX )*TEMP
                  IX        = IX        + INCX
   30          CONTINUE
            END IF
            JY = JY + INCY
   40    CONTINUE
      END IF
*
      RETURN
*
*     End of DGER  .
*
      END
      SUBROUTINE DTPMV ( UPLO, TRANS, DIAG, N, AP, X, INCX )
*     .. Scalar Arguments ..
      INTEGER            INCX, N
      CHARACTER*1        DIAG, TRANS, UPLO
*     .. Array Arguments ..
      DOUBLE PRECISION   AP( * ), X( * )
*     ..
*
*  Purpose
*  =======
*
*  DTPMV  performs one of the matrix-vector operations
*
*     x := A*x,   or   x := A'*x,
*
*  where x is an n element vector and  A is an n by n unit, or non-unit,
*  upper or lower triangular matrix, supplied in packed form.
*
*  Parameters
*  ==========
*
*  UPLO   - CHARACTER*1.
*           On entry, UPLO specifies whether the matrix is an upper or
*           lower triangular matrix as follows:
*
*              UPLO = 'U' or 'u'   A is an upper triangular matrix.
*
*              UPLO = 'L' or 'l'   A is a lower triangular matrix.
*
*           Unchanged on exit.
*
*  TRANS  - CHARACTER*1.
*           On entry, TRANS specifies the operation to be performed as
*           follows:
*
*              TRANS = 'N' or 'n'   x := A*x.
*
*              TRANS = 'T' or 't'   x := A'*x.
*
*              TRANS = 'C' or 'c'   x := A'*x.
*
*           Unchanged on exit.
*
*  DIAG   - CHARACTER*1.
*           On entry, DIAG specifies whether or not A is unit
*           triangular as follows:
*
*              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
*
*              DIAG = 'N' or 'n'   A is not assumed to be unit
*                                  triangular.
*
*           Unchanged on exit.
*
*  N      - INTEGER.
*           On entry, N specifies the order of the matrix A.
*           N must be at least zero.
*           Unchanged on exit.
*
*  AP     - DOUBLE PRECISION array of DIMENSION at least
*           ( ( n*( n + 1 ) )/2 ).
*           Before entry with  UPLO = 'U' or 'u', the array AP must
*           contain the upper triangular matrix packed sequentially,
*           column by column, so that AP( 1 ) contains a( 1, 1 ),
*           AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
*           respectively, and so on.
*           Before entry with UPLO = 'L' or 'l', the array AP must
*           contain the lower triangular matrix packed sequentially,
*           column by column, so that AP( 1 ) contains a( 1, 1 ),
*           AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
*           respectively, and so on.
*           Note that when  DIAG = 'U' or 'u', the diagonal elements of
*           A are not referenced, but are assumed to be unity.
*           Unchanged on exit.
*
*  X      - DOUBLE PRECISION array of dimension at least
*           ( 1 + ( n - 1 )*abs( INCX ) ).
*           Before entry, the incremented array X must contain the n
*           element vector x. On exit, X is overwritten with the
*           tranformed vector x.
*
*  INCX   - INTEGER.
*           On entry, INCX specifies the increment for the elements of
*           X. INCX must not be zero.
*           Unchanged on exit.
*
*
*  Level 2 Blas routine.
*
*  -- Written on 22-October-1986.
*     Jack Dongarra, Argonne National Lab.
*     Jeremy Du Croz, Nag Central Office.
*     Sven Hammarling, Nag Central Office.
*     Richard Hanson, Sandia National Labs.
*
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
*     .. Local Scalars ..
      DOUBLE PRECISION   TEMP
      INTEGER            I, INFO, IX, J, JX, K, KK, KX
      LOGICAL            NOUNIT
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF     ( .NOT.LSAME( UPLO , 'U' ).AND.
     $         .NOT.LSAME( UPLO , 'L' )      )THEN
         INFO = 1
      ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND.
     $         .NOT.LSAME( TRANS, 'T' ).AND.
     $         .NOT.LSAME( TRANS, 'C' )      )THEN
         INFO = 2
      ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND.
     $         .NOT.LSAME( DIAG , 'N' )      )THEN
         INFO = 3
      ELSE IF( N.LT.0 )THEN
         INFO = 4
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 7
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DTPMV ', INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( N.EQ.0 )
     $   RETURN
*
      NOUNIT = LSAME( DIAG, 'N' )
*
*     Set up the start point in X if the increment is not unity. This
*     will be  ( N - 1 )*INCX  too small for descending loops.
*
      IF( INCX.LE.0 )THEN
         KX = 1 - ( N - 1 )*INCX
      ELSE IF( INCX.NE.1 )THEN
         KX = 1
      END IF
*
*     Start the operations. In this version the elements of AP are
*     accessed sequentially with one pass through AP.
*
      IF( LSAME( TRANS, 'N' ) )THEN
*
*        Form  x:= A*x.
*
         IF( LSAME( UPLO, 'U' ) )THEN
            KK =1
            IF( INCX.EQ.1 )THEN
               DO 20, J = 1, N
                  IF( X( J ).NE.ZERO )THEN
                     TEMP = X( J )
                     K    = KK
                     DO 10, I = 1, J - 1
                        X( I ) = X( I ) + TEMP*AP( K )
                        K      = K      + 1
   10                CONTINUE
                     IF( NOUNIT )
     $                  X( J ) = X( J )*AP( KK + J - 1 )
                  END IF
                  KK = KK + J
   20          CONTINUE
            ELSE
               JX = KX
               DO 40, J = 1, N
                  IF( X( JX ).NE.ZERO )THEN
                     TEMP = X( JX )
                     IX   = KX
                     DO 30, K = KK, KK + J - 2
                        X( IX ) = X( IX ) + TEMP*AP( K )
                        IX      = IX      + INCX
   30                CONTINUE
                     IF( NOUNIT )
     $                  X( JX ) = X( JX )*AP( KK + J - 1 )
                  END IF
                  JX = JX + INCX
                  KK = KK + J
   40          CONTINUE
            END IF
         ELSE
            KK = ( N*( N + 1 ) )/2
            IF( INCX.EQ.1 )THEN
               DO 60, J = N, 1, -1
                  IF( X( J ).NE.ZERO )THEN
                     TEMP = X( J )
                     K    = KK
                     DO 50, I = N, J + 1, -1
                        X( I ) = X( I ) + TEMP*AP( K )
                        K      = K      - 1
   50                CONTINUE
                     IF( NOUNIT )
     $                  X( J ) = X( J )*AP( KK - N + J )
                  END IF
                  KK = KK - ( N - J + 1 )
   60          CONTINUE
            ELSE
               KX = KX + ( N - 1 )*INCX
               JX = KX
               DO 80, J = N, 1, -1
                  IF( X( JX ).NE.ZERO )THEN
                     TEMP = X( JX )
                     IX   = KX
                     DO 70, K = KK, KK - ( N - ( J + 1 ) ), -1
                        X( IX ) = X( IX ) + TEMP*AP( K )
                        IX      = IX      - INCX
   70                CONTINUE
                     IF( NOUNIT )
     $                  X( JX ) = X( JX )*AP( KK - N + J )
                  END IF
                  JX = JX - INCX
                  KK = KK - ( N - J + 1 )
   80          CONTINUE
            END IF
         END IF
      ELSE
*
*        Form  x := A'*x.
*
         IF( LSAME( UPLO, 'U' ) )THEN
            KK = ( N*( N + 1 ) )/2
            IF( INCX.EQ.1 )THEN
               DO 100, J = N, 1, -1
                  TEMP = X( J )
                  IF( NOUNIT )
     $               TEMP = TEMP*AP( KK )
                  K = KK - 1
                  DO 90, I = J - 1, 1, -1
                     TEMP = TEMP + AP( K )*X( I )
                     K    = K    - 1
   90             CONTINUE
                  X( J ) = TEMP
                  KK     = KK   - J
  100          CONTINUE
            ELSE
               JX = KX + ( N - 1 )*INCX
               DO 120, J = N, 1, -1
                  TEMP = X( JX )
                  IX   = JX
                  IF( NOUNIT )
     $               TEMP = TEMP*AP( KK )
                  DO 110, K = KK - 1, KK - J + 1, -1
                     IX   = IX   - INCX
                     TEMP = TEMP + AP( K )*X( IX )
  110             CONTINUE
                  X( JX ) = TEMP
                  JX      = JX   - INCX
                  KK      = KK   - J
  120          CONTINUE
            END IF
         ELSE
            KK = 1
            IF( INCX.EQ.1 )THEN
               DO 140, J = 1, N
                  TEMP = X( J )
                  IF( NOUNIT )
     $               TEMP = TEMP*AP( KK )
                  K = KK + 1
                  DO 130, I = J + 1, N
                     TEMP = TEMP + AP( K )*X( I )
                     K    = K    + 1
  130             CONTINUE
                  X( J ) = TEMP
                  KK     = KK   + ( N - J + 1 )
  140          CONTINUE
            ELSE
               JX = KX
               DO 160, J = 1, N
                  TEMP = X( JX )
                  IX   = JX
                  IF( NOUNIT )
     $               TEMP = TEMP*AP( KK )
                  DO 150, K = KK + 1, KK + N - J
                     IX   = IX   + INCX
                     TEMP = TEMP + AP( K )*X( IX )
  150             CONTINUE
                  X( JX ) = TEMP
                  JX      = JX   + INCX
                  KK      = KK   + ( N - J + 1 )
  160          CONTINUE
            END IF
         END IF
      END IF
*
      RETURN
*
*     End of DTPMV .
*
      END
      SUBROUTINE DTPSV ( UPLO, TRANS, DIAG, N, AP, X, INCX )
*     .. Scalar Arguments ..
      INTEGER            INCX, N
      CHARACTER*1        DIAG, TRANS, UPLO
*     .. Array Arguments ..
      DOUBLE PRECISION   AP( * ), X( * )
*     ..
*
*  Purpose
*  =======
*
*  DTPSV  solves one of the systems of equations
*
*     A*x = b,   or   A'*x = b,
*
*  where b and x are n element vectors and A is an n by n unit, or
*  non-unit, upper or lower triangular matrix, supplied in packed form.
*
*  No test for singularity or near-singularity is included in this
*  routine. Such tests must be performed before calling this routine.
*
*  Parameters
*  ==========
*
*  UPLO   - CHARACTER*1.
*           On entry, UPLO specifies whether the matrix is an upper or
*           lower triangular matrix as follows:
*
*              UPLO = 'U' or 'u'   A is an upper triangular matrix.
*
*              UPLO = 'L' or 'l'   A is a lower triangular matrix.
*
*           Unchanged on exit.
*
*  TRANS  - CHARACTER*1.
*           On entry, TRANS specifies the equations to be solved as
*           follows:
*
*              TRANS = 'N' or 'n'   A*x = b.
*
*              TRANS = 'T' or 't'   A'*x = b.
*
*              TRANS = 'C' or 'c'   A'*x = b.
*
*           Unchanged on exit.
*
*  DIAG   - CHARACTER*1.
*           On entry, DIAG specifies whether or not A is unit
*           triangular as follows:
*
*              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
*
*              DIAG = 'N' or 'n'   A is not assumed to be unit
*                                  triangular.
*
*           Unchanged on exit.
*
*  N      - INTEGER.
*           On entry, N specifies the order of the matrix A.
*           N must be at least zero.
*           Unchanged on exit.
*
*  AP     - DOUBLE PRECISION array of DIMENSION at least
*           ( ( n*( n + 1 ) )/2 ).
*           Before entry with  UPLO = 'U' or 'u', the array AP must
*           contain the upper triangular matrix packed sequentially,
*           column by column, so that AP( 1 ) contains a( 1, 1 ),
*           AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
*           respectively, and so on.
*           Before entry with UPLO = 'L' or 'l', the array AP must
*           contain the lower triangular matrix packed sequentially,
*           column by column, so that AP( 1 ) contains a( 1, 1 ),
*           AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
*           respectively, and so on.
*           Note that when  DIAG = 'U' or 'u', the diagonal elements of
*           A are not referenced, but are assumed to be unity.
*           Unchanged on exit.
*
*  X      - DOUBLE PRECISION array of dimension at least
*           ( 1 + ( n - 1 )*abs( INCX ) ).
*           Before entry, the incremented array X must contain the n
*           element right-hand side vector b. On exit, X is overwritten
*           with the solution vector x.
*
*  INCX   - INTEGER.
*           On entry, INCX specifies the increment for the elements of
*           X. INCX must not be zero.
*           Unchanged on exit.
*
*
*  Level 2 Blas routine.
*
*  -- Written on 22-October-1986.
*     Jack Dongarra, Argonne National Lab.
*     Jeremy Du Croz, Nag Central Office.
*     Sven Hammarling, Nag Central Office.
*     Richard Hanson, Sandia National Labs.
*
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
*     .. Local Scalars ..
      DOUBLE PRECISION   TEMP
      INTEGER            I, INFO, IX, J, JX, K, KK, KX
      LOGICAL            NOUNIT
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF     ( .NOT.LSAME( UPLO , 'U' ).AND.
     $         .NOT.LSAME( UPLO , 'L' )      )THEN
         INFO = 1
      ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND.
     $         .NOT.LSAME( TRANS, 'T' ).AND.
     $         .NOT.LSAME( TRANS, 'C' )      )THEN
         INFO = 2
      ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND.
     $         .NOT.LSAME( DIAG , 'N' )      )THEN
         INFO = 3
      ELSE IF( N.LT.0 )THEN
         INFO = 4
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 7
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DTPSV ', INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( N.EQ.0 )
     $   RETURN
*
      NOUNIT = LSAME( DIAG, 'N' )
*
*     Set up the start point in X if the increment is not unity. This
*     will be  ( N - 1 )*INCX  too small for descending loops.
*
      IF( INCX.LE.0 )THEN
         KX = 1 - ( N - 1 )*INCX
      ELSE IF( INCX.NE.1 )THEN
         KX = 1
      END IF
*
*     Start the operations. In this version the elements of AP are
*     accessed sequentially with one pass through AP.
*
      IF( LSAME( TRANS, 'N' ) )THEN
*
*        Form  x := inv( A )*x.
*
         IF( LSAME( UPLO, 'U' ) )THEN
            KK = ( N*( N + 1 ) )/2
            IF( INCX.EQ.1 )THEN
               DO 20, J = N, 1, -1
                  IF( X( J ).NE.ZERO )THEN
                     IF( NOUNIT )
     $                  X( J ) = X( J )/AP( KK )
                     TEMP = X( J )
                     K    = KK     - 1
                     DO 10, I = J - 1, 1, -1
                        X( I ) = X( I ) - TEMP*AP( K )
                        K      = K      - 1
   10                CONTINUE
                  END IF
                  KK = KK - J
   20          CONTINUE
            ELSE
               JX = KX + ( N - 1 )*INCX
               DO 40, J = N, 1, -1
                  IF( X( JX ).NE.ZERO )THEN
                     IF( NOUNIT )
     $                  X( JX ) = X( JX )/AP( KK )
                     TEMP = X( JX )
                     IX   = JX
                     DO 30, K = KK - 1, KK - J + 1, -1
                        IX      = IX      - INCX
                        X( IX ) = X( IX ) - TEMP*AP( K )
   30                CONTINUE
                  END IF
                  JX = JX - INCX
                  KK = KK - J
   40          CONTINUE
            END IF
         ELSE
            KK = 1
            IF( INCX.EQ.1 )THEN
               DO 60, J = 1, N
                  IF( X( J ).NE.ZERO )THEN
                     IF( NOUNIT )
     $                  X( J ) = X( J )/AP( KK )
                     TEMP = X( J )
                     K    = KK     + 1
                     DO 50, I = J + 1, N
                        X( I ) = X( I ) - TEMP*AP( K )
                        K      = K      + 1
   50                CONTINUE
                  END IF
                  KK = KK + ( N - J + 1 )
   60          CONTINUE
            ELSE
               JX = KX
               DO 80, J = 1, N
                  IF( X( JX ).NE.ZERO )THEN
                     IF( NOUNIT )
     $                  X( JX ) = X( JX )/AP( KK )
                     TEMP = X( JX )
                     IX   = JX
                     DO 70, K = KK + 1, KK + N - J
                        IX      = IX      + INCX
                        X( IX ) = X( IX ) - TEMP*AP( K )
   70                CONTINUE
                  END IF
                  JX = JX + INCX
                  KK = KK + ( N - J + 1 )
   80          CONTINUE
            END IF
         END IF
      ELSE
*
*        Form  x := inv( A' )*x.
*
         IF( LSAME( UPLO, 'U' ) )THEN
            KK = 1
            IF( INCX.EQ.1 )THEN
               DO 100, J = 1, N
                  TEMP = X( J )
                  K    = KK
                  DO 90, I = 1, J - 1
                     TEMP = TEMP - AP( K )*X( I )
                     K    = K    + 1
   90             CONTINUE
                  IF( NOUNIT )
     $               TEMP = TEMP/AP( KK + J - 1 )
                  X( J ) = TEMP
                  KK     = KK   + J
  100          CONTINUE
            ELSE
               JX = KX
               DO 120, J = 1, N
                  TEMP = X( JX )
                  IX   = KX
                  DO 110, K = KK, KK + J - 2
                     TEMP = TEMP - AP( K )*X( IX )
                     IX   = IX   + INCX
  110             CONTINUE
                  IF( NOUNIT )
     $               TEMP = TEMP/AP( KK + J - 1 )
                  X( JX ) = TEMP
                  JX      = JX   + INCX
                  KK      = KK   + J
  120          CONTINUE
            END IF
         ELSE
            KK = ( N*( N + 1 ) )/2
            IF( INCX.EQ.1 )THEN
               DO 140, J = N, 1, -1
                  TEMP = X( J )
                  K = KK
                  DO 130, I = N, J + 1, -1
                     TEMP = TEMP - AP( K )*X( I )
                     K    = K    - 1
  130             CONTINUE
                  IF( NOUNIT )
     $               TEMP = TEMP/AP( KK - N + J )
                  X( J ) = TEMP
                  KK     = KK   - ( N - J + 1 )
  140          CONTINUE
            ELSE
               KX = KX + ( N - 1 )*INCX
               JX = KX
               DO 160, J = N, 1, -1
                  TEMP = X( JX )
                  IX   = KX
                  DO 150, K = KK, KK - ( N - ( J + 1 ) ), -1
                     TEMP = TEMP - AP( K )*X( IX )
                     IX   = IX   - INCX
  150             CONTINUE
                  IF( NOUNIT )
     $               TEMP = TEMP/AP( KK - N + J )
                  X( JX ) = TEMP
                  JX      = JX   - INCX
                  KK      = KK   - (N - J + 1 )
  160          CONTINUE
            END IF
         END IF
      END IF
*
      RETURN
*
*     End of DTPSV .
*
      END
      SUBROUTINE DTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
*     .. Scalar Arguments ..
      INTEGER            INCX, LDA, N
      CHARACTER*1        DIAG, TRANS, UPLO
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), X( * )
*     ..
*
*  Purpose
*  =======
*
*  DTRMV  performs one of the matrix-vector operations
*
*     x := A*x,   or   x := A'*x,
*
*  where x is an n element vector and  A is an n by n unit, or non-unit,
*  upper or lower triangular matrix.
*
*  Parameters
*  ==========
*
*  UPLO   - CHARACTER*1.
*           On entry, UPLO specifies whether the matrix is an upper or
*           lower triangular matrix as follows:
*
*              UPLO = 'U' or 'u'   A is an upper triangular matrix.
*
*              UPLO = 'L' or 'l'   A is a lower triangular matrix.
*
*           Unchanged on exit.
*
*  TRANS  - CHARACTER*1.
*           On entry, TRANS specifies the operation to be performed as
*           follows:
*
*              TRANS = 'N' or 'n'   x := A*x.
*
*              TRANS = 'T' or 't'   x := A'*x.
*
*              TRANS = 'C' or 'c'   x := A'*x.
*
*           Unchanged on exit.
*
*  DIAG   - CHARACTER*1.
*           On entry, DIAG specifies whether or not A is unit
*           triangular as follows:
*
*              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
*
*              DIAG = 'N' or 'n'   A is not assumed to be unit
*                                  triangular.
*
*           Unchanged on exit.
*
*  N      - INTEGER.
*           On entry, N specifies the order of the matrix A.
*           N must be at least zero.
*           Unchanged on exit.
*
*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
*           Before entry with  UPLO = 'U' or 'u', the leading n by n
*           upper triangular part of the array A must contain the upper
*           triangular matrix and the strictly lower triangular part of
*           A is not referenced.
*           Before entry with UPLO = 'L' or 'l', the leading n by n
*           lower triangular part of the array A must contain the lower
*           triangular matrix and the strictly upper triangular part of
*           A is not referenced.
*           Note that when  DIAG = 'U' or 'u', the diagonal elements of
*           A are not referenced either, but are assumed to be unity.
*           Unchanged on exit.
*
*  LDA    - INTEGER.
*           On entry, LDA specifies the first dimension of A as declared
*           in the calling (sub) program. LDA must be at least
*           max( 1, n ).
*           Unchanged on exit.
*
*  X      - DOUBLE PRECISION array of dimension at least
*           ( 1 + ( n - 1 )*abs( INCX ) ).
*           Before entry, the incremented array X must contain the n
*           element vector x. On exit, X is overwritten with the
*           tranformed vector x.
*
*  INCX   - INTEGER.
*           On entry, INCX specifies the increment for the elements of
*           X. INCX must not be zero.
*           Unchanged on exit.
*
*
*  Level 2 Blas routine.
*
*  -- Written on 22-October-1986.
*     Jack Dongarra, Argonne National Lab.
*     Jeremy Du Croz, Nag Central Office.
*     Sven Hammarling, Nag Central Office.
*     Richard Hanson, Sandia National Labs.
*
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
*     .. Local Scalars ..
      DOUBLE PRECISION   TEMP
      INTEGER            I, INFO, IX, J, JX, KX
      LOGICAL            NOUNIT
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF     ( .NOT.LSAME( UPLO , 'U' ).AND.
     $         .NOT.LSAME( UPLO , 'L' )      )THEN
         INFO = 1
      ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND.
     $         .NOT.LSAME( TRANS, 'T' ).AND.
     $         .NOT.LSAME( TRANS, 'C' )      )THEN
         INFO = 2
      ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND.
     $         .NOT.LSAME( DIAG , 'N' )      )THEN
         INFO = 3
      ELSE IF( N.LT.0 )THEN
         INFO = 4
      ELSE IF( LDA.LT.MAX( 1, N ) )THEN
         INFO = 6
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 8
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DTRMV ', INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( N.EQ.0 )
     $   RETURN
*
      NOUNIT = LSAME( DIAG, 'N' )
*
*     Set up the start point in X if the increment is not unity. This
*     will be  ( N - 1 )*INCX  too small for descending loops.
*
      IF( INCX.LE.0 )THEN
         KX = 1 - ( N - 1 )*INCX
      ELSE IF( INCX.NE.1 )THEN
         KX = 1
      END IF
*
*     Start the operations. In this version the elements of A are
*     accessed sequentially with one pass through A.
*
      IF( LSAME( TRANS, 'N' ) )THEN
*
*        Form  x := A*x.
*
         IF( LSAME( UPLO, 'U' ) )THEN
            IF( INCX.EQ.1 )THEN
               DO 20, J = 1, N
                  IF( X( J ).NE.ZERO )THEN
                     TEMP = X( J )
                     DO 10, I = 1, J - 1
                        X( I ) = X( I ) + TEMP*A( I, J )
   10                CONTINUE
                     IF( NOUNIT )
     $                  X( J ) = X( J )*A( J, J )
                  END IF
   20          CONTINUE
            ELSE
               JX = KX
               DO 40, J = 1, N
                  IF( X( JX ).NE.ZERO )THEN
                     TEMP = X( JX )
                     IX   = KX
                     DO 30, I = 1, J - 1
                        X( IX ) = X( IX ) + TEMP*A( I, J )
                        IX      = IX      + INCX
   30                CONTINUE
                     IF( NOUNIT )
     $                  X( JX ) = X( JX )*A( J, J )
                  END IF
                  JX = JX + INCX
   40          CONTINUE
            END IF
         ELSE
            IF( INCX.EQ.1 )THEN
               DO 60, J = N, 1, -1
                  IF( X( J ).NE.ZERO )THEN
                     TEMP = X( J )
                     DO 50, I = N, J + 1, -1
                        X( I ) = X( I ) + TEMP*A( I, J )
   50                CONTINUE
                     IF( NOUNIT )
     $                  X( J ) = X( J )*A( J, J )
                  END IF
   60          CONTINUE
            ELSE
               KX = KX + ( N - 1 )*INCX
               JX = KX
               DO 80, J = N, 1, -1
                  IF( X( JX ).NE.ZERO )THEN
                     TEMP = X( JX )
                     IX   = KX
                     DO 70, I = N, J + 1, -1
                        X( IX ) = X( IX ) + TEMP*A( I, J )
                        IX      = IX      - INCX
   70                CONTINUE
                     IF( NOUNIT )
     $                  X( JX ) = X( JX )*A( J, J )
                  END IF
                  JX = JX - INCX
   80          CONTINUE
            END IF
         END IF
      ELSE
*
*        Form  x := A'*x.
*
         IF( LSAME( UPLO, 'U' ) )THEN
            IF( INCX.EQ.1 )THEN
               DO 100, J = N, 1, -1
                  TEMP = X( J )
                  IF( NOUNIT )
     $               TEMP = TEMP*A( J, J )
                  DO 90, I = J - 1, 1, -1
                     TEMP = TEMP + A( I, J )*X( I )
   90             CONTINUE
                  X( J ) = TEMP
  100          CONTINUE
            ELSE
               JX = KX + ( N - 1 )*INCX
               DO 120, J = N, 1, -1
                  TEMP = X( JX )
                  IX   = JX
                  IF( NOUNIT )
     $               TEMP = TEMP*A( J, J )
                  DO 110, I = J - 1, 1, -1
                     IX   = IX   - INCX
                     TEMP = TEMP + A( I, J )*X( IX )
  110             CONTINUE
                  X( JX ) = TEMP
                  JX      = JX   - INCX
  120          CONTINUE
            END IF
         ELSE
            IF( INCX.EQ.1 )THEN
               DO 140, J = 1, N
                  TEMP = X( J )
                  IF( NOUNIT )
     $               TEMP = TEMP*A( J, J )
                  DO 130, I = J + 1, N
                     TEMP = TEMP + A( I, J )*X( I )
  130             CONTINUE
                  X( J ) = TEMP
  140          CONTINUE
            ELSE
               JX = KX
               DO 160, J = 1, N
                  TEMP = X( JX )
                  IX   = JX
                  IF( NOUNIT )
     $               TEMP = TEMP*A( J, J )
                  DO 150, I = J + 1, N
                     IX   = IX   + INCX
                     TEMP = TEMP + A( I, J )*X( IX )
  150             CONTINUE
                  X( JX ) = TEMP
                  JX      = JX   + INCX
  160          CONTINUE
            END IF
         END IF
      END IF
*
      RETURN
*
*     End of DTRMV .
*
      END
      SUBROUTINE DTRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
*     .. Scalar Arguments ..
      INTEGER            INCX, LDA, N
      CHARACTER*1        DIAG, TRANS, UPLO
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), X( * )
*     ..
*
*  Purpose
*  =======
*
*  DTRSV  solves one of the systems of equations
*
*     A*x = b,   or   A'*x = b,
*
*  where b and x are n element vectors and A is an n by n unit, or
*  non-unit, upper or lower triangular matrix.
*
*  No test for singularity or near-singularity is included in this
*  routine. Such tests must be performed before calling this routine.
*
*  Parameters
*  ==========
*
*  UPLO   - CHARACTER*1.
*           On entry, UPLO specifies whether the matrix is an upper or
*           lower triangular matrix as follows:
*
*              UPLO = 'U' or 'u'   A is an upper triangular matrix.
*
*              UPLO = 'L' or 'l'   A is a lower triangular matrix.
*
*           Unchanged on exit.
*
*  TRANS  - CHARACTER*1.
*           On entry, TRANS specifies the equations to be solved as
*           follows:
*
*              TRANS = 'N' or 'n'   A*x = b.
*
*              TRANS = 'T' or 't'   A'*x = b.
*
*              TRANS = 'C' or 'c'   A'*x = b.
*
*           Unchanged on exit.
*
*  DIAG   - CHARACTER*1.
*           On entry, DIAG specifies whether or not A is unit
*           triangular as follows:
*
*              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
*
*              DIAG = 'N' or 'n'   A is not assumed to be unit
*                                  triangular.
*
*           Unchanged on exit.
*
*  N      - INTEGER.
*           On entry, N specifies the order of the matrix A.
*           N must be at least zero.
*           Unchanged on exit.
*
*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
*           Before entry with  UPLO = 'U' or 'u', the leading n by n
*           upper triangular part of the array A must contain the upper
*           triangular matrix and the strictly lower triangular part of
*           A is not referenced.
*           Before entry with UPLO = 'L' or 'l', the leading n by n
*           lower triangular part of the array A must contain the lower
*           triangular matrix and the strictly upper triangular part of
*           A is not referenced.
*           Note that when  DIAG = 'U' or 'u', the diagonal elements of
*           A are not referenced either, but are assumed to be unity.
*           Unchanged on exit.
*
*  LDA    - INTEGER.
*           On entry, LDA specifies the first dimension of A as declared
*           in the calling (sub) program. LDA must be at least
*           max( 1, n ).
*           Unchanged on exit.
*
*  X      - DOUBLE PRECISION array of dimension at least
*           ( 1 + ( n - 1 )*abs( INCX ) ).
*           Before entry, the incremented array X must contain the n
*           element right-hand side vector b. On exit, X is overwritten
*           with the solution vector x.
*
*  INCX   - INTEGER.
*           On entry, INCX specifies the increment for the elements of
*           X. INCX must not be zero.
*           Unchanged on exit.
*
*
*  Level 2 Blas routine.
*
*  -- Written on 22-October-1986.
*     Jack Dongarra, Argonne National Lab.
*     Jeremy Du Croz, Nag Central Office.
*     Sven Hammarling, Nag Central Office.
*     Richard Hanson, Sandia National Labs.
*
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
*     .. Local Scalars ..
      DOUBLE PRECISION   TEMP
      INTEGER            I, INFO, IX, J, JX, KX
      LOGICAL            NOUNIT
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF     ( .NOT.LSAME( UPLO , 'U' ).AND.
     $         .NOT.LSAME( UPLO , 'L' )      )THEN
         INFO = 1
      ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND.
     $         .NOT.LSAME( TRANS, 'T' ).AND.
     $         .NOT.LSAME( TRANS, 'C' )      )THEN
         INFO = 2
      ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND.
     $         .NOT.LSAME( DIAG , 'N' )      )THEN
         INFO = 3
      ELSE IF( N.LT.0 )THEN
         INFO = 4
      ELSE IF( LDA.LT.MAX( 1, N ) )THEN
         INFO = 6
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 8
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DTRSV ', INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( N.EQ.0 )
     $   RETURN
*
      NOUNIT = LSAME( DIAG, 'N' )
*
*     Set up the start point in X if the increment is not unity. This
*     will be  ( N - 1 )*INCX  too small for descending loops.
*
      IF( INCX.LE.0 )THEN
         KX = 1 - ( N - 1 )*INCX
      ELSE IF( INCX.NE.1 )THEN
         KX = 1
      END IF
*
*     Start the operations. In this version the elements of A are
*     accessed sequentially with one pass through A.
*
      IF( LSAME( TRANS, 'N' ) )THEN
*
*        Form  x := inv( A )*x.
*
         IF( LSAME( UPLO, 'U' ) )THEN
            IF( INCX.EQ.1 )THEN
               DO 20, J = N, 1, -1
                  IF( X( J ).NE.ZERO )THEN
                     IF( NOUNIT )
     $                  X( J ) = X( J )/A( J, J )
                     TEMP = X( J )
                     DO 10, I = J - 1, 1, -1
                        X( I ) = X( I ) - TEMP*A( I, J )
   10                CONTINUE
                  END IF
   20          CONTINUE
            ELSE
               JX = KX + ( N - 1 )*INCX
               DO 40, J = N, 1, -1
                  IF( X( JX ).NE.ZERO )THEN
                     IF( NOUNIT )
     $                  X( JX ) = X( JX )/A( J, J )
                     TEMP = X( JX )
                     IX   = JX
                     DO 30, I = J - 1, 1, -1
                        IX      = IX      - INCX
                        X( IX ) = X( IX ) - TEMP*A( I, J )
   30                CONTINUE
                  END IF
                  JX = JX - INCX
   40          CONTINUE
            END IF
         ELSE
            IF( INCX.EQ.1 )THEN
               DO 60, J = 1, N
                  IF( X( J ).NE.ZERO )THEN
                     IF( NOUNIT )
     $                  X( J ) = X( J )/A( J, J )
                     TEMP = X( J )
                     DO 50, I = J + 1, N
                        X( I ) = X( I ) - TEMP*A( I, J )
   50                CONTINUE
                  END IF
   60          CONTINUE
            ELSE
               JX = KX
               DO 80, J = 1, N
                  IF( X( JX ).NE.ZERO )THEN
                     IF( NOUNIT )
     $                  X( JX ) = X( JX )/A( J, J )
                     TEMP = X( JX )
                     IX   = JX
                     DO 70, I = J + 1, N
                        IX      = IX      + INCX
                        X( IX ) = X( IX ) - TEMP*A( I, J )
   70                CONTINUE
                  END IF
                  JX = JX + INCX
   80          CONTINUE
            END IF
         END IF
      ELSE
*
*        Form  x := inv( A' )*x.
*
         IF( LSAME( UPLO, 'U' ) )THEN
            IF( INCX.EQ.1 )THEN
               DO 100, J = 1, N
                  TEMP = X( J )
                  DO 90, I = 1, J - 1
                     TEMP = TEMP - A( I, J )*X( I )
   90             CONTINUE
                  IF( NOUNIT )
     $               TEMP = TEMP/A( J, J )
                  X( J ) = TEMP
  100          CONTINUE
            ELSE
               JX = KX
               DO 120, J = 1, N
                  TEMP = X( JX )
                  IX   = KX
                  DO 110, I = 1, J - 1
                     TEMP = TEMP - A( I, J )*X( IX )
                     IX   = IX   + INCX
  110             CONTINUE
                  IF( NOUNIT )
     $               TEMP = TEMP/A( J, J )
                  X( JX ) = TEMP
                  JX      = JX   + INCX
  120          CONTINUE
            END IF
         ELSE
            IF( INCX.EQ.1 )THEN
               DO 140, J = N, 1, -1
                  TEMP = X( J )
                  DO 130, I = N, J + 1, -1
                     TEMP = TEMP - A( I, J )*X( I )
  130             CONTINUE
                  IF( NOUNIT )
     $               TEMP = TEMP/A( J, J )
                  X( J ) = TEMP
  140          CONTINUE
            ELSE
               KX = KX + ( N - 1 )*INCX
               JX = KX
               DO 160, J = N, 1, -1
                  TEMP = X( JX )
                  IX   = KX
                  DO 150, I = N, J + 1, -1
                     TEMP = TEMP - A( I, J )*X( IX )
                     IX   = IX   - INCX
  150             CONTINUE
                  IF( NOUNIT )
     $               TEMP = TEMP/A( J, J )
                  X( JX ) = TEMP
                  JX      = JX   - INCX
  160          CONTINUE
            END IF
         END IF
      END IF
*
      RETURN
*
*     End of DTRSV .
*
      END
SHAR_EOF
fi # end of overwriting check
if test -f 'blas1.f'
then
	echo shar: will not over-write existing file "'blas1.f'"
else
cat << \SHAR_EOF > 'blas1.f'
      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     modified 12/3/93, array(1) declarations changed to array(*)
c
      double precision dx(*),dy(*)
      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
      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     modified 12/3/93, array(1) declarations changed to array(*)
c
      double precision dx(*),dy(*),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
      DOUBLE PRECISION FUNCTION DNRM2 ( N, X, INCX )
*     .. Scalar Arguments ..
      INTEGER                           INCX, N
*     .. Array Arguments ..
      DOUBLE PRECISION                  X( * )
*     ..
*
*  DNRM2 returns the euclidean norm of a vector via the function
*  name, so that
*
*     DNRM2 := sqrt( x'*x )
*
*
*
*  -- This version written on 25-October-1982.
*     Modified on 14-October-1993 to inline the call to DLASSQ.
*     Sven Hammarling, Nag Ltd.
*
*
*     .. Parameters ..
      DOUBLE PRECISION      ONE         , ZERO
      PARAMETER           ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     .. Local Scalars ..
      INTEGER               IX
      DOUBLE PRECISION      ABSXI, NORM, SCALE, SSQ
*     .. Intrinsic Functions ..
      INTRINSIC             ABS, SQRT
*     ..
*     .. Executable Statements ..
      IF( N.LT.1 .OR. INCX.LT.1 )THEN
         NORM  = ZERO
      ELSE IF( N.EQ.1 )THEN
         NORM  = ABS( X( 1 ) )
      ELSE
         SCALE = ZERO
         SSQ   = ONE
*        The following loop is equivalent to this call to the LAPACK
*        auxiliary routine:
*        CALL DLASSQ( N, X, INCX, SCALE, SSQ )
*
         DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX
            IF( X( IX ).NE.ZERO )THEN
               ABSXI = ABS( X( IX ) )
               IF( SCALE.LT.ABSXI )THEN
                  SSQ   = ONE   + SSQ*( SCALE/ABSXI )**2
                  SCALE = ABSXI
               ELSE
                  SSQ   = SSQ   +     ( ABSXI/SCALE )**2
               END IF
            END IF
   10    CONTINUE
         NORM  = SCALE * SQRT( SSQ )
      END IF
*
      DNRM2 = NORM
      RETURN
*
*     End of DNRM2.
*
      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     modified 3/93 to return if incx .le. 0.
c     modified 12/3/93, array(1) declarations changed to array(*)
c
      double precision da,dx(*)
      integer i,incx,m,mp1,n,nincx
c
      if( n.le.0 .or. incx.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  dswap (n,dx,incx,dy,incy)
c
c     interchanges two vectors.
c     uses unrolled loops for increments equal one.
c     jack dongarra, linpack, 3/11/78.
c     modified 12/3/93, array(1) declarations changed to array(*)
c
      double precision dx(*),dy(*),dtemp
      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 not equal
c         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 = dx(ix)
        dx(ix) = dy(iy)
        dy(iy) = dtemp
        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,3)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dtemp = dx(i)
        dx(i) = dy(i)
        dy(i) = dtemp
   30 continue
      if( n .lt. 3 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,3
        dtemp = dx(i)
        dx(i) = dy(i)
        dy(i) = dtemp
        dtemp = dx(i + 1)
        dx(i + 1) = dy(i + 1)
        dy(i + 1) = dtemp
        dtemp = dx(i + 2)
        dx(i + 2) = dy(i + 2)
        dy(i + 2) = dtemp
   50 continue
      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     modified 3/93 to return if incx .le. 0.
c     modified 12/3/93, array(1) declarations changed to array(*)
c
      double precision dx(*),dmax
      integer i,incx,ix,n
c
      idamax = 0
      if( n.lt.1 .or. incx.le.0 ) 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
SHAR_EOF
fi # end of overwriting check
cd ..
#	End of shell archive
exit 0

		
.

NEW PAGES:

[ODDNUGGET]

[GOPHER]