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