C ALGORITHM 652 (NEW VERSION), COLLECTED ALGORITHMS FROM ACM. C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, C VOL. 13, NO. 3, PP. 281-310. C C HOMPACK is a suite of FORTRAN 77 subroutines for solving nonlinear C systems of equations by homotopy methods. There are subroutines for C fixed point, zero finding, and general homotopy curve tracking problems, C utilizing both dense and sparse Jacobian matrices, and implementing C three different algorithms: ODE-based, normal flow, and augmented C Jacobian. The (driver) subroutines called by the user are given in the C table below, and are well documented internally. The user need not C be concerned with any other subroutines in HOMPACK. C C C Problem type C --------|--------|--------|--------|--------|--------| C x = f(x) | F(x) = 0 |rho(a,lambda,x)=0| C --------|--------|--------|--------|--------|--------| C dense | sparse | dense | sparse | dense | sparse | Algorithm C --------|--------|--------|--------|--------|--------|--------------------- C FIXPDF | FIXPDS | FIXPDF | FIXPDS | FIXPDF | FIXPDS | ODE based C --------|--------|--------|--------|--------|--------|--------------------- C FIXPNF | FIXPNS | FIXPNF | FIXPNS | FIXPNF | FIXPNS | normal flow C --------|--------|--------|--------|--------|--------|--------------------- C FIXPQF | FIXPQS | FIXPQF | FIXPQS | FIXPQF | FIXPQS | augmented Jacobian C --------|--------|--------|--------|--------|--------|--------------------- C C C The sparse subroutines use the packed skyline storage scheme standard in C structural mechanics, but any sparse storage scheme can be used by C replacing some of the low-level HOMPACK routines with user-written C routines. The stepping subroutines STEP?? may be of interest to some C users with special curve tracking needs. C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ORGANIZATIONAL DETAILS. HOMPACK is organized in two different ways: by algorithm/problem type and by subroutine level. There are three levels of subroutines. The top level consists of drivers, one for each problem type and algorithm type. Normally these drivers are called by the user, and the user need know nothing beyond them. They allocate storage for the lower level routines, and all the arrays are variable dimension, so there is no limit on problem size. The second subroutine level implements the major components of the algorithms such as stepping along the homotopy zero curve, computing tangents, and the end game for the solution at lambda = 1 . A sophisticated user might call these routines directly to have complete control of the algorithm, or for some other task such as tracking an arbitrary parametrized curve over an arbitrary parameter range. The lowest subroutine level handles the numerical linear algebra, and includes some BLAS routines. All the linear algebra and associated data structure handling are concentrated in these routines, so a user could incorporate his own data structures by writing his own versions of these low level routines. The organization of HOMPACK by algorithm/problem type is shown in the above table, which lists the driver name for each algorithm and problem type. Using brackets to indicate the three subroutine levels described above, the natural grouping of the HOMPACK routines is: [FIXPDF] [FODE, ROOT, SINTRP, STEPS] [DCPOSE] [FIXPDS] [FODEDS, ROOT, SINTRP, STEPDS] [GMFADS, MFACDS, MULTDS, PCGDS, QIMUDS, SOLVDS] [FIXPNF] [ROOTNF, STEPNF, [TANGNF]] [ROOT] [FIXPNS] [ROOTNS, STEPNS, TANGNS] [GMFADS, MFACDS, MULTDS, PCGDS, PCGNS, QIMUDS, ROOT, SOLVDS] [FIXPQF] [ROOTQF, STEPQF, TANGQF] [QRFAQF, QRSLQF, R1UPQF, UPQRQF] [FIXPQS] [ROOTQS, STEPQS, TANGQS] [GMFADS, MULTDS, PCGQS, SOLVDS] [POLSYS] [POLYNF, POLYP, ROOTNF, STEPNF, TANGNF] [DIVP, FFUNP, GFUNP, HFUNP, HFUN1P, INITP, MULP, OTPUTP, POWP, RHO, RHOJAC, ROOT, SCLGNP, STRPTP] The BLAS subroutines used by HOMPACK are DAXPY, DCOPY, DDOT, DNRM2, DSCAL, D1MACH, IDAMAX. The user written subroutines, of which exactly two must be supplied depending on the driver chosen, are F, FJAC, FJACS, RHO, RHOA, RHOJAC, RHOJS. For testing, there are three main test programs MAINF, MAINP, and MAINS, and one data file INNHP.DAT (read by MAINP). Inquiries should be directed to Layne T. Watson, Department of Computer Science, VPI & SU, Blacksburg, VA 24061; (703) 961-7540; watson@cs.vt.edu ltw@vtopus.cs.vt.edu C MAIN PROGRAM TO TEST FIXPNF, FIXPQF, AND FIXPDF C BROWN'S FUNCTION, ZERO FINDING. C C THIS PROGRAM TESTS THE HOMPACK ROUTINES FIXPNF, FIXPQF, AND C FIXPDF. THE USER MAY INSERT CALLS TO A SYSTEM TIMER AT THE C DESIGNATED LOCATIONS IN ORDER TO GET EXECUTION TIME FOR THESE C ROUTINES. C C THE MODIFICATIONS TO BE MADE FOR THE SYSTEM TIMER ARE INDICATED C BY A LINE OF M'S, E.G. CMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM C C C THE OUTPUT FROM THIS ROUTINE SHOULD BE AS FOLLOWS, WITH THE C EXECUTION TIMES CORRESPONDING TO A VAX 11/785. C C TESTING FIXPQF C C LAMBDA = 1.00000000 FLAG = 1 6 JACOBIAN EVALUATIONS C EXECUTION TIME(SECS) = 0.44 ARCLEN = 2.693 C 1.00000000E+00 1.00000000E+00 1.00000000E+00 C 1.00000000E+00 1.00000000E+00 C C TESTING FIXPNF C C LAMBDA = 1.00000000 FLAG = 1 22 JACOBIAN EVALUATIONS C EXECUTION TIME(SECS) = 0.19 ARCLEN = 2.682 C 1.00000000E+00 1.00000000E+00 1.00000000E+00 C 1.00000000E+00 1.00000000E+00 C C TESTING FIXPDF C C LAMBDA = 1.00000000 FLAG = 1 71 JACOBIAN EVALUATIONS C EXECUTION TIME(SECS) = 0.57 ARCLEN = 2.712 C 1.00000000E+00 1.00000000E+00 1.00000000E+00 C 1.00000000E+00 1.00000000E+00 C C C PROGRAM TEST1 IMPLICIT DOUBLE PRECISION (A-H,O-Z) DOUBLE PRECISION WT(101),PHI(101,16),P(101) DOUBLE PRECISION ARCLEN,QT(101,101),R(101*52),F0(101) DOUBLE PRECISION F1(101),DZ(101),T(101) DOUBLE PRECISION Y(101),W(101),WP(101),Z0(101),Z1(101), + YP(101),YOLD(101),YPOLD(101),A(100),QR(101,102), + ALPHA(100),TZ(101),SSPAR(8),YSAV(101),PAR(1) INTEGER PIVOT(101),CODE,TIME,IPAR(1),N,NDIMA,NFE,TRACE, + IFLAG,II,J,NP1 CHARACTER*6 NAME REAL DTIME COMMON /SIZE/ N C C TEST EACH OF THE THREE ALGORITHMS. C DO 60 II=1,3 C C INITIALIZE TIMER VARIABLES. C CODE=2 TIME=0 DTIME=0.0 C C DEFINE ARGUMENTS FOR CALL TO HOMPACK PROCEDURE. C N=5 NP1=N+1 ARCRE=0.5D-4 ARCAE=0.5D-4 ANSRE=1.0D-10 ANSAE=1.0D-10 TRACE=0 DO 30 J=1,8 30 SSPAR(J)=0.0 IFLAG=-1 DO 40 J=2,NP1 40 Y(J)=0.0D0 C CMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM C C INSERT CALL TO INITIALIZE SYSTEM TIMER HERE. FOR EXAMPLE, FOR C THE VAX, THE FOLLOWING STATEMENT IS USED. C C CALL LIB$INIT_TIMER C CMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM C C CALL TO HOMPACK ROUTINE. C IF (II .EQ. 1) THEN NAME='FIXPQF' CALL FIXPQF(N,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE,A,NFE, + ARCLEN,YP,YOLD,YPOLD,QT,R,F0,F1,Z0,DZ,W,T,YSAV, + SSPAR,PAR,IPAR) ELSE IF (II .EQ. 2) THEN NAME='FIXPNF' CALL FIXPNF(N,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE,A,NFE, + ARCLEN,YP,YOLD,YPOLD,QR,ALPHA,TZ,PIVOT,W,WP,Z0,Z1, + SSPAR,PAR,IPAR) ELSE NAME='FIXPDF' CALL FIXPDF(N,Y,IFLAG,ARCRE,ANSRE,TRACE,A,NDIMA,NFE, + ARCLEN,YP,YPOLD,QR,ALPHA,TZ,PIVOT,WT,PHI,P,PAR,IPAR) END IF C CMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM C C INSERT CALL TO RETURN EXECUTION TIME IN SECONDS IN DTIME. C FOR EXAMPLE, THE VAX STATEMENTS ARE AS FOLLOWS. C CALL LIB$STAT_TIMER(CODE,TIME) C DTIME=TIME/100.0 C CMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM C WRITE (6,45) NAME 45 FORMAT (//,8X,'TESTING',1X,6A) WRITE (6,50) Y(1),IFLAG,NFE,DTIME,ARCLEN,(Y(J),J=2,NP1) 50 FORMAT(//' LAMBDA =',F11.8,' FLAG =',I2,I8,' JACOBIAN ', + 'EVALUATIONS',/,1X,'EXECUTION TIME(SECS) =',F10.2,4X, + 'ARCLEN =',F10.3/(1X,1P,3E16.8)) 60 CONTINUE 400 STOP END SUBROUTINE F(X,V) C******************************************************************** C C SUBROUTINE F(X,V) -- EVALUATES BROWN'S FUNCTION AT THE POINT C X, AND RETURNS THE VALUE IN V. C C******************************************************************** C DOUBLE PRECISION X(1),V(1),PROD,SUM INTEGER J,N COMMON /SIZE/ N PROD=1.0D0 DO 10 J=1,N 10 PROD=PROD*X(J) V(1)=PROD-1.0D0 SUM=0.0D0 DO 20 J=1,N 20 SUM=SUM+X(J) SUM=SUM-DBLE(N+1) DO 30 J=2,N 30 V(J)=SUM+X(J) RETURN END SUBROUTINE FJAC(X,V,K) C******************************************************************** C C SUBROUTINE FJAC(X,V,K) -- EVALUATES THE K-TH COLUMN OF C THE JACOBIAN MATRIX FOR BROWN'S FUNCTION EVALUATED AT C THE POINT X, RETURNING THE VALUE IN V. C C******************************************************************** C DOUBLE PRECISION X(1),V(1),PROD INTEGER J,K,N COMMON /SIZE/ N PROD=1.0D0 DO 10 J=1,K-1 10 PROD=PROD*X(J) DO 15 J=K+1,N 15 PROD=PROD*X(J) V(1)=PROD DO 20 J=2,N 20 V(J)=1.0D0 IF (K .GT. 1) V(K)=V(K)+1.0D0 RETURN END C C MAIN ROUTINE TO TEST POLSYS C C THIS ROUTINE REQUIRES ONE INPUT FILE, READ AS UNIT FOR007. C C A SAMPLE INPUT FILE AND ASSOCIATED OUTPUT ARE GIVEN C IN THE COMMENTS THAT FOLLOW. THIS SAMPLE PROBLEM IS C CITED IN THE HOMPACK REPORT. C C***** SAMPLE INPUT DATA: C TWO QUADRICS, NO SOLUTIONS AT INFINITY, TWO REAL SOLUTIONS. C 00001 IFLGHM C 00001 IFLGSC C 4 ITOTDG C 1.D-04 EPSBIG C 1.D-14 EPSSML C 1.D-00 SSPAR(5) C 10 NUMRR C 2 N C 00006 NUMTRM(1) C 00002 DEG(1,1,1) C 00000 DEG(1,2,1) C -.00098D 00 C 00000 DEG(1,1,2) C 00002 DEG(1,2,2) C 978000.D 00 C 00001 DEG(1,1,3) C 00001 DEG(1,2,3) C -9.8D 00 C 00001 DEG(1,1,4) C 00000 DEG(1,2,4) C -235.0D 00 C 00000 DEG(1,1,5) C 00001 DEG(1,2,5) C 88900.0D 00 C 00000 DEG(1,1,6) C 00000 DEG(1,2,6) C -1.000D 00 C 00006 NUMTRM(2) C 00002 DEG(2,1,1) C 00000 DEG(2,2,1) C -.0100D 00 C 00000 DEG(2,1,2) C 00002 DEG(2,2,2) C -.9840D 00 C 00001 DEG(2,1,3) C 00001 DEG(2,2,3) C -29.70D 00 C 00001 DEG(2,1,4) C 00000 DEG(2,2,4) C .00987D 00 C 00000 DEG(2,1,5) C 00001 DEG(2,2,5) C -.1240D 00 C 00000 DEG(2,1,6) C 00000 DEG(2,2,6) C -.2500D 00 C***** END OF SAMPLE INPUT DATA. C C***** ASSOCIATED SAMPLE OUTPUT: C C C POLYS TEST ROUTINE 5/20/85 C C C TWO QUADRICS PBHP0403, NO SOLUTIONS AT INFINITY ......... C C IF IFLGHM=1,HOMOGENEOUS;IF IFLGHM=2,INHOMOGENEOUS;IFLGHM= 1 C C IF IFLGSC=1,SCLGEN USED; IF IFLGSC=2, NO SCALING; IFLGSC= 1 C C ITOTDG= 4 C C EPSBIG,EPSSML = 0.100000000000000D-03 0.100000000000000D-13 C NUMBER OF EQUATIONS = 2 C C C NUMBER OF RECALLS WHEN IFLAG=3: 40 C C C C ****** COEFFICIENT TABLEAU ****** C C C NUMT( 1)= 6 C KDEG( 1, 1, 1)= 2 C KDEG( 1, 2, 1)= 0 C COEF( 1, 1)=-0.980000000000000D-03 C KDEG( 1, 1, 2)= 0 C KDEG( 1, 2, 2)= 2 C COEF( 1, 2)= 0.978000000000000D+06 C KDEG( 1, 1, 3)= 1 C KDEG( 1, 2, 3)= 1 C COEF( 1, 3)=-0.980000000000000D+01 C KDEG( 1, 1, 4)= 1 C KDEG( 1, 2, 4)= 0 C COEF( 1, 4)=-0.235000000000000D+03 C KDEG( 1, 1, 5)= 0 C KDEG( 1, 2, 5)= 1 C COEF( 1, 5)= 0.889000000000000D+05 C KDEG( 1, 1, 6)= 0 C KDEG( 1, 2, 6)= 0 C COEF( 1, 6)=-0.100000000000000D+01 C C C NUMT( 2)= 6 C KDEG( 2, 1, 1)= 2 C KDEG( 2, 2, 1)= 0 C COEF( 2, 1)=-0.100000000000000D-01 C KDEG( 2, 1, 2)= 0 C KDEG( 2, 2, 2)= 2 C COEF( 2, 2)=-0.984000000000000D+00 C KDEG( 2, 1, 3)= 1 C KDEG( 2, 2, 3)= 1 C COEF( 2, 3)=-0.297000000000000D+02 C KDEG( 2, 1, 4)= 1 C KDEG( 2, 2, 4)= 0 C COEF( 2, 4)= 0.987000000000000D-02 C KDEG( 2, 1, 5)= 0 C KDEG( 2, 2, 5)= 1 C COEF( 2, 5)=-0.124000000000000D+00 C KDEG( 2, 1, 6)= 0 C KDEG( 2, 2, 6)= 0 C COEF( 2, 6)=-0.250000000000000D+00 C C C C C PATH NUMBER = 1 C C FINAL VALUES FOR PATH C C ARCLEN = 0.100553311312353D+02 C NFE = 53 C IFLG2 = 1 C T = 0.100000000000000D+01 C X = 0.234233851959126D+04 0.791152831437911D-11 C X =-0.788344824094138D+00-0.268347762088076D-14 C X =-0.949359459408658D-02-0.106447550900261D-02 C X = C C C PATH NUMBER = 2 C C FINAL VALUES FOR PATH C C ARCLEN = 0.172112868960496D+01 C NFE = 37 C IFLG2 = 1 C T = 0.100000000000000D+01 C X = 0.161478579234367D-01 0.168496955498881D+01 C X = 0.267994739614462D-03 0.442802993973661D-02 C X =-0.381948972942403D+00 0.372068943457283D+00 C X = C C C PATH NUMBER = 3 C C FINAL VALUES FOR PATH C C ARCLEN = 0.202329539135269D+01 C NFE = 35 C IFLG2 = 1 C T = 0.100000000000000D+01 C X = 0.161478579234362D-01-0.168496955498881D+01 C X = 0.267994739614461D-03-0.442802993973661D-02 C X =-0.329370493847660D+00 0.556619775523013D+00 C X = C C C PATH NUMBER = 4 C C FINAL VALUES FOR PATH C C ARCLEN = 0.416327291917901D+01 C NFE = 46 C IFLG2 = 1 C T = 0.100000000000000D+01 C X = 0.908921229615394D-01-0.111985846294633D-14 C X =-0.911497098197500D-01 0.117962440099502D-17 C X =-0.573673395727962D-01 0.136243663709219D+00 C X = C C C TOTAL NFE OVER ALL PATHS = 171 C C***** END OF ASSOCIATED SAMPLE OUTPUT. C C ************************************************************* C C PROGRAM DESCRIPTION: 1. READS IN DATA. C 2. GENERATES POLSYS INPUT. C 3. CALLS POLSYS. C 4. WRITES POLSYS OUTPUT. C C DIMENSIONS SHOULD BE SET AS FOLLOWS: C C DIMENSION NUMT(NN),COEF(NN,MMAXT),KDEG(NN,NN+1,MMAXT) C DIMENSION IFLG2(TTOTDG) C DIMENSION LAMBDA(TTOTDG),ROOTS(2,NN+1,TTOTDG),ARCLEN(TTOTDG), C + NFE(TTOTDG) C DIMENSION WK(LENWK),IWK(LENIWK) C WHERE: C N IS THE NUMBER OF EQUATIONS. NN .GE. N. C MAXT IS THE MAXIMUM NUMBER OF TERMS IN ANY ONE EQUATION. C MMAXT .GE. MAXT. C TOTDG IS THE TOTAL DEGREE OF THE SYSTEM. TTOTDG .GE. TOTDG. C LENWK IS THE DIMENSION OF THE WORKSPACE WK . LENWK MUST C BE GREATER THAN OR EQUAL TO C 21 + 61*N + 10*N**2 + 7*N*MMAXT + 4*N**2*MMAXT. C LENIWK IS THE DIMENSION OF THE WORKSPACE IWK . LENIWK MUST BE C GREATER THAN OR EQUAL TO 43 + 7*N + N*(N+1)*MMAXT. C C THIS TEST CODE HAS DIMENSIONS SET AS FOLLOWS: C C NN=10, MMAXT=30, TTOTDG=999 C LENWK = 21 + 610 + 1000 + 2100 + 12000 = 15731 C LENIWK = 43 + 70 + 3300 = 3413 C PROGRAM TESTP INTEGER IFLG1,IFLG2,IFLGHM,IFLGSC,ITEST,ITOTIT,IWK,J,K,KDEG, + L,LENIWK,LENWK,M,MMAXT,N,NFE,NN,NP1,NT,NUMRR,NUMT,TTOTDG DOUBLE PRECISION ARCLEN,COEF,EPSBIG,EPSSML,LAMBDA,ROOTS, + SSPAR,WK CHARACTER*72 TITLE C DIMENSION ARCLEN(999),COEF(10,30),IFLG2(999),IWK(3413), + KDEG(10,11,30),LAMBDA(999),NFE(999),NUMT(10),ROOTS(2,11,999), + SSPAR(8),WK(15731) C NN=10 MMAXT=30 TTOTDG=999 LENWK=15731 LENIWK=3413 C C OPEN (UNIT=7,FILE='INNHP.DAT',STATUS='UNKNOWN') OPEN (UNIT=6,FILE='OUTHP.DAT',STATUS='UNKNOWN') C SSPAR(1)=.0 SSPAR(2)=.0 SSPAR(3)=.0 SSPAR(4)=.0 SSPAR(6)=.0 SSPAR(7)=.0 SSPAR(8)=.0 C 1000 FORMAT(I5) 2000 FORMAT(D22.15) C WRITE(6,10) 10 FORMAT( ' POLSYS TEST ROUTINE 8/12/85',//) C READ(7,*) TITLE WRITE(6,21) TITLE 21 FORMAT(' ',A72) C READ(7,1000) IFLGHM READ(7,1000) IFLGSC READ(7,1000) TTOTDG C READ(7,2000) EPSBIG READ(7,2000) EPSSML READ(7,2000) SSPAR(5) READ(7,1000) NUMRR READ(7,1000) N C WRITE(6,100) IFLGHM 100 FORMAT(/ +' IF IFLGHM=1,HOMOGENEOUS;IF IFLGHM=0,INHOMOGENEOUS;IFLGHM=',I2) WRITE(6,102) IFLGSC 102 FORMAT(/ +' IF IFLGSC=1,SCLGNP USED; IF IFLGSC=0, NO SCALING; IFLGSC=',I2) WRITE(6,104) TTOTDG 104 FORMAT(/,' TTOTDG=',I5) C C WRITE(6,106) EPSBIG,EPSSML,SSPAR(5),N 106 FORMAT(/,' EPSBIG,EPSSML =',2D22.15, + //,' SSPAR(5) =',D22.15, + //,' NUMBER OF EQUATIONS =',I5) WRITE(6,108) NUMRR 108 FORMAT(/,' NUMBER OF RECALLS WHEN IFLAG=3: ',I5) C NP1=N+1 C C NOTE THAT THE DEGREES OF VARIABLES IN EACH TERM OF EACH EQUATION C ARE DEFINED BY THE FOLLOWING INDEXING SCHEME: C C KDEG(J, L, K) C C ^ ^ ^ C C E V T C Q A E C U R R C A I M C T A C I B C O L C N E C C WRITE(6,200) 200 FORMAT(//,' ****** COEFFICIENT TABLEAU ******') C DO 202 J=1,N C WRITE(6,205) 205 FORMAT(/) C READ(7,1000) NUMT(J) WRITE(6,210) J,NUMT(J) 210 FORMAT(' NUMT(',I2,')=',I5) C NT=NUMT(J) C DO 215 K=1,NT C DO 218 L=1,N READ(7,1000) KDEG(J,L,K) WRITE(6,220) J,L,K,KDEG(J,L,K) 220 FORMAT(' KDEG(',I2,',',I2,',',I2,')=',I5) C 218 CONTINUE C READ(7,2000) COEF(J,K) WRITE(6,230) J,K,COEF(J,K) 230 FORMAT(' COEF(',I2,',',I2,')=',D22.15) C 215 CONTINUE C 202 CONTINUE C WRITE(6,205) WRITE(6,205) C IFLG1=10*IFLGHM+IFLGSC C DO 235 M=1,TTOTDG IFLG2(M)=-2 235 CONTINUE C CALL POLSYS(N,NUMT,COEF,KDEG,IFLG1,IFLG2, + EPSBIG,EPSSML,SSPAR, + NUMRR,NN,MMAXT,TTOTDG,LENWK,LENIWK, + LAMBDA,ROOTS,ARCLEN,NFE,WK,IWK) WRITE(6,240) IFLG1 240 FORMAT(/,' IFLG1=',I5,/) C ITOTIT=0 DO 250 M=1,TTOTDG C ITOTIT=ITOTIT+NFE(M) C WRITE(6,260) M 260 FORMAT(' PATH NUMBER =',I5) WRITE(6,270) 270 FORMAT(/' FINAL VALUES FOR PATH'/) C WRITE(6,280) ARCLEN(M) 280 FORMAT(' ARCLEN =',D22.15) WRITE(6,290) NFE(M) 290 FORMAT(' NFE =',I5) WRITE(6,300) IFLG2(M) 300 FORMAT(' IFLG2 =',I5) C C******************************* C C DESIGNATE SOLUTIONS "REAL" OR "COMPLEX" C ITEST=0 DO 310 J=1,N IF(ABS(ROOTS(2,J,M)).GE.1.E-4) ITEST=1 310 CONTINUE IF( ITEST.EQ.1) THEN WRITE(6,779) 779 FORMAT(' COMPLEX SOLUTION ') ELSE WRITE(6,780) 780 FORMAT(' REAL SOLUTION ') END IF C C******************************* C C C DESIGNATE SOLUTION "FINITE" OR "INFINITE" C IF( ABS(ROOTS(1,NP1,M))+ABS(ROOTS(2,NP1,M)) .LT. 1.E-6) THEN WRITE(6,781) 781 FORMAT(' INFINITE SOLUTION ') ELSE WRITE(6,782) 782 FORMAT(' FINITE SOLUTION ') END IF C C******************************* C WRITE(6,320) LAMBDA(M),(ROOTS(1,J,M),ROOTS(2,J,M),J=1,N) 320 FORMAT(' LAMBDA =',D22.15,/,10(' X =',2D22.15,/)) WRITE(6,330) ROOTS(1,NP1,M),ROOTS(2,NP1,M) 330 FORMAT(/,' XNP1 =',2D22.15,/) C WRITE(6,205) C 250 CONTINUE C WRITE(6,400) ITOTIT 400 FORMAT(' TOTAL NFE OVER ALL PATHS = ',I10) C C STOP END C MAIN PROGRAM TO TEST FIXPQS, FIXPNS, AND FIXPDS C C THIS PROGRAM TESTS THE HOMPACK ROUTINES FIXPNS, FIXPQS, AND C FIXPDS. THE USER MAY INSERT CALLS TO A SYSTEM TIMER AT THE C DESIGNATED LOCATIONS IN ORDER TO GET EXECUTION TIME FOR THESE C ROUTINES. C C THE MODIFICATIONS TO BE MADE FOR THE SYSTEM TIMER ARE INDICATED C BY A LINE OF M'S, E.G. CMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM C C C THE OUTPUT FROM THIS ROUTINE SHOULD BE AS FOLLOWS, WITH THE C EXECUTION TIMES CORRESPONDING TO A VAX 11/785. C C TESTING FIXPQS C C LAMBDA = 1.00000000 FLAG = 1 33 JACOBIAN EVALUATIONS C ARC LENGTH = 1.274 EXECUTION TIME(SECS) = 2.31 C 4.00864019E-01 2.65454893E-01 8.40421103E-02 4.83042527E-01 C 3.01797132E-01 2.32508994E-01 4.96639853E-01 3.00908894E-01 C C TESTING FIXPNS C C LAMBDA = 1.00000000 FLAG = 1 20 JACOBIAN EVALUATIONS C ARC LENGTH = 1.275 EXECUTION TIME(SECS) = 1.04 C 4.00864019E-01 2.65454893E-01 8.40421103E-02 4.83042527E-01 C 3.01797132E-01 2.32508994E-01 4.96639853E-01 3.00908894E-01 C C TESTING FIXPDS C C LAMBDA = 1.00000000 FLAG = 1 70 JACOBIAN EVALUATIONS C ARC LENGTH = 1.281 EXECUTION TIME(SECS) = 1.78 C 4.00864019E-01 2.65454893E-01 8.40421103E-02 4.83042527E-01 C 3.01797132E-01 2.32508994E-01 4.96639853E-01 3.00908894E-01 C C PROGRAM TEST1 IMPLICIT DOUBLE PRECISION(A-H,O-Z) DOUBLE PRECISION Y(9), + YP(9),YOLD(9),YPOLD(9),A(8),QR(18),WORK(200), + SSPAR(8),PAR(1),PP(8),RHOVEC(9),Z0(9),DZ(9),T(9), + WT(9),PHI(9,16),P(9) INTEGER PIVOT(10),IPAR(1) INTEGER IFLAG,II,J,LENQR,N,NFE,NP1,NDIMA,TRACE DOUBLE PRECISION ARCRE,ARCAE,ANSRE,ANSAE,ARCLEN CHARACTER*6 NAME INTEGER TIME,CODE REAL DTIME C C TEST EACH OF THE THREE ALGORITHMS. C DO 60 II=1,3 C C INITIALIZE TIMER VARIABLES. C CODE=2 TIME=0 DTIME=0.0 C C DFEFINE ARGUMENTS FOR CALL TO HOMPACK PROCEDURE. C N=8 DO 7 J=1,8 7 SSPAR(J)=0.0D0 ARCRE=.5D-4 ARCAE=.5D-4 ANSRE=1.0D-12 ANSAE=1.0D-12 TRACE=0 IFLAG=-1 LENQR=18 NP1=N+1 DO 40 J=1,N 40 Y(J)=0.5D0 C CMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM C C INSERT CALL TO INITIALIZE SYSTEM TIMER HERE. FOR EXAMPLE, FOR C THE VAX, THE FOLLOWING STATEMENT IS USED. C C CALL LIB$INIT_TIMER C CMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM C C CALL TO HOMPACK ROUTINE. C C IF (II .EQ. 1) THEN NAME='FIXPQS' CALL FIXPQS(N,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE, + A,NFE,ARCLEN,YP,YOLD,YPOLD,QR,LENQR,PIVOT,PP,RHOVEC, + Z0,DZ,T,WORK,SSPAR,PAR,IPAR) ELSE IF (II .EQ. 2) THEN NAME='FIXPNS' CALL FIXPNS(N,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE,A, + NFE,ARCLEN,YP,YOLD,YPOLD,QR,LENQR,PIVOT,WORK, + SSPAR,PAR,IPAR) ELSE NAME='FIXPDS' CALL FIXPDS(N,Y,IFLAG,ARCRE,ANSRE,TRACE,A,NDIMA,NFE, + ARCLEN,YP,YPOLD,QR,LENQR,PIVOT,PP,WORK,WT,PHI,P, + PAR,IPAR) END IF C CMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM C C INSERT CALL TO RETURN EXECUTION TIME IN SECONDS IN DTIME. C FOR EXAMPLE, THE VAX STATEMENTS ARE AS FOLLOWS. C CALL LIB$STAT_TIMER(CODE,TIME) C DTIME=TIME/100.0 C CMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM C WRITE (6,45) NAME 45 FORMAT(//,8X,'TESTING',1X,6A) WRITE (6,50) Y(NP1),IFLAG,NFE,ARCLEN,DTIME,(Y(J),J=1,N) 50 FORMAT(/' LAMBDA =',F11.8,' FLAG =',I2,I8,' JACOBIAN ', + 'EVALUATIONS',/,1X,' ARC LENGTH =',F8.3, + ' EXECUTION TIME(SECS) =',F10.2/(1X,1P,4E16.8)) 60 CONTINUE STOP END SUBROUTINE F(X,V) C C**************************************************************** C C SUBROUTINE F(X,V) -- COMPUTES F AT THE POINT X, C RETURNING THE VALUE IN V. C C**************************************************************** DOUBLE PRECISION X(8),V(8) V(1)=X(1)**3+6.0*X(2)*X(3)-1+2.0*X(1) V(2)=6.0*X(1)*X(3)+X(2)**4*X(5)-1+3.0*X(2) V(3)=6.0*X(1)*X(2)+X(3)*X(5)-1+4.0*X(3) V(4)=X(4)**3*X(8)-1+2.0*X(4) V(5)=X(2)**5/5.0 + X(3)**2/2.0 + X(8)*X(5)-1+3.0*X(5) V(6)=X(6)*X(8)-1+4.0*X(6) V(7)=X(7)**2*X(8)**3-1+2.0*X(7) V(8)=X(4)**4/4.0 + X(5)**2/2.0 + X(6)**2/2.0 + X(7)**3* + X(8)**2-1+3.0*X(8) RETURN END SUBROUTINE FJACS(X,QR,LENQR,PIVOT) C****************************************************************** C C SUBROUTINE FJACS(X,QR,LENQR,PIVOT) C C -- COMPUTES THE JACOBIAN OF F AT THE POINT X, RETURNING C THE JACOBIAN MATRIX IN PACKED SKYLINE FORM IN THE C ARRAYS QR, AND PIVOT. C C***************************************************************** DOUBLE PRECISION X(8),QR(LENQR) INTEGER LENQR,PIVOT(9) PIVOT(1)=1 PIVOT(2)=2 PIVOT(3)=4 PIVOT(4)=7 PIVOT(5)=8 PIVOT(6)=12 PIVOT(7)=13 PIVOT(8)=14 PIVOT(9)=19 QR(1)=3.0*X(1)**2+2.0 QR(2)=4.0*X(2)**3*X(5)+3.0 QR(3)=6.0*X(3) QR(4)=X(5)+4.0 QR(5)=6.0*X(1) QR(6)=6.0*X(2) QR(7)=3.0*X(4)**2*X(8)+2.0 QR(8)=X(8)+3.0 QR(9)=.0 QR(10)=X(3) QR(11)=X(2)**4 QR(12)=X(8)+4.0 QR(13)=2.0*X(7)*X(8)**3+2.0 QR(14)=2.0*X(7)**3*X(8)+3.0 QR(15)=3.0*X(7)**2*X(8)**2 QR(16)=X(6) QR(17)=X(5) QR(18)=X(4)**3 RETURN END C C HOMPACK is a suite of FORTRAN 77 subroutines for solving nonlinea C systems of equations by homotopy methods. There are subroutines for C fixed point, zero finding, and general homotopy curve tracking problem C utilizing both dense and sparse Jacobian matrices, and implementing C three different algorithms: ODE-based, normal flow, and augmented C Jacobian. The (driver) subroutines called by the user are given in th C table below, and are well documented internally. The user need not C be concerned with any other subroutines in HOMPACK. C C C Problem type C --------|--------|--------|--------|--------|--------| C x = f(x) | F(x) = 0 |rho(a,lambda,x)=0| C --------|--------|--------|--------|--------|--------| C dense | sparse | dense | sparse | dense | sparse | Algorithm C --------|--------|--------|--------|--------|--------|---------------- C FIXPDF | FIXPDS | FIXPDF | FIXPDS | FIXPDF | FIXPDS | ODE based C --------|--------|--------|--------|--------|--------|---------------- C FIXPNF | FIXPNS | FIXPNF | FIXPNS | FIXPNF | FIXPNS | normal flow C --------|--------|--------|--------|--------|--------|---------------- C FIXPQF | FIXPQS | FIXPQF | FIXPQS | FIXPQF | FIXPQS | augmented Jacob C --------|--------|--------|--------|--------|--------|---------------- C C C The sparse subroutines use the packed skyline storage scheme standard C structural mechanics, but any sparse storage scheme can be used by C replacing some of the low-level HOMPACK routines with user-written C routines. The stepping subroutines STEP?? may be of interest to some C users with special curve tracking needs. C C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C DOUBLE PRECISION FUNCTION D1MACH(I) C***BEGIN PROLOGUE D1MACH C***DATE WRITTEN 750101 (YYMMDD) C***REVISION DATE 870717 (YYMMDD) C***CATEGORY NO. Q3 C***KEYWORDS MACHINE CONSTANTS C***AUTHOR FOX, P. A., (BELL LABS) C HALL, A. D., (BELL LABS) C SCHRYER, N. L., (BELL LABS) C WATSON, L. T., (VPI & SU) C***PURPOSE Returns double precision machine dependent constants C***DESCRIPTION C D1MACH can be used to obtain machine-dependent parameters C for the local machine environment. It is a function C subprogram with one (input) argument, and can be called C as follows, for example C C D = D1MACH(I) C C where I=1,...,5. The (output) value of D above is C determined by the (input) value of I. The results for C various values of I are discussed below. C C Double-precision machine constants C D1MACH( 1) = B**(EMIN-1), the smallest positive magnitude. C D1MACH( 2) = B**EMAX*(1 - B**(-T)), the largest magnitude. C D1MACH( 3) = B**(-T), the smallest relative spacing. C D1MACH( 4) = B**(1-T), the largest relative spacing. C D1MACH( 5) = LOG10(B) C***REFERENCES FOX P.A., HALL A.D., SCHRYER N.L.,*FRAMEWORK FOR A C PORTABLE LIBRARY*, ACM TRANSACTIONS ON MATHEMATICAL C SOFTWARE, VOL. 4, NO. 2, JUNE 1978, PP. 177-188. C***END PROLOGUE D1MACH C INTEGER I INTEGER SMALL(4) INTEGER LARGE(4) INTEGER RIGHT(4) INTEGER DIVER(4) INTEGER LOG10(4) C DOUBLE PRECISION DMACH(5) C EQUIVALENCE (DMACH(1),SMALL(1)) EQUIVALENCE (DMACH(2),LARGE(1)) EQUIVALENCE (DMACH(3),RIGHT(1)) EQUIVALENCE (DMACH(4),DIVER(1)) EQUIVALENCE (DMACH(5),LOG10(1)) C SAVE DMACH C C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. C C DATA SMALL(1) / ZC00800000 / C DATA SMALL(2) / Z000000000 / C C DATA LARGE(1) / ZDFFFFFFFF / C DATA LARGE(2) / ZFFFFFFFFF / C C DATA RIGHT(1) / ZCC5800000 / C DATA RIGHT(2) / Z000000000 / C C DATA DIVER(1) / ZCC6800000 / C DATA DIVER(2) / Z000000000 / C C DATA LOG10(1) / ZD00E730E7 / C DATA LOG10(2) / ZC77800DC0 / C C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM. C C DATA SMALL(1) / O1771000000000000 / C DATA SMALL(2) / O0000000000000000 / C C DATA LARGE(1) / O0777777777777777 / C DATA LARGE(2) / O0007777777777777 / C C DATA RIGHT(1) / O1461000000000000 / C DATA RIGHT(2) / O0000000000000000 / C C DATA DIVER(1) / O1451000000000000 / C DATA DIVER(2) / O0000000000000000 / C C DATA LOG10(1) / O1157163034761674 / C DATA LOG10(2) / O0006677466732724 / C C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS. C C DATA SMALL(1) / O1771000000000000 / C DATA SMALL(2) / O7770000000000000 / C C DATA LARGE(1) / O0777777777777777 / C DATA LARGE(2) / O7777777777777777 / C C DATA RIGHT(1) / O1461000000000000 / C DATA RIGHT(2) / O0000000000000000 / C C DATA DIVER(1) / O1451000000000000 / C DATA DIVER(2) / O0000000000000000 / C C DATA LOG10(1) / O1157163034761674 / C DATA LOG10(2) / O0006677466732724 / C C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES. C C DATA SMALL(1) / 00604000000000000000B / C DATA SMALL(2) / 00000000000000000000B / C DATA LARGE(1) / 37767777777777777777B / C DATA LARGE(2) / 37167777777777777777B / C DATA RIGHT(1) / 15604000000000000000B / C DATA RIGHT(2) / 15000000000000000000B / C DATA DIVER(1) / 15614000000000000000B / C DATA DIVER(2) / 15010000000000000000B / C DATA LOG10(1) / 17164642023241175717B / C DATA LOG10(2) / 16367571421742254654B / C C MACHINE CONSTANTS FOR THE CDC CYBER SERIES. C C DATA SMALL(1) / O"00604000000000000000" / C DATA SMALL(2) / O"00000000000000000000" / C DATA LARGE(1) / O"37767777777777777777" / C DATA LARGE(2) / O"37167777777777777777" / C DATA RIGHT(1) / O"15604000000000000000" / C DATA RIGHT(2) / O"15000000000000000000" / C DATA DIVER(1) / O"15614000000000000000" / C DATA DIVER(2) / O"15010000000000000000" / C DATA LOG10(1) / O"17164642023241175717" / C DATA LOG10(2) / O"16367571421742254654" / C C MACHINE CONSTANTS FOR CONVEX C-1 C C DATA SMALL(1),SMALL(2) / '00100000'X, '00000000'X / C DATA LARGE(1),LARGE(2) / '7FFFFFFF'X, 'FFFFFFFF'X / C DATA RIGHT(1),RIGHT(2) / '3CC00000'X, '00000000'X / C DATA DIVER(1),DIVER(2) / '3CD00000'X, '00000000'X / C DATA LOG10(1),LOG10(2) / '3FF34413'X, '509F79FF'X / C C MACHINE CONSTANTS FOR THE CRAY 1 (ERIC GROSSE) C C DATA SMALL(1) / 201354000000000000000B / C DATA SMALL(2) / 000000000000000000000B / C DATA LARGE(1) / 577767777777777777777B / C DATA LARGE(2) / 000007777777777777776B / C DATA RIGHT(1) / 376434000000000000000B / C DATA RIGHT(2) / 000000000000000000000B / C DATA DIVER(1) / 376444000000000000000B / C DATA DIVER(2) / 000000000000000000000B / C DATA LOG10(1) / 377774642023241175717B / C DATA LOG10(2) / 000007571421742254654B / C C MACHINE CONSTANTS FOR THE CRAY 1 (SLATEC LIBRARY) C C DATA SMALL(1) / 200004000000000000000B / C DATA SMALL(2) / 000000000000000000000B / C DATA LARGE(1) / 577777777777777777777B / C DATA LARGE(2) / 000007777777777777777B / C DATA RIGHT(1) / 377214000000000000000B / C DATA RIGHT(2) / 000000000000000000000B / C DATA DIVER(1) / 377224000000000000000B / C DATA DIVER(2) / 000000000000000000000B / C DATA LOG10(1) / 377774642023241175717B / C DATA LOG10(2) / 000007571421742254654B / C C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 C C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - C STATIC DMACH(5) C C DATA SMALL/20K,3*0/,LARGE/77777K,3*177777K/ C DATA RIGHT/31420K,3*0/,DIVER/32020K,3*0/ C DATA LOG10/40423K,42023K,50237K,74776K/ C C MACHINE CONSTANTS FOR THE DATA GENERAL MV/8000, 10000 C C DATA SMALL(1),SMALL(2) / 1048576, 0 / C DATA LARGE(1),LARGE(2) / 2147483647, -1 / C DATA RIGHT(1),RIGHT(2) / 856686592, 0 / C DATA DIVER(1),DIVER(2) / 873463808, 0 / C DATA LOG10(1),LOG10(2) / 1091781651, 1352628734 / C C MACHINE CONSTANTS FOR THE HARRIS 220 C C DATA SMALL(1),SMALL(2) / '20000000, '00000201 / C DATA LARGE(1),LARGE(2) / '37777777, '37777577 / C DATA RIGHT(1),RIGHT(2) / '20000000, '00000333 / C DATA DIVER(1),DIVER(2) / '20000000, '00000334 / C DATA LOG10(1),LOG10(2) / '23210115, '10237777 / C C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES. C C DATA SMALL(1),SMALL(2) / O402400000000, O000000000000 / C DATA LARGE(1),LARGE(2) / O376777777777, O777777777777 / C DATA RIGHT(1),RIGHT(2) / O604400000000, O000000000000 / C DATA DIVER(1),DIVER(2) / O606400000000, O000000000000 / C DATA LOG10(1),LOG10(2) / O776464202324, O117571775714 / C C MACHINE CONSTANTS FOR THE HP 2100 C THREE WORD DOUBLE PRECISION OPTION WITH FTN4 C C DATA SMALL(1), SMALL(2), SMALL(3) / 40000B, 0, 1 / C DATA LARGE(1), LARGE(2), LARGE(3) / 77777B, 177777B, 177776B / C DATA RIGHT(1), RIGHT(2), RIGHT(3) / 40000B, 0, 265B / C DATA DIVER(1), DIVER(2), DIVER(3) / 40000B, 0, 276B / C DATA LOG10(1), LOG10(2), LOG10(3) / 46420B, 46502B, 77777B / C C C MACHINE CONSTANTS FOR THE HP 2100 C FOUR WORD DOUBLE PRECISION OPTION WITH FTN4 C C DATA SMALL(1), SMALL(2) / 40000B, 0 / C DATA SMALL(3), SMALL(4) / 0, 1 / C DATA LARGE(1), LARGE(2) / 77777B, 177777B / C DATA LARGE(3), LARGE(4) / 177777B, 177776B / C DATA RIGHT(1), RIGHT(2) / 40000B, 0 / C DATA RIGHT(3), RIGHT(4) / 0, 225B / C DATA DIVER(1), DIVER(2) / 40000B, 0 / C DATA DIVER(3), DIVER(4) / 0, 227B / C DATA LOG10(1), LOG10(2) / 46420B, 46502B / C DATA LOG10(3), LOG10(4) / 76747B, 176377B / C C C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND C THE PERKIN ELMER (INTERDATA) 7/32. C C DATA SMALL(1),SMALL(2) / Z00100000, Z00000000 / C DATA LARGE(1),LARGE(2) / Z7FFFFFFF, ZFFFFFFFF / C DATA RIGHT(1),RIGHT(2) / Z33100000, Z00000000 / C DATA DIVER(1),DIVER(2) / Z34100000, Z00000000 / C DATA LOG10(1),LOG10(2) / Z41134413, Z509F79FF / C C MACHINE CONSTANTS FOR THE INTEL 8087, 80287, SEQUENT BALANCE. C ASSUMES INTEGER*2 AS THE DEFAULT FOR TYPE INTEGER. C C DATA SMALL(1), SMALL(2) / 0, 0/ C DATA SMALL(3), SMALL(4) / 0, 16/ C DATA LARGE(1), LARGE(2) / -1, -1/ C DATA LARGE(3), LARGE(4) / -1, 32751/ C DATA RIGHT(1), RIGHT(2) / 0, 0/ C DATA RIGHT(3), RIGHT(4) / 0, 15520/ C DATA DIVER(1), DIVER(2) / 0, 0/ C DATA DIVER(3), DIVER(4) / 0, 15536/ C DATA LOG10(1), LOG10(2) / 31231, 20639/ C DATA LOG10(3), LOG10(4) / 17427, 16339/ C C MACHINE CONSTANTS FOR THE INTEL 8087, 80287, SEQUENT BALANCE. C ASSUMES INTEGER*4 AS THE DEFAULT FOR TYPE INTEGER. C C DATA SMALL(1),SMALL(2) / 0, 1048576 / C DATA LARGE(1),LARGE(2) / -1, 2146435071 / C DATA RIGHT(1),RIGHT(2) / 0, 1017118720 / C DATA DIVER(1),DIVER(2) / 0, 1018167296 / C DATA LOG10(1),LOG10(2) / 1352628735, 1070810131 / C C MACHINE CONSTANTS FOR THE MOTOROLA 68000 SERIES, AT&T 3B SERIES. C ASSUMES INTEGER*2 AS THE DEFAULT FOR TYPE INTEGER. C C DATA SMALL(1), SMALL(2) / 16, 0/ C DATA SMALL(3), SMALL(4) / 0, 0/ C DATA LARGE(1), LARGE(2) / 32751, -1/ C DATA LARGE(3), LARGE(4) / -1, -1/ C DATA RIGHT(1), RIGHT(2) / 15520, 0/ C DATA RIGHT(3), RIGHT(4) / 0, 0/ C DATA DIVER(1), DIVER(2) / 15536, 0/ C DATA DIVER(3), DIVER(4) / 0, 0/ C DATA LOG10(1), LOG10(2) / 16339, 17427/ C DATA LOG10(3), LOG10(4) / 20639, 31231/ C C MACHINE CONSTANTS FOR THE MOTOROLA 68000 SERIES, AT&T 3B SERIES. C ASSUMES INTEGER*4 AS THE DEFAULT FOR TYPE INTEGER. C C DATA SMALL(1),SMALL(2) / 1048576, 0 / C DATA LARGE(1),LARGE(2) / 2146435071, -1 / C DATA RIGHT(1),RIGHT(2) / 1017118720, 0 / C DATA DIVER(1),DIVER(2) / 1018167296, 0 / C DATA LOG10(1),LOG10(2) / 1070810131, 1352628735 / C C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR). C C DATA SMALL(1),SMALL(2) / "033400000000, "000000000000 / C DATA LARGE(1),LARGE(2) / "377777777777, "344777777777 / C DATA RIGHT(1),RIGHT(2) / "113400000000, "000000000000 / C DATA DIVER(1),DIVER(2) / "114400000000, "000000000000 / C DATA LOG10(1),LOG10(2) / "177464202324, "144117571776 / C C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR). C C DATA SMALL(1),SMALL(2) / "000400000000, "000000000000 / C DATA LARGE(1),LARGE(2) / "377777777777, "377777777777 / C DATA RIGHT(1),RIGHT(2) / "103400000000, "000000000000 / C DATA DIVER(1),DIVER(2) / "104400000000, "000000000000 / C DATA LOG10(1),LOG10(2) / "177464202324, "476747767461 / C C MACHINE CONSTANTS FOR PDP-11 FORTRAN'S SUPPORTING C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). C C DATA SMALL(1),SMALL(2) / 8388608, 0 / C DATA LARGE(1),LARGE(2) / 2147483647, -1 / C DATA RIGHT(1),RIGHT(2) / 612368384, 0 / C DATA DIVER(1),DIVER(2) / 620756992, 0 / C DATA LOG10(1),LOG10(2) / 1067065498, -2063872008 / C C DATA SMALL(1),SMALL(2) / O00040000000, O00000000000 / C DATA LARGE(1),LARGE(2) / O17777777777, O37777777777 / C DATA RIGHT(1),RIGHT(2) / O04440000000, O00000000000 / C DATA DIVER(1),DIVER(2) / O04500000000, O00000000000 / C DATA LOG10(1),LOG10(2) / O07746420232, O20476747770 / C C MACHINE CONSTANTS FOR PDP-11 FORTRAN'S SUPPORTING C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). C C DATA SMALL(1),SMALL(2) / 128, 0 / C DATA SMALL(3),SMALL(4) / 0, 0 / C C DATA LARGE(1),LARGE(2) / 32767, -1 / C DATA LARGE(3),LARGE(4) / -1, -1 / C C DATA RIGHT(1),RIGHT(2) / 9344, 0 / C DATA RIGHT(3),RIGHT(4) / 0, 0 / C C DATA DIVER(1),DIVER(2) / 9472, 0 / C DATA DIVER(3),DIVER(4) / 0, 0 / C C DATA LOG10(1),LOG10(2) / 16282, 8346 / C DATA LOG10(3),LOG10(4) / -31493, -12296 / C C DATA SMALL(1),SMALL(2) / O000200, O000000 / C DATA SMALL(3),SMALL(4) / O000000, O000000 / C C DATA LARGE(1),LARGE(2) / O077777, O177777 / C DATA LARGE(3),LARGE(4) / O177777, O177777 / C C DATA RIGHT(1),RIGHT(2) / O022200, O000000 / C DATA RIGHT(3),RIGHT(4) / O000000, O000000 / C C DATA DIVER(1),DIVER(2) / O022400, O000000 / C DATA DIVER(3),DIVER(4) / O000000, O000000 / C C DATA LOG10(1),LOG10(2) / O037632, O020232 / C DATA LOG10(3),LOG10(4) / O102373, O147770 / C C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. C C DATA SMALL(1),SMALL(2) / O000040000000, O000000000000 / C DATA LARGE(1),LARGE(2) / O377777777777, O777777777777 / C DATA RIGHT(1),RIGHT(2) / O170540000000, O000000000000 / C DATA DIVER(1),DIVER(2) / O170640000000, O000000000000 / C DATA LOG10(1),LOG10(2) / O177746420232, O411757177572 / C C C MACHINE CONSTANTS FOR VAX 11/780 C (EXPRESSED IN INTEGER AND HEXADECIMAL) C ***THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSYEMS*** C *** THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS*** C DATA SMALL(1), SMALL(2) / 128, 0 / DATA LARGE(1), LARGE(2) / -32769, -1 / DATA RIGHT(1), RIGHT(2) / 9344, 0 / DATA DIVER(1), DIVER(2) / 9472, 0 / DATA LOG10(1), LOG10(2) / 546979738, -805665541 / C C DATA SMALL(1), SMALL(2) / Z00000080, Z00000000 / C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / C DATA RIGHT(1), RIGHT(2) / Z00002480, Z00000000 / C DATA DIVER(1), DIVER(2) / Z00002500, Z00000000 / C DATA LOG10(1), LOG10(2) / Z209A3F9A, ZCFFA84FB / C C MACHINE CONSTANTS FOR VAX 11/780 (G-FLOATING) C (EXPRESSED IN INTEGER AND HEXADECIMAL) C ***THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSYEMS*** C *** THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS*** C C DATA SMALL(1), SMALL(2) / 16, 0 / C DATA LARGE(1), LARGE(2) / -32769, -1 / C DATA RIGHT(1), RIGHT(2) / 15552, 0 / C DATA DIVER(1), DIVER(2) / 15568, 0 / C DATA LOG10(1), LOG10(2) / 1142112243, 2046775455 / C C DATA SMALL(1), SMALL(2) / Z00000010, Z00000000 / C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / C DATA RIGHT(1), RIGHT(2) / Z00003CC0, Z00000000 / C DATA DIVER(1), DIVER(2) / Z00003CD0, Z00000000 / C DATA LOG10(1), LOG10(2) / Z44133FF3, Z79FF509F / C C***FIRST EXECUTABLE STATEMENT D1MACH C D1MACH = DMACH(I) RETURN C END SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) C C CONSTANT TIMES A VECTOR PLUS A VECTOR. C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. C JACK DONGARRA, LINPACK, 3/11/78. C DOUBLE PRECISION DX(1),DY(1),DA INTEGER I,INCX,INCY,IX,IY,M,MP1,N C IF(N.LE.0)RETURN IF (DA .EQ. 0.0D0) RETURN IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 C C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS C NOT EQUAL TO 1 C IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N DY(IY) = DY(IY) + DA*DX(IX) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C C C CLEAN-UP LOOP C 20 M = MOD(N,4) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M DY(I) = DY(I) + DA*DX(I) 30 CONTINUE IF( N .LT. 4 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,4 DY(I) = DY(I) + DA*DX(I) DY(I + 1) = DY(I + 1) + DA*DX(I + 1) DY(I + 2) = DY(I + 2) + DA*DX(I + 2) DY(I + 3) = DY(I + 3) + DA*DX(I + 3) 50 CONTINUE RETURN END SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) C C COPIES A VECTOR, X, TO A VECTOR, Y. C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. C JACK DONGARRA, LINPACK, 3/11/78. C DOUBLE PRECISION DX(1),DY(1) INTEGER I,INCX,INCY,IX,IY,M,MP1,N C IF(N.LE.0)RETURN IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 C C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS C NOT EQUAL TO 1 C IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N DY(IY) = DX(IX) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C C C CLEAN-UP LOOP C 20 M = MOD(N,7) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M DY(I) = DX(I) 30 CONTINUE IF( N .LT. 7 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,7 DY(I) = DX(I) DY(I + 1) = DX(I + 1) DY(I + 2) = DX(I + 2) DY(I + 3) = DX(I + 3) DY(I + 4) = DX(I + 4) DY(I + 5) = DX(I + 5) DY(I + 6) = DX(I + 6) 50 CONTINUE RETURN END SUBROUTINE DCPOSE(NDIM,N,QR,ALPHA,PIVOT,IERR,Y,SUM) C C SUBROUTINE DCPOSE IS A MODIFICATION OF THE ALGOL PROCEDURE C DECOMPOSE IN P. BUSINGER AND G. H. GOLUB, LINEAR LEAST C SQUARES SOLUTIONS BY HOUSEHOLDER TRANSFORMATIONS, C NUMER. MATH. 7 (1965) 269-276. C INTEGER NDIM,N,PIVOT(1) DOUBLE PRECISION QR(NDIM,1),ALPHA(N) INTEGER IERR,I,J,JBAR,K,KP1,NP1 DOUBLE PRECISION BETA,SIGMA,ALPHAK,QRKK,Y(1),SUM(1) DOUBLE PRECISION DDOT IERR=0 NP1=N+1 DO 20 J=1,NP1 SUM(J)=DDOT(N,QR(1,J),1,QR(1,J),1) 20 PIVOT(J)=J DO 500 K=1,N SIGMA=SUM(K) JBAR=K KP1=K+1 DO 40 J=KP1,NP1 IF (SIGMA .GE. SUM(J)) GO TO 40 SIGMA=SUM(J) JBAR=J 40 CONTINUE IF (JBAR .EQ. K) GO TO 70 I=PIVOT(K) PIVOT(K)=PIVOT(JBAR) PIVOT(JBAR)=I SUM(JBAR)=SUM(K) SUM(K)=SIGMA DO 50 I=1,N SIGMA=QR(I,K) QR(I,K)=QR(I,JBAR) QR(I,JBAR)=SIGMA 50 CONTINUE C END OF COLUMN INTERCHANGE. 70 SIGMA=DDOT(N-K+1,QR(K,K),1,QR(K,K),1) IF (SIGMA .NE. 0.0) GO TO 60 IERR=1 RETURN 60 IF (K .EQ. N) GO TO 500 QRKK=QR(K,K) ALPHAK=-SQRT(SIGMA) IF (QRKK .LT. 0.0) ALPHAK=-ALPHAK ALPHA(K)=ALPHAK BETA=1.0/(SIGMA-QRKK*ALPHAK) QR(K,K)=QRKK-ALPHAK DO 80 J=KP1,NP1 80 Y(J)=BETA*DDOT(N-K+1,QR(K,K),1,QR(K,J),1) DO 100 J=KP1,NP1 DO 90 I=K,N QR(I,J)=QR(I,J)-QR(I,K)*Y(J) 90 CONTINUE SUM(J)=SUM(J)-QR(K,J)**2 100 CONTINUE 500 CONTINUE ALPHA(N)=QR(N,N) RETURN END DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) C C FORMS THE DOT PRODUCT OF TWO VECTORS. C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. C JACK DONGARRA, LINPACK, 3/11/78. C DOUBLE PRECISION DX(1),DY(1),DTEMP INTEGER I,INCX,INCY,IX,IY,M,MP1,N C DDOT = 0.0D0 DTEMP = 0.0D0 IF(N.LE.0)RETURN IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 C C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS C NOT EQUAL TO 1 C IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N DTEMP = DTEMP + DX(IX)*DY(IY) IX = IX + INCX IY = IY + INCY 10 CONTINUE DDOT = DTEMP RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C C C CLEAN-UP LOOP C 20 M = MOD(N,5) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M DTEMP = DTEMP + DX(I)*DY(I) 30 CONTINUE IF( N .LT. 5 ) GO TO 60 40 MP1 = M + 1 DO 50 I = MP1,N,5 DTEMP = DTEMP + DX(I)*DY(I) + DX(I + 1)*DY(I + 1) + * DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4) 50 CONTINUE 60 DDOT = DTEMP RETURN END SUBROUTINE DIVP(XXXX,YYYY,ZZZZ,IERR) C C THIS SUBROUTINE PERFORMS DIVISION OF COMPLEX NUMBERS: C ZZZZ = XXXX/YYYY C C ON INPUT: C C XXXX IS AN ARRAY OF LENGTH TWO REPRESENTING THE FIRST COMPLEX C NUMBER, WHERE XXXX(1) = REAL PART OF XXXX AND XXXX(2) = C IMAGINARY PART OF XXXX. C C YYYY IS AN ARRAY OF LENGTH TWO REPRESENTING THE SECOND COMPLEX C NUMBER, WHERE YYYY(1) = REAL PART OF YYYY AND YYYY(2) = C IMAGINARY PART OF YYYY. C C ON OUTPUT: C C ZZZZ IS AN ARRAY OF LENGTH TWO REPRESENTING THE RESULT OF C THE DIVISION, ZZZZ = XXXX/YYYY, WHERE ZZZZ(1) = C REAL PART OF ZZZZ AND ZZZZ(2) = IMAGINARY PART OF ZZZZ. C C IERR = C 1 IF DIVISION WOULD HAVE CAUSED OVERFLOW. IN THIS CASE, THE C APPROPRIATE PARTS OF ZZZZ ARE SET EQUAL TO THE LARGEST C FLOATING POINT NUMBER, AS GIVEN BY FUNCTION D1MACH . C C 0 IF DIVISION DOES NOT CAUSE OVERFLOW. C C DECLARATION OF INPUT DOUBLE PRECISION XXXX,YYYY DIMENSION XXXX(2),YYYY(2) C C DECLARATION OF OUTPUT INTEGER IERR DOUBLE PRECISION ZZZZ DIMENSION ZZZZ(2) C C DECLARATION OF VARIABLES DOUBLE PRECISION DENOM,XNUM,D1MACH C IERR = 0 DENOM = YYYY(1)*YYYY(1) + YYYY(2)*YYYY(2) XNUM = XXXX(1)*YYYY(1) + XXXX(2)*YYYY(2) IF (ABS(DENOM) .GE. 1.0 .OR. ( ABS(DENOM) .LT. 1.0 .AND. $ ABS(XNUM)/D1MACH(2) .LT. ABS(DENOM) ) ) THEN ZZZZ(1) = XNUM/DENOM ELSE ZZZZ(1) = D1MACH(2) IERR =1 END IF XNUM = XXXX(2)*YYYY(1) - XXXX(1)*YYYY(2) IF (ABS(DENOM) .GE. 1.0 .OR. ( ABS(DENOM) .LT. 1.0 .AND. $ ABS(XNUM)/D1MACH(2) .LT. ABS(DENOM) ) ) THEN ZZZZ(2) = XNUM/DENOM ELSE ZZZZ(2) = D1MACH(2) IERR =1 END IF RETURN END * DOUBLE PRECISION FUNCTION DNRM2 ( N, DX, INCX) INTEGER I,INCX,J,N,NEXT,NN DOUBLE PRECISION DX(1), CUTLO, CUTHI, HITEST, SUM, XMAX DOUBLE PRECISION ONE,ZERO PARAMETER (ZERO=0.0D0, ONE=1.0D0) C C EUCLIDEAN NORM OF THE N-VECTOR STORED IN DX() WITH STORAGE C INCREMENT INCX . C IF N .LE. 0 RETURN WITH RESULT = 0. C IF N .GE. 1 THEN INCX MUST BE .GE. 1 C C C.L.LAWSON, 1978 JAN 08 C C FOUR PHASE METHOD USING TWO BUILT-IN CONSTANTS THAT ARE C HOPEFULLY APPLICABLE TO ALL MACHINES. C CUTLO = MAXIMUM OF DSQRT(U/EPS) OVER ALL KNOWN MACHINES. C CUTHI = MINIMUM OF DSQRT(V) OVER ALL KNOWN MACHINES. C WHERE C EPS = SMALLEST NO. SUCH THAT EPS + 1. .GT. 1. C U = SMALLEST POSITIVE NO. (UNDERFLOW LIMIT) C V = LARGEST NO. (OVERFLOW LIMIT) C C BRIEF OUTLINE OF ALGORITHM.. C C PHASE 1 SCANS ZERO COMPONENTS. C MOVE TO PHASE 2 WHEN A COMPONENT IS NONZERO AND .LE. CUTLO C MOVE TO PHASE 3 WHEN A COMPONENT IS .GT. CUTLO C MOVE TO PHASE 4 WHEN A COMPONENT IS .GE. CUTHI/M C WHERE M = N FOR X() REAL AND M = 2*N FOR COMPLEX. C C VALUES FOR CUTLO AND CUTHI.. C FROM THE ENVIRONMENTAL PARAMETERS LISTED IN THE IMSL CONVERTER C DOCUMENT THE LIMITING VALUES ARE AS FOLLOWS.. C CUTLO, S.P. U/EPS = 2**(-102) FOR HONEYWELL. CLOSE SECONDS ARE C UNIVAC AND DEC AT 2**(-103) C THUS CUTLO = 2**(-51) = 4.44089E-16 C CUTHI, S.P. V = 2**127 FOR UNIVAC, HONEYWELL, AND DEC. C THUS CUTHI = 2**(63.5) = 1.30438E19 C CUTLO, D.P. U/EPS = 2**(-67) FOR HONEYWELL AND DEC. C THUS CUTLO = 2**(-33.5) = 8.23181D-11 C CUTHI, D.P. SAME AS S.P. CUTHI = 1.30438D19 C DATA CUTLO, CUTHI / 8.232D-11, 1.304D19 / C DATA CUTLO, CUTHI / 4.441E-16, 1.304E19 / DATA CUTLO, CUTHI / 8.232D-11, 1.304D19 / C IF(N .GT. 0) GO TO 10 DNRM2 = ZERO GO TO 300 C 10 ASSIGN 30 TO NEXT SUM = ZERO NN = N * INCX C BEGIN MAIN LOOP I = 1 20 GO TO NEXT,(30, 50, 70, 110) 30 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 ASSIGN 50 TO NEXT XMAX = ZERO C C PHASE 1. SUM IS ZERO C 50 IF( DX(I) .EQ. ZERO) GO TO 200 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 C C PREPARE FOR PHASE 2. ASSIGN 70 TO NEXT GO TO 105 C C PREPARE FOR PHASE 4. C 100 I = J ASSIGN 110 TO NEXT SUM = (SUM / DX(I)) / DX(I) 105 XMAX = DABS(DX(I)) GO TO 115 C C PHASE 2. SUM IS SMALL. C SCALE TO AVOID DESTRUCTIVE UNDERFLOW. C 70 IF( DABS(DX(I)) .GT. CUTLO ) GO TO 75 C C COMMON CODE FOR PHASES 2 AND 4. C IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. C 110 IF( DABS(DX(I)) .LE. XMAX ) GO TO 115 SUM = ONE + SUM * (XMAX / DX(I))**2 XMAX = DABS(DX(I)) GO TO 200 C 115 SUM = SUM + (DX(I)/XMAX)**2 GO TO 200 C C C PREPARE FOR PHASE 3. C 75 SUM = (SUM * XMAX) * XMAX C C C FOR REAL OR D.P. SET HITEST = CUTHI/N C FOR COMPLEX SET HITEST = CUTHI/(2*N) C 85 HITEST = CUTHI/FLOAT( N ) C C PHASE 3. SUM IS MID-RANGE. NO SCALING. C DO 95 J =I,NN,INCX IF(DABS(DX(J)) .GE. HITEST) GO TO 100 95 SUM = SUM + DX(J)**2 DNRM2 = DSQRT( SUM ) GO TO 300 C 200 CONTINUE I = I + INCX IF ( I .LE. NN ) GO TO 20 C C END OF MAIN LOOP. C C COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. C DNRM2 = XMAX * DSQRT(SUM) 300 CONTINUE RETURN END SUBROUTINE DSCAL(N,DA,DX,INCX) C C SCALES A VECTOR BY A CONSTANT. C USES UNROLLED LOOPS FOR INCREMENT EQUAL TO ONE. C JACK DONGARRA, LINPACK, 3/11/78. C DOUBLE PRECISION DA,DX(1) INTEGER I,INCX,M,MP1,N,NINCX C IF(N.LE.0)RETURN IF(INCX.EQ.1)GO TO 20 C C CODE FOR INCREMENT NOT EQUAL TO 1 C NINCX = N*INCX DO 10 I = 1,NINCX,INCX DX(I) = DA*DX(I) 10 CONTINUE RETURN C C CODE FOR INCREMENT EQUAL TO 1 C C C CLEAN-UP LOOP C 20 M = MOD(N,5) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M DX(I) = DA*DX(I) 30 CONTINUE IF( N .LT. 5 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,5 DX(I) = DA*DX(I) DX(I + 1) = DA*DX(I + 1) DX(I + 2) = DA*DX(I + 2) DX(I + 3) = DA*DX(I + 3) DX(I + 4) = DA*DX(I + 4) 50 CONTINUE RETURN END SUBROUTINE F(X,V) DOUBLE PRECISION X(1),V(1) C C EVALUATE F(X) AND RETURN IN THE VECTOR V . C RETURN END SUBROUTINE FFUNP(N,NUMT,MMAXT,KDEG,COEF,CL,X, $ XX,TRM,DTRM,CLX,DXNP1,F,DF) C C FFUNP EVALUATES THE SYSTEM "F(X)=0" AND ITS PARTIAL C DERIVATIVES, USING THE "TABLEAU" INPUT: N,NUMT,KDEG,COEF. C C FFUNP CAN BE MADE MORE EFFICIENT BY CUSTOMIZING IT TO C PARTICULAR SYSTEM TYPES. FOR EXAMPLE, C IF X(1)**2 AND X(1)**3 ARE USED IN SEVERAL C EQUATIONS, THE CURRENT FFUNP RECOMPUTES BOTH OF THESE FOR C EACH EQUATION. BUT (OF COURSE) WE CAN COMPUTE C X1SQ=X(1)**2 AND X1CU=XSQ(1)*X(1), AND C USE THESE IN EACH OF THE EQUATIONS. C C THE PART OF THE CODE BELOW LABELED "BLOCK A" CAN BE C CUSTOMIZED IN THIS WAY. (THE CODE OUTSIDE OF C BLOCK A CONCERNS THE PROJECTIVE TRANSFORMATION AND NEED NOT C BE CHANGED.) HOWEVER, BLOCK A REQUIRES THE HOMOGENEOUS FORM C OF THE POLYNOMIALS RATHER THAN THE STANDARD FORM. FURTHER, C THE PARTIAL DERIVATIVES WITH RESPECT TO ALL N+1 PROJECTIVE C VARIABLES MUST BE COMPUTED. MORE EXPLICITLY, C THE ORIGINAL SYSTEM, F(X)=0, IS GIVEN IN "NON-HOMOGENEOUS FORM" AS C DESCRIBED IN SUBROUTINE POLSYS. F(X) IS C REPRESENTED IN "HOMOGENEOUS FORM" AS FOLLOWS: C C NUMT(J) C C F(J) = SUM TRM(J,K) C C K=1 C C WHERE TRM(J,K)=COEF(J,K) * XX(J,1,K)*XX(J,2,K)* ... *XX(J,N+1,K) C C WITH XX(J,L,K) = X(L)**KDEG(J,L,K) FOR J=1 TO N, L=1 TO N, AND C K=1 TO NUMT(J), AND WITH XX(J,N+1,K) = XNP1**KDEG(J,N+1,K) FOR J=1 TO C N AND K=1 TO NUMT(J), WHERE XNP1 IS THE "HOMOGENEOUS COORDINATE," C KDEG(J,N+1,K)=IDEG(J)-(KDEG(J,1,K)+ ... + KDEG(J,N,K)), C AND IDEG(J) THE DEGREE OF THE J-TH EQUATION. XNP1 IS GENERATED C FROM X AND CL BEFORE BLOCK A. C C IN THIS DISCUSSION WE HAVE OMITTED, FOR SIMPLICITY OF C EXPOSITION, THE LEADING INDEX, WHICH DIFFERENTIATES THE C REAL AND IMAGINARY PARTS. HOWEVER, THIS INDEX MUST NOT BE C OMITTED IN THE CODE. C C WE COMPLETE THE EXPOSITION OF "REPLACING BLOCK A WITH MORE EFFICIENT C CODE" WITH AN EXPLICIT EXAMPLE. FIRST, THE SYSTEM IS DESCRIBED. C THEN THE CODE THAT SHOULD BE USED IS GIVEN (COMMENTED OUT). C IN TESTS POLSYS WITH THE MORE EFFICIENT FFUNP RAN ABOUT TWICE AS C FAST AS WITH THE GENERIC FFUNP . C C HERE IS THE SYSTEM TO BE SOLVED: C C F(1) = COEF(1,1) * X(1)**4 C & + COEF(1,2) * X(1)**3 * X(2) C & + COEF(1,3) * X(1)**3 C & + COEF(1,4) * X(1) C & + COEF(1,5) C F(2) = COEF(2,1) * X(1) * X(2)**2 C & + COEF(2,2) X(2)**2 C & + COEF(2,3) C C THE REPLACEMENT CODE REQUIRES THE FOLLOWING DECLARATIONS: C DOUBLE PRECISION X1SQ,X1CU,X2SQ,X3SQ,X3CU, C & TEMPA,TEMPB,TEMPC,TEMPD,TEMPE,TEMPF C DIMENSION X1SQ(2),X1CU(2),X2SQ(2),X3SQ(2),X3CU(2), C & TEMPA(2),TEMPB(2),TEMPC(2),TEMPD(2),TEMPE(2),TEMPF(2) C C HERE IS CODE TO REPLACE BLOCK A: C C****************** BEGIN BLOCK A ******************* C C CALL MULP(X(1,1),X(1,1),X1SQ) C CALL MULP(X1SQ ,X(1,1),X1CU) C CALL MULP(X(1,2),X(1,2),X2SQ) C CALL MULP(XNP1, XNP1, X3SQ) C CALL MULP(X3SQ ,XNP1, X3CU) C C DO 1 I=1,2 C TEMPA(I)= COEF(1,1) * X(I,1) C & + COEF(1,2) * X(I,2) C & + COEF(1,3) * XNP1(I) C TEMPB(I)= COEF(1,4) * X(I,1) C & + COEF(1,5) * XNP1(I) C 1 CONTINUE C C CALL MULP(X1SQ, TEMPA,TEMPC) C CALL MULP(X(1,1),TEMPC,TEMPD) C CALL MULP(X3SQ, TEMPB,TEMPE) C CALL MULP(XNP1, TEMPE,TEMPF) C C DO 2 I=1,2 C F(I,1)=TEMPD(I) + TEMPF(I) C DF(I,1,1)= 3. *TEMPC(I) + COEF(1,1)*X1CU(I) + COEF(1,4)*X3CU(I) C DF(I,1,2)= COEF(1,2) * X1CU(I) C DF(I,1,3)= COEF(1,3)*X1CU(I) + 3. *TEMPE(I) + COEF(1,5)*X3CU(I) C C TEMPA(I) = COEF(2,1) * X(I,1) + COEF(2,2) * XNP1(I) C 2 CONTINUE C C CALL MULP(TEMPA,X(1,2),TEMPB) C CALL MULP(TEMPB,X(1,2),TEMPC) C C DO 3 I=1,2 C F(I,2) = TEMPC(I) + COEF(2,3) * X3CU(I) C DF(I,2,1) = COEF(2,1) * X2SQ(I) C DF(I,2,2) = 2. * TEMPB(I) C DF(I,2,3) = COEF(2,2) * X2SQ(I) + COEF(2,3) * 3. * X3SQ(I) C 3 CONTINUE C****************** END OF BLOCK A ******************* C C ON INPUT: C C N IS THE NUMBER OF EQUATIONS AND VARIABLES. C C NUMT(J) IS THE NUMBER OF TERMS IN THE JTH EQUATION. C C MMAXT IS AN UPPER BOUND ON NUMT(J) FOR J=1 TO N. C C KDEG(J,L,K) IS THE DEGREE OF THE L-TH VARIABLE IN THE K-TH TERM C OF THE J-TH EQUATION. C C COEF(J,K) IS THE K-TH COEFFICIENT OF THE J-TH EQUATION. C C CL IS USED TO DEFINE THE PROJECTIVE TRANSFORMATION. IF C THE PROJECTIVE TRANSFORMATION IS NOT SPECIFIED, THEN CL C CONTAINS DUMMY VALUES. C C X(1,J), X(2,J) ARE THE REAL AND IMAGINARY PARTS RESPECTIVELY OF C THE J-TH INDEPENDENT VARIABLE. C C XX, TRM, DTRM, CLX, DXNP1 ARE WORKSPACE VARIABLES. C C ON OUTPUT: C C F(1,J), F(2,J) ARE THE REAL AND IMAGINARY PARTS RESPECTIVELY OF C THE J-TH EQUATION. C C DF(1,J,K), DF(2,J,K) ARE THE REAL AND IMAGINARY PARTS RESPECTIVELY C OF THE K-TH PARTIAL DERIVATIVE OF THE J-TH EQUATION. C C C VARIABLES: XNP1,TEMP1,TEMP2. C C NOTE: XNP1(1), XNP1(2) ARE THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE PROJECTIVE VARIABLE. XNP1 IS UNITY C IF THE PROJECTIVE TRANSFORMATION IS NOT SPECIFIED. C C SUBROUTINES: MULP,POWP,DIVP. C C C DECLARATION OF INPUT AND OUTPUT: INTEGER N,NUMT,MMAXT,KDEG DOUBLE PRECISION COEF,CL,X,XX,TRM,DTRM,CLX,DXNP1,F,DF DIMENSION NUMT(N),KDEG(N,N+1,MMAXT), $ COEF(N,MMAXT),CL(2,N+1),X(2,N), $ XX(2,N,N+1,MMAXT),TRM(2,N,MMAXT),DTRM(2,N,N+1,MMAXT), $ CLX(2,N),DXNP1(2,N),F(2,N),DF(2,N,N+1) C C DECLARATION OF VARIABLES: INTEGER I,IERR,J,K,L,M,NNNN,NP1 DOUBLE PRECISION TEMP1,TEMP2,XNP1 DIMENSION TEMP1(2),TEMP2(2),XNP1(2) C NP1=N+1 C C GENERATE XNP1, THE PROJECTIVE COORDINATE, AND ITS DERIVATIVES. DO 40 J=1,N CALL MULP(CL(1,J),X(1,J),CLX(1,J)) 40 CONTINUE C DO 60 I=1,2 XNP1(I)=CL(I,NP1) DO 50 J=1,N XNP1(I) = XNP1(I) + CLX(I,J) DXNP1(I,J)=CL(I,J) 50 CONTINUE 60 CONTINUE C C****************** BEGIN BLOCK A ******************* C C "BLOCK A" TAKES X AND XNP1 AS INPUT AND RETURNS F C AND DF AS OUTPUT. F IS THE HOMOGENEOUS FORM OF THE C ORIGINAL F, AND DF CONSISTS OF THE PARTIAL C DERIVATIVES OF THE HOMOGENEOUS FORM OF F WITH RESPECT C TO THE N+1 VARIABLES X(1), ... ,X(N), XNP1. C C BEGIN "COMPUTE F" C DO 100 J=1,N DO 100 K=1,NUMT(J) CALL POWP(KDEG(J,NP1,K),XNP1, XX(1,J,NP1,K)) DO 100 L=1,N CALL POWP(KDEG(J, L,K),X(1,L),XX(1,J, L,K)) 100 CONTINUE DO 200 J=1,N DO 200 K=1,NUMT(J) TRM(1,J,K)=COEF(J,K) TRM(2,J,K)=0.0 DO 120 L=1,NP1 CALL MULP(XX(1,J,L,K), TRM(1,J,K),TEMP1) TRM(1,J,K )=TEMP1(1) TRM(2,J,K )=TEMP1(2) 120 CONTINUE 200 CONTINUE DO 300 J=1,N F(1,J)=0.0 F(2,J)=0.0 DO 220 I=1,2 DO 220 K=1,NUMT(J) F(I,J)= F(I,J) + TRM(I,J,K) 220 CONTINUE 300 CONTINUE C C END OF "COMPUTE F" C C BEGIN "COMPUTE DF" C DO 400 J=1,N DO 400 K=1,NUMT(J) DO 400 M=1,NP1 C C IF TERM DOES NOT INCLUDE X(M), SET PARTIAL DERIVATIVE OF TERM C EQUAL TO ZERO. IF(KDEG(J,M,K) .EQ. 0) THEN DTRM(1,J,M,K)=0.0 DTRM(2,J,M,K)=0.0 ELSE C C IF TERM DOES INCLUDE X(M), TRY COMPUTING THE PARTIAL BY DIVIDING C THE TERM BY X(M). IF(M.LE.N) CALL DIVP(TRM(1,J,K),X(1,M),DTRM(1,J,M,K),IERR) IF(M.EQ.NP1) CALL DIVP(TRM(1,J,K),XNP1,DTRM(1,J,M,K),IERR) IF (IERR .EQ. 0) THEN DTRM(1,J,M,K)=KDEG(J,M,K)*DTRM(1,J,M,K) DTRM(2,J,M,K)=KDEG(J,M,K)*DTRM(2,J,M,K) ELSE C C IF DIVISION WOULD CAUSE OVERFLOW, GENERATE THE PARTIAL BY C THE POLYNOMIAL FORMULA. DTRM(1,J,M,K)=COEF(J,K) DTRM(2,J,M,K)=0.0 DO 320 L=1,NP1 IF (L .EQ. M) GOTO 320 CALL MULP(XX(1,J,L,K),DTRM(1,J,M,K),TEMP1) DTRM(1,J,M,K)=TEMP1(1) DTRM(2,J,M,K)=TEMP1(2) 320 CONTINUE NNNN=KDEG(J,M,K)-1 IF (M .LE. N) CALL POWP(NNNN,X(1,M),TEMP2) IF (M .EQ. NP1) CALL POWP(NNNN,XNP1 ,TEMP2) CALL MULP(TEMP2,TEMP1,DTRM(1,J,M,K)) DTRM(1,J,M,K)=KDEG(J,M,K)*DTRM(1,J,M,K) DTRM(2,J,M,K)=KDEG(J,M,K)*DTRM(2,J,M,K) END IF END IF 400 CONTINUE DO 600 J=1,N DO 600 M=1,NP1 DF(1,J,M)=0.0 DF(2,J,M)=0.0 DO 420 I=1,2 DO 420 K=1,NUMT(J) DF(I,J,M)= DF(I,J,M) + DTRM(I,J,M,K) 420 CONTINUE 600 CONTINUE C C END OF "COMPUTE DF" C******************* END BLOCK A ******************** C C CONVERT DF TO BE PARTIALS WITH RESPECT TO X(1), ... ,X(N), C BY APPLYING THE CHAIN RULE WITH XNP1 CONSIDERED A FUNCTION OF C OF X(1), ... ,X(N). C DO 700 J=1,N DO 700 K=1,N CALL MULP(DF(1,J,NP1),DXNP1(1,K),TEMP1) DO 700 I=1,2 DF(I,J,K)=DF(I,J,K)+TEMP1(I) 700 CONTINUE RETURN END * SUBROUTINE FIXPDF(N,Y,IFLAG,ARCTOL,EPS,TRACE,A,NDIMA,NFE, $ ARCLEN,YP,YPOLD,QR,ALPHA,TZ,PIVOT,WT,PHI,P,PAR,IPAR) C C SUBROUTINE FIXPDF FINDS A FIXED POINT OR ZERO OF THE C N-DIMENSIONAL VECTOR FUNCTION F(X), OR TRACKS A ZERO CURVE C OF A GENERAL HOMOTOPY MAP RHO(A,LAMBDA,X). FOR THE FIXED C POINT PROBLEM F(X) IS ASSUMED TO BE A C2 MAP OF SOME BALL C INTO ITSELF. THE EQUATION X = F(X) IS SOLVED BY C FOLLOWING THE ZERO CURVE OF THE HOMOTOPY MAP C C LAMBDA*(X - F(X)) + (1 - LAMBDA)*(X - A) , C C STARTING FROM LAMBDA = 0, X = A. THE CURVE IS PARAMETERIZED C BY ARC LENGTH S, AND IS FOLLOWED BY SOLVING THE ORDINARY C DIFFERENTIAL EQUATION D(HOMOTOPY MAP)/DS = 0 FOR C Y(S) = (LAMBDA(S), X(S)). C C FOR THE ZERO FINDING PROBLEM F(X) IS ASSUMED TO BE A C2 MAP C SUCH THAT FOR SOME R > 0, X*F(X) >= 0 WHENEVER NORM(X) = R. C THE EQUATION F(X) = 0 IS SOLVED BY FOLLOWING THE ZERO CURVE C OF THE HOMOTOPY MAP C C LAMBDA*F(X) + (1 - LAMBDA)*(X - A) C C EMANATING FROM LAMBDA = 0, X = A. C C A MUST BE AN INTERIOR POINT OF THE ABOVE MENTIONED BALLS. C C FOR THE CURVE TRACKING PROBLEM RHO(A,LAMBDA,X) IS ASSUMED TO C BE A C2 MAP FROM E**M X [0,1) X E**N INTO E**N, WHICH FOR C ALMOST ALL PARAMETER VECTORS A IN SOME NONEMPTY OPEN SUBSET C OF E**M SATISFIES C C RANK [D RHO(A,LAMBDA,X)/D LAMBDA , D RHO(A,LAMBDA,X)/DX] = N C C FOR ALL POINTS (LAMBDA,X) SUCH THAT RHO(A,LAMBDA,X)=0. IT IS C FURTHER ASSUMED THAT C C RANK [ D RHO(A,0,X0)/DX ] = N . C C WITH A FIXED, THE ZERO CURVE OF RHO(A,LAMBDA,X) EMANATING C FROM LAMBDA = 0, X = X0 IS TRACKED UNTIL LAMBDA = 1 BY C SOLVING THE ORDINARY DIFFERENTIAL EQUATION C D RHO(A,LAMBDA(S),X(S))/DS = 0 FOR Y(S) = (LAMBDA(S), X(S)), C WHERE S IS ARC LENGTH ALONG THE ZERO CURVE. ALSO THE HOMOTOPY C MAP RHO(A,LAMBDA,X) IS ASSUMED TO BE CONSTRUCTED SUCH THAT C C D LAMBDA(0)/DS > 0 . C C THIS CODE IS BASED ON THE ALGORITHM IN L. T. WATSON, A C GLOBALLY CONVERGENT ALGORITHM FOR COMPUTING FIXED POINTS OF C C2 MAPS, APPL. MATH. COMPUT., 5 (1979) 297-311. C C C FOR THE FIXED POINT AND ZERO FINDING PROBLEMS, THE USER C MUST SUPPLY A SUBROUTINE F(X,V) WHICH EVALUATES F(X) AT X C AND RETURNS THE VECTOR F(X) IN V, AND A SUBROUTINE FJAC(X,V,K) C WHICH RETURNS IN V THE KTH COLUMN OF THE JACOBIAN MATRIX OF C F(X) EVALUATED AT X. FOR THE CURVE TRACKING PROBLEM, THE USER MUST C SUPPLY A SUBROUTINE RHOA(V,LAMBDA,X,PAR,IPAR) WHICH GIVEN C (LAMBDA,X) RETURNS A PARAMETER VECTOR A IN V SUCH THAT C RHO(A,LAMBDA,X)=0, AND A SUBROUTINE RHOJAC(A,LAMBDA,X,V,K,PAR,IPAR) C WHICH RETURNS IN V THE KTH COLUMN OF THE N X (N+1) JACOBIAN C MATRIX [D RHO/D LAMBDA, D RHO/DX] EVALUATED AT (A,LAMBDA,X). C FIXPDF DIRECTLY OR INDIRECTLY USES THE SUBROUTINES C STEPS , SINTRP , ROOT , FODE , F (OR RHOA ), C FJAC (OR RHOJAC ), DCPOSE , D1MACH , AND THE BLAS FUNCTIONS C DDOT AND DNRM2 . ONLY D1MACH CONTAINS MACHINE C DEPENDENT CONSTANTS. NO OTHER MODIFICATIONS BY THE USER ARE C REQUIRED. C C ***WARNING: THIS SUBROUTINE IS GENERALLY MORE ROBUST THAN FIXPNF C AND FIXPQF , BUT MAY BE SLOWER THAN THOSE SUBROUTINES BY A C FACTOR OF TWO. C C C ON INPUT: C C N IS THE DIMENSION OF X, F(X), AND RHO(A,LAMBDA,X). C C Y IS AN ARRRAY OF LENGTH N + 1. (Y(2),...,Y(N+1)) = A IS THE C STARTING POINT FOR THE ZERO CURVE FOR THE FIXED POINT AND C ZERO FINDING PROBLEMS. (Y(2),...,Y(N+1)) = X0 FOR THE CURVE C TRACKING PROBLEM. C C IFLAG CAN BE -2, -1, 0, 2, OR 3. IFLAG SHOULD BE 0 ON THE C FIRST CALL TO FIXPDF FOR THE PROBLEM X=F(X), -1 FOR THE C PROBLEM F(X)=0, AND -2 FOR THE PROBLEM RHO(A,LAMBDA,X)=0. C IN CERTAIN SITUATIONS IFLAG IS SET TO 2 OR 3 BY FIXPDF, C AND FIXPDF CAN BE CALLED AGAIN WITHOUT CHANGING IFLAG. C C ARCTOL IS THE LOCAL ERROR ALLOWED THE ODE SOLVER WHEN C FOLLOWING THE ZERO CURVE. IF ARCTOL .LE. 0.0 ON INPUT C IT IS RESET TO .5*DSQRT(EPS). NORMALLY ARCTOL SHOULD C BE CONSIDERABLY LARGER THAN EPS. C C EPS IS THE LOCAL ERROR ALLOWED THE ODE SOLVER WHEN VERY C NEAR THE FIXED POINT(ZERO). EPS IS APPROXIMATELY THE C MIXED ABSOLUTE AND RELATIVE ERROR IN THE COMPUTED FIXED C POINT(ZERO). C C TRACE IS AN INTEGER SPECIFYING THE LOGICAL I/O UNIT FOR C INTERMEDIATE OUTPUT. IF TRACE .GT. 0 THE POINTS COMPUTED ON C THE ZERO CURVE ARE WRITTEN TO I/O UNIT TRACE . C C A(1:NDIMA) CONTAINS THE PARAMETER VECTOR A . FOR THE FIXED POINT C AND ZERO FINDING PROBLEMS, A NEED NOT BE INITIALIZED BY THE C USER, AND IS ASSUMED TO HAVE LENGTH N. FOR THE CURVE C TRACKING PROBLEM, A HAS LENGTH NDIMA AND MUST BE INITIALIZED C BY THE USER. C C NDIMA IS THE DIMENSION OF A, AND IS USED ONLY FOR THE CURVE C TRACKING PROBLEM. C C YP(1:N+1) IS A WORK ARRAY CONTAINING THE CURRENT TANGENT C VECTOR TO THE ZERO CURVE. C C YPOLD(1:N+1) IS A WORK ARRAY CONTAINING THE PREVIOUS TANGENT C VECTOR TO THE ZERO CURVE. C C QR(1:N,1:N+1), ALPHA(1:N), TZ(1:N+1), AND PIVOT(1:N+1) ARE C ALL WORK ARRAYS USED BY FODE TO CALCULATE THE TANGENT C VECTOR YP. C C WT(1:N+1), PHI(1:N+1,1:16), AND P(1:N+1) ARE ALL WORK ARRAYS C USED BY THE ODE SUBROUTINE STEPS . C C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS, C WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES C RHOA, RHOJAC. C C Y, ARCTOL, EPS, ARCLEN, NFE, AND IFLAG SHOULD ALL BE C VARIABLES IN THE CALLING PROGRAM. C C C ON OUTPUT: C C N AND TRACE ARE UNCHANGED. C C Y(1) = LAMBDA, (Y(2),...,Y(N+1)) = X, AND Y IS AN APPROXIMATE C ZERO OF THE HOMOTOPY MAP. NORMALLY LAMBDA = 1 AND X IS A C FIXED POINT(ZERO) OF F(X). IN ABNORMAL SITUATIONS LAMBDA C MAY ONLY BE NEAR 1 AND X IS NEAR A FIXED POINT(ZERO). C C IFLAG = C -2 CAUSES FIXPDF TO INITIALIZE EVERYTHING FOR THE PROBLEM C RHO(A,LAMBDA,X) = 0 (USE ON FIRST CALL). C C -1 CAUSES FIXPDF TO INITIALIZE EVERYTHING FOR THE PROBLEM C F(X) = 0 (USE ON FIRST CALL). C C 0 CAUSES FIXPDF TO INITIALIZE EVERYTHING FOR THE PROBLEM C X = F(X) (USE ON FIRST CALL). C C 1 NORMAL RETURN. C C 2 SPECIFIED ERROR TOLERANCE CANNOT BE MET. EPS HAS BEEN C INCREASED TO A SUITABLE VALUE. TO CONTINUE, JUST CALL C FIXPDF AGAIN WITHOUT CHANGING ANY PARAMETERS. C C 3 STEPS HAS BEEN CALLED 1000 TIMES. TO CONTINUE, CALL C FIXPDF AGAIN WITHOUT CHANGING ANY PARAMETERS. C C 4 JACOBIAN MATRIX DOES NOT HAVE FULL RANK. THE ALGORITHM C HAS FAILED (THE ZERO CURVE OF THE HOMOTOPY MAP CANNOT BE C FOLLOWED ANY FURTHER). C C 5 EPS (OR ARCTOL ) IS TOO LARGE. THE PROBLEM SHOULD BE C RESTARTED BY CALLING FIXPDF WITH A SMALLER EPS (OR C ARCTOL ) AND IFLAG = 0 (-1, -2). C C 6 I - DF(X) IS NEARLY SINGULAR AT THE FIXED POINT (DF(X) IS C NEARLY SINGULAR AT THE ZERO, OR D RHO(A,LAMBDA,X)/DX IS C NEARLY SINGULAR AT LAMBDA = 1 ). ANSWER MAY NOT BE C ACCURATE. C C 7 ILLEGAL INPUT PARAMETERS, A FATAL ERROR. C C ARCTOL = EPS AFTER A NORMAL RETURN (IFLAG = 1). C C EPS IS UNCHANGED AFTER A NORMAL RETURN (IFLAG = 1). IT IS C INCREASED TO AN APPROPRIATE VALUE ON THE RETURN IFLAG = 2. C C A WILL (NORMALLY) HAVE BEEN MODIFIED. C C NFE IS THE NUMBER OF FUNCTION EVALUATIONS (= NUMBER OF C JACOBIAN EVALUATIONS). C C ARCLEN IS THE LENGTH OF THE PATH FOLLOWED. C C DOUBLE PRECISION AOLD,ARCLEN,ARCTOL,CURSW,CURTOL,EPS, 1 EPSSTP,EPST,H,HOLD,S,S99,SA,SB,SOUT,SQNP1,XOLD,Y1SOUT INTEGER IFLAG,IFLAGC,ITER,IVC,J,JUDY,JW,K,KGI,KOLD, 1 KSTEPS,LCODE,LIMIT,LIMITD,N,NDIMA,NFE,NFEC,NP1,TRACE LOGICAL START,CRASH,ST99 C C ***** ARRAY DECLARATIONS. ***** C C ARRAYS NEEDED BY THE ODE SUBROUTINE STEPS . DOUBLE PRECISION Y(N+1),WT(N+1),PHI(N+1,16),P(N+1),YP(N+1), 1 ALPHAS(12),W(12),G(13),GI(11) INTEGER IV(10) C C ARRAYS NEEDED BY FIXPDF , FODE , AND DCPOSE . DOUBLE PRECISION YPOLD(N+1),A(N),QR(N,N+1),ALPHA(N),TZ(N+1), $ PAR(1) INTEGER PIVOT(N+1),IPAR(1) C C ***** END OF DIMENSIONAL INFORMATION. ***** C SAVE EXTERNAL FODE C C LIMITD IS AN UPPER BOUND ON THE NUMBER OF STEPS. IT MAY BE C CHANGED BY CHANGING THE FOLLOWING PARAMETER STATEMENT: PARAMETER (LIMITD=1000) C C C : : : : : : : : : : : : : : : : : : : : : IF (N .LE. 0 .OR. EPS .LE. 0.0 ) IFLAG=7 IF (IFLAG .GE. -2 .AND. IFLAG .LE. 0) GO TO 10 IF (IFLAG .EQ. 2) GO TO 35 IF (IFLAG .EQ. 3) GO TO 30 C ONLY VALID INPUT FOR IFLAG IS -2, -1, 0, 2, 3. IFLAG=7 RETURN C C ***** INITIALIZATION BLOCK. ***** C 10 ARCLEN=0.0 S=0.0 IF (ARCTOL .LE. 0.0) ARCTOL=.5*SQRT(EPS) NFEC=0 IFLAGC=IFLAG NP1=N+1 SQNP1=SQRT(DBLE(NP1)) C C SWITCH FROM THE TOLERANCE ARCTOL TO THE (FINER) TOLERANCE EPS IF C THE CURVATURE OF ANY COMPONENT OF Y EXCEEDS CURSW. C CURSW=10.0 C ST99=.FALSE. START=.TRUE. CRASH=.FALSE. HOLD=1.0 H=.1 EPSSTP=ARCTOL KSTEPS=0 C SET INITIAL CONDITIONS FOR ORDINARY DIFFERENTIAL EQUATION. YPOLD(1)=1.0 YP(1)=1.0 Y(1)=0.0 DO 20 J=2,NP1 YPOLD(J)=0.0 YP(J)=0.0 20 CONTINUE C LOAD A FOR THE FIXED POINT AND ZERO FINDING PROBLEMS. IF (IFLAGC .GE. -1) THEN DO 23 J=2,NP1 A(J-1)=Y(J) 23 CONTINUE ENDIF 30 LIMIT=LIMITD C C ***** END OF INITIALIZATION BLOCK. ***** C C C ***** MAIN LOOP. ***** C 35 DO 150 ITER=1,LIMIT IF (Y(1) .LT. 0.0) THEN 40 ARCLEN=ARCLEN+S IFLAG=5 RETURN ENDIF 50 IF (S .LE. 7.0*SQNP1) GO TO 80 C ARC LENGTH IS GETTING TOO LONG, THE PROBLEM WILL BE C RESTARTED WITH A DIFFERENT A VECTOR. ARCLEN=ARCLEN+S S=0.0 60 START=.TRUE. CRASH=.FALSE. C COMPUTE A NEW A VECTOR. IF (IFLAGC .EQ. -2) THEN DO 63 JW=1,NDIMA QR(JW,1)=A(JW) 63 CONTINUE CALL RHOA(A,Y(1),Y(2),PAR,IPAR) DO 65 JW=1,NDIMA AOLD=QR(JW,1) C IF NEW AND OLD A DIFFER BY TOO MUCH, TRACKING SHOULD NOT CONTINUE. IF (ABS(A(JW)-AOLD) .GT. 1.0+ABS(AOLD)) THEN ARCLEN=ARCLEN+S IFLAG=5 RETURN ENDIF 65 CONTINUE ELSE CALL F(Y(2),YP) DO 70 JW=1,N AOLD=A(JW) IF (IFLAGC .EQ. -1) THEN A(JW)=Y(1)*YP(JW)/(1.0 - Y(1)) + Y(JW+1) ELSE A(JW)=(Y(JW+1) - Y(1)*YP(JW))/(1.0 - Y(1)) ENDIF C IF NEW AND OLD A DIFFER BY TOO MUCH, TRACKING SHOULD NOT CONTINUE. IF (ABS(A(JW)-AOLD) .GT. 1.0+ABS(AOLD)) THEN ARCLEN=ARCLEN+S IFLAG=5 RETURN ENDIF 70 CONTINUE ENDIF GO TO 100 80 IF (Y(1) .LE. .99 .OR. ST99) GO TO 100 C WHEN LAMBDA REACHES .99, THE PROBLEM WILL BE RESTARTED WITH C A NEW A VECTOR. 90 ST99=.TRUE. EPSSTP=EPS ARCTOL=EPS GO TO 60 C C SET DIFFERENT ERROR TOLERANCE FOR HIGH CURVATURE COMPONENTS OF THE C TRAJECTORY Y(S). 100 CURTOL=CURSW*HOLD EPST=EPS/EPSSTP DO 110 JW=1,NP1 IF (ABS(YP(JW)-YPOLD(JW)) .LE. CURTOL) THEN WT(JW)=(ABS(Y(JW))+1.0) ELSE WT(JW)=(ABS(Y(JW))+1.0)*EPST ENDIF 110 CONTINUE C C TAKE A STEP ALONG THE CURVE. CALL STEPS(FODE,NP1,Y,S,H,EPSSTP,WT,START,HOLD,K,KOLD,CRASH, + PHI,P,YP,ALPHAS,W,G,KSTEPS,XOLD,IVC,IV,KGI,GI, + YPOLD,A,QR,ALPHA,TZ,PIVOT,NFEC,IFLAGC,PAR,IPAR) C PRINT LATEST POINT ON CURVE IF REQUESTED. IF (TRACE .GT. 0) THEN WRITE (TRACE,117) ITER,NFEC,S,Y(1),(Y(JW),JW=2,NP1) 117 FORMAT(/' STEP',I5,3X,'NFE =',I5,3X,'ARC LENGTH =',F9.4,3X, $ 'LAMBDA =',F7.4,5X,'X vector:'/1P,(1X,6E12.4)) ENDIF NFE=NFEC C CHECK IF THE STEP WAS SUCCESSFUL. IF (IFLAGC .EQ. 4) THEN ARCLEN=ARCLEN+S IFLAG=4 RETURN ENDIF 120 IF (CRASH) THEN C RETURN CODE FOR ERROR TOLERANCE TOO SMALL. IFLAG=2 C CHANGE ERROR TOLERANCES. EPS=EPSSTP IF (ARCTOL .LT. EPS) ARCTOL=EPS C CHANGE LIMIT ON NUMBER OF ITERATIONS. LIMIT=LIMIT-ITER RETURN ENDIF C 130 IF (Y(1) .GE. 1.0) THEN IF (ST99) GO TO 160 C C IF LAMBDA .GE. 1.0 BUT THE PROBLEM HAS NOT BEEN RESTARTED C WITH A NEW A VECTOR, BACK UP AND RESTART. C S99=S-.5*HOLD C GET AN APPROXIMATE ZERO Y(S) WITH Y(1)=LAMBDA .LT. 1.0 . 135 CALL SINTRP(S,Y,S99,WT,YP,NP1,KOLD,PHI,IVC,IV,KGI,GI, $ ALPHAS,G,W,XOLD,P) IF (WT(1) .LT. 1.0) GO TO 140 S99=.5*(S-HOLD+S99) GO TO 135 C 140 DO 144 JUDY=1,NP1 Y(JUDY)=WT(JUDY) YPOLD(JUDY)=YP(JUDY) 144 CONTINUE S=S99 GO TO 90 ENDIF C 150 CONTINUE C C ***** END OF MAIN LOOP. ***** C C LAMBDA HAS NOT REACHED 1 IN 1000 STEPS. IFLAG=3 RETURN C C C USE INVERSE INTERPOLATION TO GET THE ANSWER AT LAMBDA = 1.0 . C 160 SA=S-HOLD SB=S LCODE=1 170 CALL ROOT(SOUT,Y1SOUT,SA,SB,EPS,EPS,LCODE) C ROOT FINDS S SUCH THAT Y(1)(S) = LAMBDA = 1 . IF (LCODE .GT. 0) GO TO 190 CALL SINTRP(S,Y,SOUT,WT,YP,NP1,KOLD,PHI,IVC,IV,KGI,GI, $ ALPHAS,G,W,XOLD,P) Y1SOUT=WT(1)-1.0 GO TO 170 190 IFLAG=1 C SET IFLAG = 6 IF ROOT COULD NOT GET LAMBDA = 1.0 . IF (LCODE .GT. 2) IFLAG=6 ARCLEN=ARCLEN+SA C LAMBDA(SA) = 1.0 . CALL SINTRP(S,Y,SA,WT,YP,NP1,KOLD,PHI,IVC,IV,KGI,GI, $ ALPHAS,G,W,XOLD,P) C DO 210 J=1,NP1 210 Y(J)=WT(J) RETURN END SUBROUTINE FIXPDS(N,Y,IFLAG,ARCTOL,EPS,TRACE,A,NDIMA,NFE, $ ARCLEN,YP,YPOLD,QR,LENQR,PIVOT,PP,WORK,WT,PHI,P, $ PAR,IPAR) C C SUBROUTINE FIXPDS FINDS A FIXED POINT OR ZERO OF THE C N-DIMENSIONAL VECTOR FUNCTION F(X), OR TRACKS A ZERO CURVE C OF A GENERAL HOMOTOPY MAP RHO(A,X,LAMBDA). FOR THE FIXED C POINT PROBLEM F(X) IS ASSUMED TO BE A C2 MAP OF SOME BALL C INTO ITSELF. THE EQUATION X = F(X) IS SOLVED BY C FOLLOWING THE ZERO CURVE OF THE HOMOTOPY MAP C C LAMBDA*(X - F(X)) + (1 - LAMBDA)*(X - A) , C C STARTING FROM LAMBDA = 0, X = A. THE CURVE IS PARAMETERIZED C BY ARC LENGTH S, AND IS FOLLOWED BY SOLVING THE ORDINARY C DIFFERENTIAL EQUATION D(HOMOTOPY MAP)/DS = 0 FOR C Y(S) = (X(S), LAMBDA(S)). C C FOR THE ZERO FINDING PROBLEM F(X) IS ASSUMED TO BE A C2 MAP C SUCH THAT FOR SOME R > 0, X*F(X) >= 0 WHENEVER NORM(X) = R. C THE EQUATION F(X) = 0 IS SOLVED BY FOLLOWING THE ZERO CURVE C OF THE HOMOTOPY MAP C C LAMBDA*F(X) + (1 - LAMBDA)*(X - A) C C EMANATING FROM LAMBDA = 0, X = A. C C A MUST BE AN INTERIOR POINT OF THE ABOVE MENTIONED BALLS. C C FOR THE CURVE TRACKING PROBLEM RHO(A,X,LAMBDA) IS ASSUMED TO C BE A C2 MAP FROM E**M X E**N X [0,1) INTO E**N, WHICH FOR C ALMOST ALL PARAMETER VECTORS A IN SOME NONEMPTY OPEN SUBSET C OF E**M SATISFIES C C RANK [D RHO(A,X,LAMBDA)/D LAMBDA , D RHO(A,X,LAMBDA)/DX] = N C C FOR ALL POINTS (X,LAMBDA) SUCH THAT RHO(A,X,LAMBDA)=0. IT IS C FURTHER ASSUMED THAT C C RANK [ D RHO(A,X0,0)/DX ] = N . C C WITH A FIXED, THE ZERO CURVE OF RHO(A,X,LAMBDA) EMANATING C FROM LAMBDA = 0, X = X0 IS TRACKED UNTIL LAMBDA = 1 BY C SOLVING THE ORDINARY DIFFERENTIAL EQUATION C D RHO(A,X(S),LAMBDA(S))/DS = 0 FOR Y(S) = (X(S), LAMBDA(S)), C WHERE S IS ARC LENGTH ALONG THE ZERO CURVE. ALSO THE HOMOTOPY C MAP RHO(A,X,LAMBDA) IS ASSUMED TO BE CONSTRUCTED SUCH THAT C C D LAMBDA(0)/DS > 0 . C C THIS CODE IS BASED ON THE ALGORITHM IN L. T. WATSON, A C GLOBALLY CONVERGENT ALGORITHM FOR COMPUTING FIXED POINTS OF C C2 MAPS, APPL. MATH. COMPUT., 5 (1979) 297-311. C C C FOR THE FIXED POINT AND ZERO FINDING PROBLEMS, THE USER C MUST SUPPLY A SUBROUTINE F(X,V) WHICH EVALUATES F(X) AT X C AND RETURNS THE VECTOR F(X) IN V, AND A SUBROUTINE C FJACS(X,QR,LENQR,PIVOT) WHICH EVALUATES THE (SYMMETRIC) C JACOBIAN MATRIX OF F(X) AT X, AND RETURNS THE SYMMETRIC C JACOBIAN MATRIX IN PACKED SKYLINE STORAGE FORMAT IN QR. LENQR C AND PIVOT DESCRIBE THE DATA STRUCTURE IN QR. FOR THE CURVE C TRACKING PROBLEM, THE USER MUST SUPPLY A SUBROUTINE C RHOA(V,LAMBDA,X,PAR,IPAR) WHICH GIVEN (X,LAMBDA) RETURNS A C PARAMETER VECTOR A IN V SUCH THAT RHO(A,X,LAMBDA)=0, AND A C SUBROUTINE RHOJS(A,LAMBDA,X,QR,LENQR,PIVOT,PP,PAR,IPAR) WHICH C RETURNS IN QR THE SYMMETRIC N X N JACOBIAN MATRIX [D RHO/DX] C EVALUATED AT (A,X,LAMBDA) AND STORED IN PACKED SKYLINE FORMAT, C AND RETURNS IN PP THE VECTOR -(D RHO/D LAMBDA) EVALUATED AT C (A,X,LAMBDA). LENQR AND PIVOT DESCRIBE THE DATA STRUCTURE IN QR. C *** NOTE THE MINUS SIGN IN THE DEFINITION OF PP. *** C C C FUNCTIONS AND SUBROUTINES DIRECTLY OR INDIRECTLY CALLED BY FIXPDS: C D1MACH , F (OR RHOA ), FJACS (OR RHOJS ), FODEDS , GMFADS , C MFACDS , MULTDS , PCGDS , QIMUDS , ROOT , SINTRP , SOLVDS , C STEPDS , AND THE BLAS FUNCTIONS DAXPY , DCOPY , DDOT , DNRM2 , C DSCAL , IDAMAX . ONLY D1MACH CONTAINS MACHINE DEPENDENT C CONSTANTS. NO OTHER MODIFICATIONS BY THE USER ARE REQUIRED. C C ***WARNING: THIS SUBROUTINE IS GENERALLY MORE ROBUST THAN FIXPNS C AND FIXPQS , BUT MAY BE SLOWER THAN THOSE SUBROUTINES BY A C FACTOR OF TWO. C C C ON INPUT: C C N IS THE DIMENSION OF X, F(X), AND RHO(A,X,LAMBDA). C C Y IS AN ARRRAY OF LENGTH N + 1. (Y(1),...,Y(N)) = A IS THE C STARTING POINT FOR THE ZERO CURVE FOR THE FIXED POINT AND C ZERO FINDING PROBLEMS. (Y(1),...,Y(N)) = X0 FOR THE CURVE C TRACKING PROBLEM. C C IFLAG CAN BE -2, -1, 0, 2, OR 3. IFLAG SHOULD BE 0 ON THE C FIRST CALL TO FIXPDS FOR THE PROBLEM X=F(X), -1 FOR THE C PROBLEM F(X)=0, AND -2 FOR THE PROBLEM RHO(A,X,LAMBDA)=0. C IN CERTAIN SITUATIONS IFLAG IS SET TO 2 OR 3 BY FIXPDS, C AND FIXPDS CAN BE CALLED AGAIN WITHOUT CHANGING IFLAG. C C ARCTOL IS THE LOCAL ERROR ALLOWED THE ODE SOLVER WHEN C FOLLOWING THE ZERO CURVE. IF ARCTOL .LE. 0.0 ON INPUT C IT IS RESET TO .5*DSQRT(EPS). NORMALLY ARCTOL SHOULD C BE CONSIDERABLY LARGER THAN EPS. C C EPS IS THE LOCAL ERROR ALLOWED THE ODE SOLVER WHEN VERY C NEAR THE FIXED POINT(ZERO). EPS IS APPROXIMATELY THE C MIXED ABSOLUTE AND RELATIVE ERROR IN THE COMPUTED FIXED C POINT(ZERO). C C TRACE IS AN INTEGER SPECIFYING THE LOGICAL I/O UNIT FOR C INTERMEDIATE OUTPUT. IF TRACE .GT. 0 THE POINTS COMPUTED ON C THE ZERO CURVE ARE WRITTEN TO I/O UNIT TRACE . C C A(1:NDIMA) CONTAINS THE PARAMETER VECTOR A . FOR THE FIXED POINT C AND ZERO FINDING PROBLEMS, A NEED NOT BE INITIALIZED BY THE C USER, AND IS ASSUMED TO HAVE LENGTH N. FOR THE CURVE C TRACKING PROBLEM, A HAS LENGTH NDIMA AND MUST BE INITIALIZED C BY THE USER. C C NDIMA IS THE DIMENSION OF A , AND IS USED ONLY FOR THE CURVE C TRACKING PROBLEM. C C YP(1:N+1) IS A WORK ARRAY CONTAINING THE CURRENT TANGENT C VECTOR TO THE ZERO CURVE. C C YPOLD(1:N+1) IS A WORK ARRAY CONTAINING THE PREVIOUS TANGENT C VECTOR TO THE ZERO CURVE. C C QR(1:LENQR) IS A WORK ARRAY CONTAINING THE (SYMMETRIC) JACOBIAN C MATRIX WITH RESPECT TO X, IN THE PACKED SKYLINE STORAGE FORMAT. C C LENQR IS THE DIMENSION OF QR . C C PIVOT(1:N+2), PP(1:N), AND WORK(1:6*(N+1)+LENQR) ARE ALL WORK C ARRAYS USED BY FODEDS TO CALCULATE THE TANGENT VECTOR YP. C C WT(1:N+1), PHI(1:N+1,1:16), AND P(1:N+1) ARE ALL WORK ARRAYS C USED BY THE ODE SUBROUTINE STEPDS . C C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS, C WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES C RHOA, RHOJS. C C Y, ARCTOL, EPS, ARCLEN, NFE, AND IFLAG SHOULD ALL BE C VARIABLES IN THE CALLING PROGRAM. C C C ON OUTPUT: C C N AND TRACE ARE UNCHANGED. C C (Y(1),...,Y(N)) = X, Y(N+1) = LAMBDA, AND Y IS AN APPROXIMATE C ZERO OF THE HOMOTOPY MAP. NORMALLY LAMBDA = 1 AND X IS A C FIXED POINT(ZERO) OF F(X). IN ABNORMAL SITUATIONS LAMBDA C MAY ONLY BE NEAR 1 AND X IS NEAR A FIXED POINT(ZERO). C C IFLAG = C -2 CAUSES FIXPDS TO INITIALIZE EVERYTHING FOR THE PROBLEM C RHO(A,X,LAMBDA) = 0 (USE ON FIRST CALL). C C -1 CAUSES FIXPDS TO INITIALIZE EVERYTHING FOR THE PROBLEM C F(X) = 0 (USE ON FIRST CALL). C C 0 CAUSES FIXPDS TO INITIALIZE EVERYTHING FOR THE PROBLEM C X = F(X) (USE ON FIRST CALL). C C 1 NORMAL RETURN. C C 2 SPECIFIED ERROR TOLERANCE CANNOT BE MET. EPS HAS BEEN C INCREASED TO A SUITABLE VALUE. TO CONTINUE, JUST CALL C FIXPDS AGAIN WITHOUT CHANGING ANY PARAMETERS. C C 3 STEPDS HAS BEEN CALLED 1000 TIMES. TO CONTINUE, CALL C FIXPDS AGAIN WITHOUT CHANGING ANY PARAMETERS. C C 4 JACOBIAN MATRIX DOES NOT HAVE FULL RANK AND/OR THE CONJUGATE C GRADIENT ITERATION FOR THE KERNEL OF THE JACOBIAN MATRIX C FAILED TO CONVERGE. THE ALGORITHM HAS FAILED (THE ZERO C CURVE OF THE HOMOTOPY MAP CANNOT BE FOLLOWED ANY FURTHER). C C 5 EPS (OR ARCTOL ) IS TOO LARGE. THE PROBLEM SHOULD BE C RESTARTED BY CALLING FIXPDS WITH A SMALLER EPS (OR C ARCTOL ) AND IFLAG = 0 (-1, -2). C C 6 I - DF(X) IS NEARLY SINGULAR AT THE FIXED POINT (DF(X) IS C NEARLY SINGULAR AT THE ZERO, OR D RHO(A,X,LAMBDA)/DX IS C NEARLY SINGULAR AT LAMBDA = 1 ). ANSWER MAY NOT BE C ACCURATE. C C 7 ILLEGAL INPUT PARAMETERS, A FATAL ERROR. C C ARCTOL = EPS AFTER A NORMAL RETURN (IFLAG = 1). C C EPS IS UNCHANGED AFTER A NORMAL RETURN (IFLAG = 1). IT IS C INCREASED TO AN APPROPRIATE VALUE ON THE RETURN IFLAG = 2. C C A WILL (NORMALLY) HAVE BEEN MODIFIED. C C NFE IS THE NUMBER OF FUNCTION EVALUATIONS (= NUMBER OF C JACOBIAN EVALUATIONS). C C ARCLEN IS THE LENGTH OF THE PATH FOLLOWED. C C DOUBLE PRECISION AOLD,ARCLEN,ARCTOL,CURSW,CURTOL,EPS, 1 EPSSTP,EPST,H,HOLD,S,S99,SA,SB,SOUT,SQNP1,XOLD,Y1SOUT INTEGER IFLAG,IFLAGC,ITER,IVC,J,JW,K,KGI,KOLD, 1 KSTEPS,LCODE,LENQR,LIMIT,LIMITD,N,NDIMA,NFE,NFEC,NP1,TRACE LOGICAL START,CRASH,ST99 C C ***** ARRAY DECLARATIONS. ***** C C ARRAYS NEEDED BY THE ODE SUBROUTINE STEPDS . DOUBLE PRECISION Y(N+1),WT(N+1),PHI(N+1,16),P(N+1),YP(N+1), 1 ALPHAS(12),W(12),G(13),GI(11) INTEGER IV(10) C C ARRAYS NEEDED BY FIXPDS , FODEDS , AND PCGDS . DOUBLE PRECISION YPOLD(N+1),A(N),QR(LENQR),PP(N), 1 WORK(6*(N+1)+LENQR),PAR(1) INTEGER PIVOT(N+2),IPAR(1) C C ***** END OF DIMENSIONAL INFORMATION. ***** C SAVE EXTERNAL FODEDS C C LIMITD IS AN UPPER BOUND ON THE NUMBER OF STEPS. IT MAY BE C CHANGED BY CHANGING THE FOLLOWING PARAMETER STATEMENT: PARAMETER (LIMITD=1000) C C C : : : : : : : : : : : : : : : : : : : : : IF (N .LE. 0 .OR. EPS .LE. 0.0 ) IFLAG=7 IF (IFLAG .GE. -2 .AND. IFLAG .LE. 0) GO TO 10 IF (IFLAG .EQ. 2) GO TO 35 IF (IFLAG .EQ. 3) GO TO 30 C ONLY VALID INPUT FOR IFLAG IS -2, -1, 0, 2, 3. IFLAG=7 RETURN C C ***** INITIALIZATION BLOCK. ***** C 10 ARCLEN=0.0 S=0.0 IF (ARCTOL .LE. 0.0) ARCTOL=.5*SQRT(EPS) NFEC=0 IFLAGC=IFLAG NP1=N+1 SQNP1=SQRT(DBLE(NP1)) C C SWITCH FROM THE TOLERANCE ARCTOL TO THE (FINER) TOLERANCE EPS IF C THE CURVATURE OF ANY COMPONENT OF Y EXCEEDS CURSW. C CURSW=10.0 C ST99=.FALSE. START=.TRUE. CRASH=.FALSE. HOLD=1.0 H=.1 EPSSTP=ARCTOL KSTEPS=0 C SET INITIAL CONDITIONS FOR ORDINARY DIFFERENTIAL EQUATION. YPOLD(NP1)=1.0 YP(NP1)=1.0 Y(NP1)=0.0 WORK(2*NP1)=0.0 WORK(3*NP1)=0.0 DO 20 J=1,N YPOLD(J)=0.0 YP(J)=0.0 WORK(NP1+J)=0.0 WORK(2*NP1+J)=0.0 20 CONTINUE C LOAD A FOR THE FIXED POINT AND ZERO FINDING PROBLEMS. IF (IFLAGC .GE. -1) THEN CALL DCOPY(N,Y,1,A,1) ENDIF 30 LIMIT=LIMITD C C ***** END OF INITIALIZATION BLOCK. ***** C C C ***** MAIN LOOP. ***** C 35 DO 150 ITER=1,LIMIT IF (Y(NP1) .LT. 0.0) THEN 40 ARCLEN=ARCLEN+S IFLAG=5 RETURN ENDIF 50 IF (S .LE. 7.0*SQNP1) GO TO 80 C ARC LENGTH IS GETTING TOO LONG, THE PROBLEM WILL BE C RESTARTED WITH A DIFFERENT A VECTOR. ARCLEN=ARCLEN+S S=0.0 60 START=.TRUE. CRASH=.FALSE. C COMPUTE A NEW A VECTOR. IF (IFLAGC .EQ. -2) THEN DO 63 JW=1,NDIMA QR(JW)=A(JW) 63 CONTINUE CALL RHOA(A,Y(NP1),Y,PAR,IPAR) DO 65 JW=1,NDIMA AOLD=QR(JW) C IF NEW AND OLD A DIFFER BY TOO MUCH, TRACKING SHOULD NOT CONTINUE. IF (ABS(A(JW)-AOLD) .GT. 1.0+ABS(AOLD)) THEN ARCLEN=ARCLEN+S IFLAG=5 RETURN ENDIF 65 CONTINUE ELSE CALL F(Y,YP) DO 70 JW=1,N AOLD=A(JW) IF (IFLAGC .EQ. -1) THEN A(JW)=Y(NP1)*YP(JW)/(1.0 - Y(NP1)) + Y(JW) ELSE A(JW)=(Y(JW) - Y(NP1)*YP(JW))/(1.0 - Y(NP1)) ENDIF C IF NEW AND OLD A DIFFER BY TOO MUCH, TRACKING SHOULD NOT CONTINUE. IF (ABS(A(JW)-AOLD) .GT. 1.0+ABS(AOLD)) THEN ARCLEN=ARCLEN+S IFLAG=5 RETURN ENDIF 70 CONTINUE ENDIF GO TO 100 80 IF (Y(NP1) .LE. .99 .OR. ST99) GO TO 100 C WHEN LAMBDA REACHES .99, THE PROBLEM WILL BE RESTARTED WITH C A NEW A VECTOR. 90 ST99=.TRUE. EPSSTP=EPS ARCTOL=EPS GO TO 60 C C SET DIFFERENT ERROR TOLERANCE FOR HIGH CURVATURE COMPONENTS OF THE C TRAJECTORY Y(S). 100 CURTOL=CURSW*HOLD EPST=EPS/EPSSTP DO 110 JW=1,NP1 IF (ABS(YP(JW)-YPOLD(JW)) .LE. CURTOL) THEN WT(JW)=(ABS(Y(JW))+1.0) ELSE WT(JW)=(ABS(Y(JW))+1.0)*EPST ENDIF 110 CONTINUE C C TAKE A STEP ALONG THE CURVE. CALL STEPDS(FODEDS,NP1,Y,S,H,EPSSTP,WT,START,HOLD,K,KOLD,CRASH, + PHI,P,YP,ALPHAS,W,G,KSTEPS,XOLD,IVC,IV,KGI,GI, + YPOLD,A,QR,LENQR,PIVOT,PP,WORK,NFEC,IFLAGC,PAR,IPAR) C PRINT LATEST POINT ON CURVE IF REQUESTED. IF (TRACE .GT. 0) THEN WRITE (TRACE,117) ITER,NFEC,S,Y(NP1),(Y(JW),JW=1,N) 117 FORMAT(/' STEP',I5,3X,'NFE =',I5,3X,'ARC LENGTH =',F9.4,3X, $ 'LAMBDA =',F7.4,5X,'X vector:'/1P,(1X,6E12.4)) ENDIF NFE=NFEC C CHECK IF THE STEP WAS SUCCESSFUL. IF (IFLAGC .EQ. 4) THEN ARCLEN=ARCLEN+S IFLAG=4 RETURN ENDIF 120 IF (CRASH) THEN C RETURN CODE FOR ERROR TOLERANCE TOO SMALL. IFLAG=2 C CHANGE ERROR TOLERANCES. EPS=EPSSTP IF (ARCTOL .LT. EPS) ARCTOL=EPS C CHANGE LIMIT ON NUMBER OF ITERATIONS. LIMIT=LIMIT-ITER RETURN ENDIF C 130 IF (Y(NP1) .GE. 1.0) THEN IF (ST99) GO TO 160 C C IF LAMBDA .GE. 1.0 BUT THE PROBLEM HAS NOT BEEN RESTARTED C WITH A NEW A VECTOR, BACK UP AND RESTART. C S99=S-.5*HOLD C GET AN APPROXIMATE ZERO Y(S) WITH Y(NP1)=LAMBDA .LT. 1.0 . 135 CALL SINTRP(S,Y,S99,WT,YP,NP1,KOLD,PHI,IVC,IV,KGI,GI, $ ALPHAS,G,W,XOLD,P) IF (WT(NP1) .LT. 1.0) GO TO 140 S99=.5*(S-HOLD+S99) GO TO 135 C 140 CALL DCOPY(NP1,WT,1,Y,1) CALL DCOPY(NP1,YP,1,YPOLD,1) S=S99 GO TO 90 ENDIF C 150 CONTINUE C C ***** END OF MAIN LOOP. ***** C C LAMBDA HAS NOT REACHED 1 IN 1000 STEPS. IFLAG=3 RETURN C C C USE INVERSE INTERPOLATION TO GET THE ANSWER AT LAMBDA = 1.0 . C 160 SA=S-HOLD SB=S LCODE=1 170 CALL ROOT(SOUT,Y1SOUT,SA,SB,EPS,EPS,LCODE) C ROOT FINDS S SUCH THAT Y(NP1)(S) = LAMBDA = 1 . IF (LCODE .GT. 0) GO TO 190 CALL SINTRP(S,Y,SOUT,WT,YP,NP1,KOLD,PHI,IVC,IV,KGI,GI, $ ALPHAS,G,W,XOLD,P) Y1SOUT=WT(NP1)-1.0 GO TO 170 190 IFLAG=1 C SET IFLAG = 6 IF ROOT COULD NOT GET LAMBDA = 1.0 . IF (LCODE .GT. 2) IFLAG=6 ARCLEN=ARCLEN+SA C LAMBDA(SA) = 1.0 . CALL SINTRP(S,Y,SA,WT,YP,NP1,KOLD,PHI,IVC,IV,KGI,GI, $ ALPHAS,G,W,XOLD,P) C CALL DCOPY(NP1,WT,1,Y,1) C RETURN END SUBROUTINE FIXPNF(N,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE,A,NFE, $ ARCLEN,YP,YOLD,YPOLD,QR,ALPHA,TZ,PIVOT,W,WP,Z0,Z1,SSPAR, $ PAR,IPAR) C C SUBROUTINE FIXPNF FINDS A FIXED POINT OR ZERO OF THE C N-DIMENSIONAL VECTOR FUNCTION F(X), OR TRACKS A ZERO CURVE C OF A GENERAL HOMOTOPY MAP RHO(A,LAMBDA,X). FOR THE FIXED C POINT PROBLEM F(X) IS ASSUMED TO BE A C2 MAP OF SOME BALL C INTO ITSELF. THE EQUATION X = F(X) IS SOLVED BY C FOLLOWING THE ZERO CURVE OF THE HOMOTOPY MAP C C LAMBDA*(X - F(X)) + (1 - LAMBDA)*(X - A) , C C STARTING FROM LAMBDA = 0, X = A. THE CURVE IS PARAMETERIZED C BY ARC LENGTH S, AND IS FOLLOWED BY SOLVING THE ORDINARY C DIFFERENTIAL EQUATION D(HOMOTOPY MAP)/DS = 0 FOR C Y(S) = (LAMBDA(S), X(S)) USING A HERMITE CUBIC PREDICTOR AND A C CORRECTOR WHICH RETURNS TO THE ZERO CURVE ALONG THE FLOW NORMAL C TO THE DAVIDENKO FLOW (WHICH CONSISTS OF THE INTEGRAL CURVES OF C D(HOMOTOPY MAP)/DS ). C C FOR THE ZERO FINDING PROBLEM F(X) IS ASSUMED TO BE A C2 MAP C SUCH THAT FOR SOME R > 0, X*F(X) >= 0 WHENEVER NORM(X) = R. C THE EQUATION F(X) = 0 IS SOLVED BY FOLLOWING THE ZERO CURVE C OF THE HOMOTOPY MAP C C LAMBDA*F(X) + (1 - LAMBDA)*(X - A) C C EMANATING FROM LAMBDA = 0, X = A. C C A MUST BE AN INTERIOR POINT OF THE ABOVE MENTIONED BALLS. C C FOR THE CURVE TRACKING PROBLEM RHO(A,LAMBDA,X) IS ASSUMED TO C BE A C2 MAP FROM E**M X [0,1) X E**N INTO E**N, WHICH FOR C ALMOST ALL PARAMETER VECTORS A IN SOME NONEMPTY OPEN SUBSET C OF E**M SATISFIES C C RANK [D RHO(A,LAMBDA,X)/D LAMBDA , D RHO(A,LAMBDA,X)/DX] = N C C FOR ALL POINTS (LAMBDA,X) SUCH THAT RHO(A,LAMBDA,X)=0. IT IS C FURTHER ASSUMED THAT C C RANK [ D RHO(A,0,X0)/DX ] = N . C C WITH A FIXED, THE ZERO CURVE OF RHO(A,LAMBDA,X) EMANATING C FROM LAMBDA = 0, X = X0 IS TRACKED UNTIL LAMBDA = 1 BY C SOLVING THE ORDINARY DIFFERENTIAL EQUATION C D RHO(A,LAMBDA(S),X(S))/DS = 0 FOR Y(S) = (LAMBDA(S), X(S)), C WHERE S IS ARC LENGTH ALONG THE ZERO CURVE. ALSO THE HOMOTOPY C MAP RHO(A,LAMBDA,X) IS ASSUMED TO BE CONSTRUCTED SUCH THAT C C D LAMBDA(0)/DS > 0 . C C C FOR THE FIXED POINT AND ZERO FINDING PROBLEMS, THE USER MUST SUPPLY C A SUBROUTINE F(X,V) WHICH EVALUATES F(X) AT X AND RETURNS THE C VECTOR F(X) IN V, AND A SUBROUTINE FJAC(X,V,K) WHICH RETURNS IN V C THE KTH COLUMN OF THE JACOBIAN MATRIX OF F(X) EVALUATED AT X. FOR C THE CURVE TRACKING PROBLEM, THE USER MUST SUPPLY A SUBROUTINE C RHO(A,LAMBDA,X,V,PAR,IPAR) WHICH EVALUATES THE HOMOTOPY MAP RHO AT C (A,LAMBDA,X) AND RETURNS THE VECTOR RHO(A,LAMBDA,X) IN V, AND A C SUBROUTINE RHOJAC(A,LAMBDA,X,V,K,PAR,IPAR) WHICH RETURNS IN V THE KT C COLUMN OF THE N X (N+1) JACOBIAN MATRIX [D RHO/D LAMBDA, D RHO/DX] C EVALUATED AT (A,LAMBDA,X). FIXPNF DIRECTLY OR INDIRECTLY USES C THE SUBROUTINES STEPNF , TANGNF , ROOTNF , ROOT , F (OR RHO ), C FJAC (OR RHOJAC ), D1MACH , AND THE BLAS FUNCTIONS DDOT AND C DNRM2 . ONLY D1MACH CONTAINS MACHINE DEPENDENT CONSTANTS. C NO OTHER MODIFICATIONS BY THE USER ARE REQUIRED. C C C ON INPUT: C C N IS THE DIMENSION OF X, F(X), AND RHO(A,LAMBDA,X). C C Y IS AN ARRRAY OF LENGTH N + 1. (Y(2),...,Y(N+1)) = A IS THE C STARTING POINT FOR THE ZERO CURVE FOR THE FIXED POINT AND C ZERO FINDING PROBLEMS. (Y(2),...,Y(N+1)) = X0 FOR THE CURVE C TRACKING PROBLEM. C C IFLAG CAN BE -2, -1, 0, 2, OR 3. IFLAG SHOULD BE 0 ON THE C FIRST CALL TO FIXPNF FOR THE PROBLEM X=F(X), -1 FOR THE C PROBLEM F(X)=0, AND -2 FOR THE PROBLEM RHO(A,LAMBDA,X)=0. C IN CERTAIN SITUATIONS IFLAG IS SET TO 2 OR 3 BY FIXPNF, C AND FIXPNF CAN BE CALLED AGAIN WITHOUT CHANGING IFLAG. C C ARCRE , ARCAE ARE THE RELATIVE AND ABSOLUTE ERRORS, RESPECTIVELY, C ALLOWED THE NORMAL FLOW ITERATION ALONG THE ZERO CURVE. IF C ARC?E .LE. 0.0 ON INPUT IT IS RESET TO .5*SQRT(ANS?E) . C NORMALLY ARC?E SHOULD BE CONSIDERABLY LARGER THAN ANS?E . C C ANSRE , ANSAE ARE THE RELATIVE AND ABSOLUTE ERROR VALUES USED FOR C THE ANSWER AT LAMBDA = 1. THE ACCEPTED ANSWER Y = (LAMBDA, X) C SATISFIES C C |Y(1) - 1| .LE. ANSRE + ANSAE .AND. C C ||Z|| .LE. ANSRE*||X|| + ANSAE WHERE C C (.,Z) IS THE NEWTON STEP TO Y. C C TRACE IS AN INTEGER SPECIFYING THE LOGICAL I/O UNIT FOR C INTERMEDIATE OUTPUT. IF TRACE .GT. 0 THE POINTS COMPUTED ON C THE ZERO CURVE ARE WRITTEN TO I/O UNIT TRACE . C C A(1:*) CONTAINS THE PARAMETER VECTOR A . FOR THE FIXED POINT C AND ZERO FINDING PROBLEMS, A NEED NOT BE INITIALIZED BY THE C USER, AND IS ASSUMED TO HAVE LENGTH N. FOR THE CURVE C TRACKING PROBLEM, A MUST BE INITIALIZED BY THE USER. C C YP(1:N+1) IS A WORK ARRAY CONTAINING THE TANGENT VECTOR TO C THE ZERO CURVE AT THE CURRENT POINT Y . C C YOLD(1:N+1) IS A WORK ARRAY CONTAINING THE PREVIOUS POINT FOUND C ON THE ZERO CURVE. C C YPOLD(1:N+1) IS A WORK ARRAY CONTAINING THE TANGENT VECTOR TO C THE ZERO CURVE AT YOLD . C C QR(1:N,1:N+2), ALPHA(1:N), TZ(1:N+1), PIVOT(1:N+1) , W(1:N+1) , C WP(1:N+1) , Z0(1:N+1) , Z1(1:N+1) ARE ALL WORK ARRAYS USED BY C STEPNF TO CALCULATE THE TANGENT VECTORS AND NEWTON STEPS. C C SSPAR(1:8) = (LIDEAL, RIDEAL, DIDEAL, HMIN, HMAX, BMIN, BMAX, P) IS C A VECTOR OF PARAMETERS USED FOR THE OPTIMAL STEP SIZE ESTIMATION. C IF SSPAR(J) .LE. 0.0 ON INPUT, IT IS RESET TO A DEFAULT VALUE C BY FIXPNF . OTHERWISE THE INPUT VALUE OF SSPAR(J) IS USED. C SEE THE COMMENTS BELOW AND IN STEPNF FOR MORE INFORMATION ABOUT C THESE CONSTANTS. C C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS, C WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES C RHO, RHOJAC. C C C ON OUTPUT: C C N , TRACE , A ARE UNCHANGED. C C Y(1) = LAMBDA, (Y(2),...,Y(N+1)) = X, AND Y IS AN APPROXIMATE C ZERO OF THE HOMOTOPY MAP. NORMALLY LAMBDA = 1 AND X IS A C FIXED POINT(ZERO) OF F(X). IN ABNORMAL SITUATIONS LAMBDA C MAY ONLY BE NEAR 1 AND X IS NEAR A FIXED POINT(ZERO). C C IFLAG = C -2 CAUSES FIXPNF TO INITIALIZE EVERYTHING FOR THE PROBLEM C RHO(A,LAMBDA,X) = 0 (USE ON FIRST CALL). C C -1 CAUSES FIXPNF TO INITIALIZE EVERYTHING FOR THE PROBLEM C F(X) = 0 (USE ON FIRST CALL). C C 0 CAUSES FIXPNF TO INITIALIZE EVERYTHING FOR THE PROBLEM C X = F(X) (USE ON FIRST CALL). C C 1 NORMAL RETURN. C C 2 SPECIFIED ERROR TOLERANCE CANNOT BE MET. SOME OR ALL OF C ARCRE , ARCAE , ANSRE , ANSAE HAVE BEEN INCREASED TO C SUITABLE VALUES. TO CONTINUE, JUST CALL FIXPNF AGAIN C WITHOUT CHANGING ANY PARAMETERS. C C 3 STEPNF HAS BEEN CALLED 1000 TIMES. TO CONTINUE, CALL C FIXPNF AGAIN WITHOUT CHANGING ANY PARAMETERS. C C 4 JACOBIAN MATRIX DOES NOT HAVE FULL RANK. THE ALGORITHM C HAS FAILED (THE ZERO CURVE OF THE HOMOTOPY MAP CANNOT BE C FOLLOWED ANY FURTHER). C C 5 THE TRACKING ALGORITHM HAS LOST THE ZERO CURVE OF THE C HOMOTOPY MAP AND IS NOT MAKING PROGRESS. THE ERROR TOLERANCES C ARC?E AND ANS?E WERE TOO LENIENT. THE PROBLEM SHOULD BE C RESTARTED BY CALLING FIXPNF WITH SMALLER ERROR TOLERANCES C AND IFLAG = 0 (-1, -2). C C 6 THE NORMAL FLOW NEWTON ITERATION IN STEPNF OR ROOTNF C FAILED TO CONVERGE. THE ERROR TOLERANCES ANS?E MAY BE TOO C STRINGENT. C C 7 ILLEGAL INPUT PARAMETERS, A FATAL ERROR. C C ARCRE , ARCAE , ANSRE , ANSAE ARE UNCHANGED AFTER A NORMAL RETURN C (IFLAG = 1). THEY ARE INCREASED TO APPROPRIATE VALUES ON THE C RETURN IFLAG = 2 . C C NFE IS THE NUMBER OF FUNCTION EVALUATIONS (= NUMBER OF C JACOBIAN EVALUATIONS). C C ARCLEN IS THE LENGTH OF THE PATH FOLLOWED. C C C DOUBLE PRECISION ABSERR,ANSAE,ANSRE,ARCAE,ARCLEN,ARCRE, 1 CURSW,CURTOL,D1MACH,DNRM2,H,HOLD,RELERR,S INTEGER IFLAG,IFLAGC,ITER,JW,LIMIT,LIMITD,N,NC,NFE,NFEC,NP1, 1 TRACE LOGICAL CRASH,POLSYS,START C C ***** ARRAY DECLARATIONS. ***** C DOUBLE PRECISION Y(N+1),YP(N+1),YOLD(N+1),YPOLD(N+1),A(N), $ QR(N,N+2),ALPHA(N),TZ(N+1),W(N+1),WP(N+1),Z0(N+1), $ Z1(N+1),SSPAR(8),PAR(1) INTEGER PIVOT(N+1),IPAR(1) C C ***** END OF DIMENSIONAL INFORMATION. ***** C SAVE C C LIMITD IS AN UPPER BOUND ON THE NUMBER OF STEPS. IT MAY BE C CHANGED BY CHANGING THE FOLLOWING PARAMETER STATEMENT: PARAMETER (LIMITD=1000) C C SWITCH FROM THE TOLERANCE ARC?E TO THE (FINER) TOLERANCE ANS?E IF C THE CURVATURE OF ANY COMPONENT OF Y EXCEEDS CURSW. PARAMETER (CURSW=10.0) C C C C : : : : : : : : : : : : : : : : : : : : : : : : C SET LOGICAL SWITCH TO REFLECT ENTRY POINT. POLSYS=.FALSE. GO TO 11 ENTRY POLYNF(N,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE,A,NFE, $ ARCLEN,YP,YOLD,YPOLD,QR,ALPHA,TZ,PIVOT,W,WP,Z0,Z1,SSPAR, $ PAR,IPAR) POLSYS=.TRUE. 11 CONTINUE C IF (N .LE. 0 .OR. ANSRE .LE. 0.0 .OR. ANSAE .LT. 0.0) $ IFLAG=7 IF (IFLAG .GE. -2 .AND. IFLAG .LE. 0) GO TO 20 IF (IFLAG .EQ. 2) GO TO 120 IF (IFLAG .EQ. 3) GO TO 90 C ONLY VALID INPUT FOR IFLAG IS -2, -1, 0, 2, 3. IFLAG=7 RETURN C C ***** INITIALIZATION BLOCK. ***** C 20 ARCLEN=0.0 IF (ARCRE .LE. 0.0) ARCRE=.5*SQRT(ANSRE) IF (ARCAE .LE. 0.0) ARCAE=.5*SQRT(ANSAE) NC=N NFEC=0 IFLAGC=IFLAG NP1=N+1 C SET INITIAL CONDITIONS FOR FIRST CALL TO STEPNF . START=.TRUE. CRASH=.FALSE. HOLD=1.0 H=.1 S=0.0 YPOLD(1)=1.0 YP(1)=1.0 Y(1)=0.0 DO 40 JW=2,NP1 YPOLD(JW)=0.0 YP(JW)=0.0 40 CONTINUE C SET OPTIMAL STEP SIZE ESTIMATION PARAMETERS. C LET Z[K] DENOTE THE NEWTON ITERATES ALONG THE FLOW NORMAL TO THE C DAVIDENKO FLOW AND Y THEIR LIMIT. C IDEAL CONTRACTION FACTOR: ||Z[2] - Z[1]|| / ||Z[1] - Z[0]|| IF (SSPAR(1) .LE. 0.0) SSPAR(1)= .5 C IDEAL RESIDUAL FACTOR: ||RHO(A, Z[1])|| / ||RHO(A, Z[0])|| IF (SSPAR(2) .LE. 0.0) SSPAR(2)= .01 C IDEAL DISTANCE FACTOR: ||Z[1] - Y|| / ||Z[0] - Y|| IF (SSPAR(3) .LE. 0.0) SSPAR(3)= .5 C MINIMUM STEP SIZE HMIN . IF (SSPAR(4) .LE. 0.0) SSPAR(4)= (SQRT(N+1.0)+4.0)*D1MACH(4) C MAXIMUM STEP SIZE HMAX . IF (SSPAR(5) .LE. 0.0) SSPAR(5)= 1.0 C MINIMUM STEP SIZE REDUCTION FACTOR BMIN . IF (SSPAR(6) .LE. 0.0) SSPAR(6)= .1 C MAXIMUM STEP SIZE EXPANSION FACTOR BMAX . IF (SSPAR(7) .LE. 0.0) SSPAR(7)= 3.0 C ASSUMED OPERATING ORDER P . IF (SSPAR(8) .LE. 0.0) SSPAR(8)= 2.0 C C LOAD A FOR THE FIXED POINT AND ZERO FINDING PROBLEMS. IF (IFLAGC .GE. -1) THEN DO 60 JW=2,NP1 A(JW-1)=Y(JW) 60 CONTINUE ENDIF 90 LIMIT=LIMITD C C ***** END OF INITIALIZATION BLOCK. ***** C C C ***** MAIN LOOP. ***** C 120 DO 400 ITER=1,LIMIT IF (Y(1) .LT. 0.0) THEN ARCLEN=S IFLAG=5 RETURN ENDIF C C SET DIFFERENT ERROR TOLERANCE IF THE TRAJECTORY Y(S) HAS ANY HIGH C CURVATURE COMPONENTS. 140 CURTOL=CURSW*HOLD RELERR=ARCRE ABSERR=ARCAE DO 160 JW=1,NP1 IF (ABS(YP(JW)-YPOLD(JW)) .GT. CURTOL) THEN RELERR=ANSRE ABSERR=ANSAE GO TO 200 ENDIF 160 CONTINUE C C TAKE A STEP ALONG THE CURVE. 200 CALL STEPNF(NC,NFEC,IFLAGC,START,CRASH,HOLD,H,RELERR,ABSERR, + S,Y,YP,YOLD,YPOLD,A,QR,ALPHA,TZ,PIVOT,W,WP,Z0,Z1,SSPAR, + PAR,IPAR) C PRINT LATEST POINT ON CURVE IF REQUESTED. IF (TRACE .GT. 0) THEN WRITE (TRACE,217) ITER,NFEC,S,Y(1),(Y(JW),JW=2,NP1) 217 FORMAT(/' STEP',I5,3X,'NFE =',I5,3X,'ARC LENGTH =',F9.4,3X, $ 'LAMBDA =',F7.4,5X,'X vector:'/1P,(1X,6E12.4)) ENDIF NFE=NFEC C CHECK IF THE STEP WAS SUCCESSFUL. IF (IFLAGC .GT. 0) THEN ARCLEN=S IFLAG=IFLAGC RETURN ENDIF IF (CRASH) THEN C RETURN CODE FOR ERROR TOLERANCE TOO SMALL. IFLAG=2 C CHANGE ERROR TOLERANCES. IF (ARCRE .LT. RELERR) ARCRE=RELERR IF (ANSRE .LT. RELERR) ANSRE=RELERR IF (ARCAE .LT. ABSERR) ARCAE=ABSERR IF (ANSAE .LT. ABSERR) ANSAE=ABSERR C CHANGE LIMIT ON NUMBER OF ITERATIONS. LIMIT=LIMIT-ITER RETURN ENDIF C IF (Y(1) .GE. 1.0) THEN C C USE HERMITE CUBIC INTERPOLATION AND NEWTON ITERATION TO GET THE C ANSWER AT LAMBDA = 1.0 . C C SAVE YOLD FOR ARC LENGTH CALCULATION LATER. DO 260 JW=1,NP1 Z0(JW)=YOLD(JW) 260 CONTINUE CALL ROOTNF(NC,NFEC,IFLAGC,ANSRE,ANSAE,Y,YP,YOLD,YPOLD, $ A,QR,ALPHA,TZ,PIVOT,W,WP,PAR,IPAR) C NFE=NFEC IFLAG=1 C SET ERROR FLAG IF ROOTNF COULD NOT GET THE POINT ON THE ZERO C CURVE AT LAMBDA = 1.0 . IF (IFLAGC .GT. 0) IFLAG=IFLAGC C CALCULATE FINAL ARC LENGTH. DO 290 JW=1,NP1 W(JW)=Y(JW) - Z0(JW) 290 CONTINUE ARCLEN=S - HOLD + DNRM2(NP1,W,1) RETURN ENDIF C C FOR POLYNOMIAL SYSTEMS AND THE POLSYS HOMOTOPY MAP, C D LAMBDA/DS .GE. 0 NECESSARILY. THIS CONDITION IS FORCED HERE IF C THE ENTRY POINT WAS POLYNF . C IF (POLSYS) THEN IF (YP(1) .LT. 0.0) THEN C REVERSE TANGENT DIRECTION SO D LAMBDA/DS = YP(1) > 0 . DO 310 JW=1,NP1 YP(JW)=-YP(JW) YPOLD(JW)=YP(JW) 310 CONTINUE C FORCE STEPNF TO USE THE LINEAR PREDICTOR FOR THE NEXT STEP ONLY. START=.TRUE. ENDIF ENDIF C 400 CONTINUE C C ***** END OF MAIN LOOP. ***** C C LAMBDA HAS NOT REACHED 1 IN 1000 STEPS. IFLAG=3 ARCLEN=S RETURN C END SUBROUTINE FIXPNS(N,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE,A, $ NFE,ARCLEN,YP,YOLD,YPOLD,QR,LENQR,PIVOT,WORK,SSPAR, $ PAR,IPAR) C C SUBROUTINE FIXPNS FINDS A FIXED POINT OR ZERO OF THE C N-DIMENSIONAL VECTOR FUNCTION F(X), OR TRACKS A ZERO CURVE C OF A GENERAL HOMOTOPY MAP RHO(A,X,LAMBDA). FOR THE FIXED C POINT PROBLEM F(X) IS ASSUMED TO BE A C2 MAP OF SOME BALL C INTO ITSELF. THE EQUATION X = F(X) IS SOLVED BY C FOLLOWING THE ZERO CURVE OF THE HOMOTOPY MAP C C LAMBDA*(X - F(X)) + (1 - LAMBDA)*(X - A) , C C STARTING FROM LAMBDA = 0, X = A. THE CURVE IS PARAMETERIZED C BY ARC LENGTH S, AND IS FOLLOWED BY SOLVING THE ORDINARY C DIFFERENTIAL EQUATION D(HOMOTOPY MAP)/DS = 0 FOR C Y(S) = (X(S), LAMBDA(S)) USING A HERMITE CUBIC PREDICTOR AND A C CORRECTOR WHICH RETURNS TO THE ZERO CURVE ALONG THE FLOW NORMAL C TO THE DAVIDENKO FLOW (WHICH CONSISTS OF THE INTEGRAL CURVES OF C D(HOMOTOPY MAP)/DS ). C C FOR THE ZERO FINDING PROBLEM F(X) IS ASSUMED TO BE A C2 MAP C SUCH THAT FOR SOME R > 0, X*F(X) >= 0 WHENEVER NORM(X) = R. C THE EQUATION F(X) = 0 IS SOLVED BY FOLLOWING THE ZERO CURVE C OF THE HOMOTOPY MAP C C LAMBDA*F(X) + (1 - LAMBDA)*(X - A) C C EMANATING FROM LAMBDA = 0, X = A. C C A MUST BE AN INTERIOR POINT OF THE ABOVE MENTIONED BALLS. C C FOR THE CURVE TRACKING PROBLEM RHO(A,X,LAMBDA) IS ASSUMED TO C BE A C2 MAP FROM E**M X E**N X [0,1) INTO E**N, WHICH FOR C ALMOST ALL PARAMETER VECTORS A IN SOME NONEMPTY OPEN SUBSET C OF E**M SATISFIES C C RANK [D RHO(A,X,LAMBDA)/DX , D RHO(A,X,LAMBDA)/D LAMBDA] = N C C FOR ALL POINTS (X,LAMBDA) SUCH THAT RHO(A,X,LAMBDA)=0. IT IS C FURTHER ASSUMED THAT C C RANK [ D RHO(A,X0,0)/DX ] = N . C C WITH A FIXED, THE ZERO CURVE OF RHO(A,X,LAMBDA) EMANATING C FROM LAMBDA = 0, X = X0 IS TRACKED UNTIL LAMBDA = 1 BY C SOLVING THE ORDINARY DIFFERENTIAL EQUATION C D RHO(A,X(S),LAMBDA(S))/DS = 0 FOR Y(S) = (X(S), LAMBDA(S)), C WHERE S IS ARC LENGTH ALONG THE ZERO CURVE. ALSO THE HOMOTOPY C MAP RHO(A,X,LAMBDA) IS ASSUMED TO BE CONSTRUCTED SUCH THAT C C D LAMBDA(0)/DS > 0 . C C C FOR THE FIXED POINT AND ZERO FINDING PROBLEMS, THE USER C MUST SUPPLY A SUBROUTINE F(X,V) WHICH EVALUATES F(X) AT X C AND RETURNS THE VECTOR F(X) IN V, AND A SUBROUTINE C FJACS(X,QR,LENQR,PIVOT) WHICH EVALUATES THE (SYMMETRIC) C JACOBIAN MATRIX OF F(X) AT X, AND RETURNS THE SYMMETRIC C JACOBIAN MATRIX IN PACKED SKYLINE STORAGE FORMAT IN QR. LENQR C AND PIVOT DESCRIBE THE DATA STRUCTURE IN QR. FOR THE CURVE C TRACKING PROBLEM, THE USER MUST SUPPLY A SUBROUTINE C RHO(A,LAMBDA,X,V,PAR,IPAR) WHICH EVALUATES THE HOMOTOPY MAP RHO C AT (A,X,LAMBDA) AND RETURNS THE VECTOR RHO(A,X,LAMBDA) IN V, AND C A SUBROUTINE RHOJS(A,LAMBDA,X,QR,LENQR,PIVOT,PP,PAR,IPAR) WHICH C RETURNS IN QR THE SYMMETRIC N X N JACOBIAN MATRIX [D RHO/DX] C EVALUATED AT (A,X,LAMBDA) AND STORED IN PACKED SKYLINE FORMAT, AND C RETURNS IN PP THE VECTOR -(D RHO/D LAMBDA) EVALUATED AT C (A,X,LAMBDA). LENQR AND PIVOT DESCRIBE THE DATA STRUCTURE C IN QR. C *** NOTE THE MINUS SIGN IN THE DEFINITION OF PP. *** C C C FUNCTIONS AND SUBROUTINES DIRECTLY OR INDIRECTLY CALLED BY FIXPDS: C D1MACH , F (OR RHO ), FJACS (OR RHOJS ), GMFADS , MFACDS , C MULTDS , PCGDS , PCGNS , QIMUDS , ROOT , ROOTNS , SOLVDS , C STEPNS , TANGNS , AND THE BLAS FUNCTIONS DAXPY , DCOPY , DDOT , C DNRM2 , DSCAL , IDAMAX . ONLY D1MACH CONTAINS MACHINE DEPENDENT C CONSTANTS. NO OTHER MODIFICATIONS BY THE USER ARE REQUIRED. C C C ON INPUT: C C N IS THE DIMENSION OF X, F(X), AND RHO(A,X,LAMBDA). C C Y IS AN ARRRAY OF LENGTH N + 1. (Y(1),...,Y(N)) = A IS THE C STARTING POINT FOR THE ZERO CURVE FOR THE FIXED POINT AND C ZERO FINDING PROBLEMS. (Y(1),...,Y(N)) = X0 FOR THE CURVE C TRACKING PROBLEM. C C IFLAG CAN BE -2, -1, 0, 2, OR 3. IFLAG SHOULD BE 0 ON THE C FIRST CALL TO FIXPNS FOR THE PROBLEM X=F(X), -1 FOR THE C PROBLEM F(X)=0, AND -2 FOR THE PROBLEM RHO(A,X,LAMBDA)=0. C IN CERTAIN SITUATIONS IFLAG IS SET TO 2 OR 3 BY FIXPNS, C AND FIXPNS CAN BE CALLED AGAIN WITHOUT CHANGING IFLAG. C C ARCRE , ARCAE ARE THE RELATIVE AND ABSOLUTE ERRORS, RESPECTIVELY, C ALLOWED THE NORMAL FLOW ITERATION ALONG THE ZERO CURVE. IF C ARC?E .LE. 0.0 ON INPUT IT IS RESET TO .5*SQRT(ANS?E) . C NORMALLY ARC?E SHOULD BE CONSIDERABLY LARGER THAN ANS?E . C C ANSRE , ANSAE ARE THE RELATIVE AND ABSOLUTE ERROR VALUES USED FOR C THE ANSWER AT LAMBDA = 1. THE ACCEPTED ANSWER Y = (X, LAMBDA) C SATISFIES C C |Y(NP1) - 1| .LE. ANSRE + ANSAE .AND. C C ||Z|| .LE. ANSRE*||X|| + ANSAE WHERE C C (Z,.) IS THE NEWTON STEP TO Y. C C TRACE IS AN INTEGER SPECIFYING THE LOGICAL I/O UNIT FOR C INTERMEDIATE OUTPUT. IF TRACE .GT. 0 THE POINTS COMPUTED ON C THE ZERO CURVE ARE WRITTEN TO I/O UNIT TRACE . C C A(1:*) CONTAINS THE PARAMETER VECTOR A . FOR THE FIXED POINT C AND ZERO FINDING PROBLEMS, A NEED NOT BE INITIALIZED BY THE C USER, AND IS ASSUMED TO HAVE LENGTH N. FOR THE CURVE C TRACKING PROBLEM, A MUST BE INITIALIZED BY THE USER. C C YP(1:N+1) IS A WORK ARRAY CONTAINING THE TANGENT VECTOR TO C THE ZERO CURVE AT THE CURRENT POINT Y . C C YOLD(1:N+1) IS A WORK ARRAY CONTAINING THE PREVIOUS POINT FOUND C ON THE ZERO CURVE. C C YPOLD(1:N+1) IS A WORK ARRAY CONTAINING THE TANGENT VECTOR TO C THE ZERO CURVE AT YOLD . C C QR(1:LENQR) IS A WORK ARRAY CONTAINING THE N X N SYMMETRIC C JACOBIAN MATRIX WITH RESPECT TO X STORED IN PACKED SKYLINE C STORAGE FORMAT. LENQR AND PIVOT DESCRIBE THE DATA C STRUCTURE IN QR . C C LENQR IS THE LENGTH OF THE ONE-DIMENSIONAL ARRAY QR . C C PIVOT(1:N+2) IS A WORK ARRAY CONTAINING THE INDICES OF THE C DIAGONAL ELEMENTS OF THE N X N SYMMETRIC JACOBIAN MATRIX C (WITH RESPECT TO X) WITHIN QR . C C WORK(1:13*(N+1)+2*N+LENQR) IS A WORK ARRAY SPLIT UP AND USED C FOR THE CALCULATION OF THE JACOBIAN MATRIX KERNEL, THE C NEWTON STEP, INTERPOLATION, AND THE ESTIMATION OF THE OPTIMAL C STEP SIZE H . C C SSPAR(1:8) = (LIDEAL, RIDEAL, DIDEAL, HMIN, HMAX, BMIN, BMAX, P) IS C A VECTOR OF PARAMETERS USED FOR THE OPTIMAL STEP SIZE ESTIMATION. C IF SSPAR(J) .LE. 0.0 ON INPUT, IT IS RESET TO A DEFAULT VALUE C BY FIXPNS . OTHERWISE THE INPUT VALUE OF SSPAR(J) IS USED. C SEE THE COMMENTS BELOW AND IN STEPNS FOR MORE INFORMATION ABOUT C THESE CONSTANTS. C C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS, C WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES C RHO, RHOJS. C C C ON OUTPUT: C C N , TRACE , A ARE UNCHANGED. C C (Y(1),...,Y(N)) = X, Y(NP1) = LAMBDA, AND Y IS AN APPROXIMATE C ZERO OF THE HOMOTOPY MAP. NORMALLY LAMBDA = 1 AND X IS A C FIXED POINT(ZERO) OF F(X). IN ABNORMAL SITUATIONS LAMBDA C MAY ONLY BE NEAR 1 AND X IS NEAR A FIXED POINT(ZERO). C C IFLAG = C -2 CAUSES FIXPNS TO INITIALIZE EVERYTHING FOR THE PROBLEM C RHO(A,X,LAMBDA) = 0 (USE ON FIRST CALL). C C -1 CAUSES FIXPNS TO INITIALIZE EVERYTHING FOR THE PROBLEM C F(X) = 0 (USE ON FIRST CALL). C C 0 CAUSES FIXPNS TO INITIALIZE EVERYTHING FOR THE PROBLEM C X = F(X) (USE ON FIRST CALL). C C 1 NORMAL RETURN. C C 2 SPECIFIED ERROR TOLERANCE CANNOT BE MET. SOME OR ALL OF C ARCRE , ARCAE , ANSRE , ANSAE HAVE BEEN INCREASED TO C SUITABLE VALUES. TO CONTINUE, JUST CALL FIXPNS AGAIN C WITHOUT CHANGING ANY PARAMETERS. C C 3 STEPNS HAS BEEN CALLED 1000 TIMES. TO CONTINUE, CALL C FIXPNS AGAIN WITHOUT CHANGING ANY PARAMETERS. C C 4 THE PRECONDITIONED CONJUGATE GRADIENT ITERATION FAILED TO C CONVERGE (PROBABLY BECAUSE THE JACOBIAN MATRIX DID NOT HAVE C FULL RANK). THE ALGORITHM HAS FAILED (THE ZERO CURVE OF C THE HOMOTOPY MAP CANNOT BE FOLLOWED ANY FURTHER). C C 5 THE TRACKING ALGORITHM HAS LOST THE ZERO CURVE OF THE C HOMOTOPY MAP AND IS NOT MAKING PROGRESS. THE ERROR TOLERANCES C ARC?E AND ANS?E WERE TOO LENIENT. THE PROBLEM SHOULD BE C RESTARTED BY CALLING FIXPNS WITH SMALLER ERROR TOLERANCES C AND IFLAG = 0 (-1, -2). C C 6 THE NORMAL FLOW NEWTON ITERATION IN STEPNS OR ROOTNS C FAILED TO CONVERGE. THE ERROR TOLERANCES ANS?E MAY BE TOO C STRINGENT. C C 7 ILLEGAL INPUT PARAMETERS, A FATAL ERROR. C C ARCRE , ARCAE , ANSRE , ANSAE ARE UNCHANGED AFTER A NORMAL RETURN C (IFLAG = 1). THEY ARE INCREASED TO APPROPRIATE VALUES ON THE C RETURN IFLAG = 2 . C C NFE IS THE NUMBER OF FUNCTION EVALUATIONS (= NUMBER OF C JACOBIAN EVALUATIONS). C C ARCLEN IS THE LENGTH OF THE PATH FOLLOWED. C C C DOUBLE PRECISION ABSERR,ANSAE,ANSRE,ARCAE,ARCLEN,ARCRE, 1 CURSW,CURTOL,D1MACH,DNRM2,H,HOLD,RELERR,S INTEGER IFLAG,IFLAGC,IPP,IRHO,ITANGW,ITER,ITZ,IW,IWP, 1 IZ0,IZ1,JW,LENQR,LIMIT,LIMITD,N,NC,NFE,NFEC,NP1,TRACE LOGICAL START,CRASH C C ***** ARRAY DECLARATIONS. ***** C DOUBLE PRECISION Y(N+1),YP(N+1),YOLD(N+1),YPOLD(N+1),A(N), $ QR(LENQR),WORK(13*(N+1)+2*N+LENQR),SSPAR(8),PAR(1) INTEGER PIVOT(N+2),IPAR(1) C C ***** END OF DIMENSIONAL INFORMATION. ***** C SAVE C C LIMITD IS AN UPPER BOUND ON THE NUMBER OF STEPS. IT MAY BE C CHANGED BY CHANGING THE FOLLOWING PARAMETER STATEMENT: PARAMETER (LIMITD=1000) C C SWITCH FROM THE TOLERANCE ARC?E TO THE (FINER) TOLERANCE ANS?E IF C THE CURVATURE OF ANY COMPONENT OF Y EXCEEDS CURSW. PARAMETER (CURSW=10.0) C C C C : : : : : : : : : : : : : : : : : : : : : : : : IF (N .LE. 0 .OR. ANSRE .LE. 0.0 .OR. ANSAE .LT. 0.0) $ IFLAG=7 IF (IFLAG .GE. -2 .AND. IFLAG .LE. 0) GO TO 20 IF (IFLAG .EQ. 2) GO TO 120 IF (IFLAG .EQ. 3) GO TO 90 C ONLY VALID INPUT FOR IFLAG IS -2, -1, 0, 2, 3. IFLAG=7 RETURN C C ***** INITIALIZATION BLOCK. ***** C 20 ARCLEN=0.0 IF (ARCRE .LE. 0.0) ARCRE=.5*SQRT(ANSRE) IF (ARCAE .LE. 0.0) ARCAE=.5*SQRT(ANSAE) NC=N NFEC=0 IFLAGC=IFLAG NP1=N+1 C SET INDICES FOR SPLITTING UP WORK ARRAY. IPP=1 IRHO=N+1 IW=IRHO+N IWP=IW+NP1 ITZ=IWP+NP1 IZ0=ITZ+NP1 IZ1=IZ0+NP1 ITANGW=IZ1+NP1 C SET INITIAL CONDITIONS FOR FIRST CALL TO STEPNS . START=.TRUE. CRASH=.FALSE. HOLD=1.0 H=.1 S=0.0 YPOLD(NP1)=1.0 YP(NP1)=1.0 Y(NP1)=0.0 DO 40 JW=1,N YPOLD(JW)=0.0 YP(JW)=0.0 40 CONTINUE DO 50 JW=ITANGW,ITANGW+NP1+N WORK(JW)=0.0 50 CONTINUE C SET OPTIMAL STEP SIZE ESTIMATION PARAMETERS. C LET Z[K] DENOTE THE NEWTON ITERATES ALONG THE FLOW NORMAL TO THE C DAVIDENKO FLOW AND Y THEIR LIMIT. C IDEAL CONTRACTION FACTOR: ||Z[2] - Z[1]|| / ||Z[1] - Z[0]|| IF (SSPAR(1) .LE. 0.0) SSPAR(1)= .5 C IDEAL RESIDUAL FACTOR: ||RHO(A, Z[1])|| / ||RHO(A, Z[0])|| IF (SSPAR(2) .LE. 0.0) SSPAR(2)= .01 C IDEAL DISTANCE FACTOR: ||Z[1] - Y|| / ||Z[0] - Y|| IF (SSPAR(3) .LE. 0.0) SSPAR(3)= .5 C MINIMUM STEP SIZE HMIN . IF (SSPAR(4) .LE. 0.0) SSPAR(4)= (SQRT(N+1.0)+4.0)*D1MACH(4) C MAXIMUM STEP SIZE HMAX . IF (SSPAR(5) .LE. 0.0) SSPAR(5)= 1.0 C MINIMUM STEP SIZE REDUCTION FACTOR BMIN . IF (SSPAR(6) .LE. 0.0) SSPAR(6)= .1 C MAXIMUM STEP SIZE EXPANSION FACTOR BMAX . IF (SSPAR(7) .LE. 0.0) SSPAR(7)= 3.0 C ASSUMED OPERATING ORDER P . IF (SSPAR(8) .LE. 0.0) SSPAR(8)= 2.0 C C LOAD A FOR THE FIXED POINT AND ZERO FINDING PROBLEMS. IF (IFLAGC .GE. -1) THEN CALL DCOPY(N,Y,1,A,1) ENDIF 90 LIMIT=LIMITD C C ***** END OF INITIALIZATION BLOCK. ***** C C C ***** MAIN LOOP. ***** C 120 DO 400 ITER=1,LIMIT IF (Y(NP1) .LT. 0.0) THEN ARCLEN=S IFLAG=5 RETURN ENDIF C C SET DIFFERENT ERROR TOLERANCE IF THE TRAJECTORY Y(S) HAS ANY HIGH C CURVATURE COMPONENTS. 140 CURTOL=CURSW*HOLD RELERR=ARCRE ABSERR=ARCAE DO 160 JW=1,NP1 IF (ABS(YP(JW)-YPOLD(JW)) .GT. CURTOL) THEN RELERR=ANSRE ABSERR=ANSAE GO TO 200 ENDIF 160 CONTINUE C C TAKE A STEP ALONG THE CURVE. 200 CALL STEPNS(NC,NFEC,IFLAGC,START,CRASH,HOLD,H,RELERR,ABSERR, + S,Y,YP,YOLD,YPOLD,A,QR,LENQR,PIVOT,WORK,SSPAR,PAR,IPAR) C PRINT LATEST POINT ON CURVE IF REQUESTED. IF (TRACE .GT. 0) THEN WRITE (TRACE,217) ITER,NFEC,S,Y(NP1),(Y(JW),JW=1,NC) 217 FORMAT(/' STEP',I5,3X,'NFE =',I5,3X,'ARC LENGTH =',F9.4,3X, $ 'LAMBDA =',F7.4,5X,'X vector:'/1P,(1X,6E12.4)) ENDIF NFE=NFEC C CHECK IF THE STEP WAS SUCCESSFUL. IF (IFLAGC .GT. 0) THEN ARCLEN=S IFLAG=IFLAGC RETURN ENDIF IF (CRASH) THEN C RETURN CODE FOR ERROR TOLERANCE TOO SMALL. IFLAG=2 C CHANGE ERROR TOLERANCES. IF (ARCRE .LT. RELERR) ARCRE=RELERR IF (ANSRE .LT. RELERR) ANSRE=RELERR IF (ARCAE .LT. ABSERR) ARCAE=ABSERR IF (ANSAE .LT. ABSERR) ANSAE=ABSERR C CHANGE LIMIT ON NUMBER OF ITERATIONS. LIMIT=LIMIT-ITER RETURN ENDIF C IF (Y(NP1) .GE. 1.0) THEN C C USE HERMITE CUBIC INTERPOLATION AND NEWTON ITERATION TO GET THE C ANSWER AT LAMBDA = 1.0 . C C SAVE YOLD FOR ARC LENGTH CALCULATION LATER. CALL DCOPY(NP1,YOLD,1,WORK(IZ0),1) C CALL ROOTNS(NC,NFEC,IFLAGC,ANSRE,ANSAE,Y,YP,YOLD,YPOLD, $ A,QR,LENQR,PIVOT,WORK,PAR,IPAR) C NFE=NFEC IFLAG=1 C SET ERROR FLAG IF ROOTNS COULD NOT GET THE POINT ON THE ZERO C CURVE AT LAMBDA = 1.0 . IF (IFLAGC .GT. 0) IFLAG=IFLAGC C CALCULATE FINAL ARC LENGTH. DO 290 JW=1,NP1 WORK(JW)=Y(JW) - WORK(IZ0+JW-1) 290 CONTINUE ARCLEN=S - HOLD + DNRM2(NP1,WORK,1) RETURN ENDIF C 400 CONTINUE C C ***** END OF MAIN LOOP. ***** C C LAMBDA HAS NOT REACHED 1 IN 1000 STEPS. IFLAG=3 ARCLEN=S RETURN C C END SUBROUTINE FIXPQF(N,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE,A, $ NFE,ARCLEN,YP,YOLD,YPOLD,QT,R,F0,F1,Z0,DZ,W,T,YSAV, $ SSPAR,PAR,IPAR) C C SUBROUTINE FIXPQF FINDS A FIXED POINT OR ZERO OF THE C N-DIMENSIONAL VECTOR FUNCTION F(X), OR TRACKS A ZERO CURVE OF A C GENERAL HOMOTOPY MAP RHO(A,LAMBDA,X). FOR THE FIXED POINT PROBLEM C F(X) IS ASSUMED TO BE A C2 MAP OF SOME BALL INTO ITSELF. THE C EQUATION X=F(X) IS SOLVED BY FOLLOWING THE ZERO CURVE OF THE C HOMOTOPY MAP C C LAMBDA*(X - F(X)) + (1 - LAMBDA)*(X - A), C C STARTING FROM LAMBDA = 0, X = A. THE CURVE IS PARAMETERIZED C BY ARC LENGTH S, AND IS FOLLOWED BY SOLVING THE ORDINARY C DIFFERENTIAL EQUATION D(HOMOTOPY MAP)/DS = 0 FOR C Y(S) = (LAMBDA(S), X(S)). THIS IS DONE BY USING A HERMITE CUBIC C PREDICTOR AND A CORRECTOR WHICH RETURNS TO THE ZERO CURVE IN A C HYPERPLANE PERPENDICULAR TO THE TANGENT TO THE ZERO CURVE AT THE C MOST RECENT POINT. C C FOR THE ZERO FINDING PROBLEM F(X) IS ASSUMED TO BE A C2 MAP C SUCH THAT FOR SOME R > 0, X*F(X) >= 0 WHENEVER NORM(X) = R. C THE EQUATION F(X) = 0 IS SOLVED BY FOLLOWING THE ZERO CURVE OF C THE HOMOTOPY MAP C C LAMBDA*F(X) + (1 - LAMBDA)*(X - A) C C EMANATING FROM LAMBDA = 0, X = A. C C A MUST BE AN INTERIOR POINT OF THE ABOVE MENTIONED BALLS. C C FOR THE CURVE TRACKING PROBLEM RHO(A,LAMBDA,X) IS ASSUMED TO C BE A C2 MAP FROM E**M X [0,1) X E**N INTO E**N, WHICH FOR C ALMOST ALL PARAMETER VECTORS A IN SOME NONEMPTY OPEN SUBSET C OF E**M SATISFIES C C RANK [D RHO(A,LAMBDA,X)/D LAMBDA, D RHO(A,LAMBDA,X)/DX] = N C C FOR ALL POINTS (LAMBDA,X) SUCH THAT RHO(A,LAMBDA,X) = 0. IT IS C FURTHER ASSUMED THAT C C RANK [ D RHO(A,0,X0)/DX ] = N. C C WITH A FIXED, THE ZERO CURVE OF RHO(A,LAMBDA,X) EMANATING FROM C LAMBDA = 0, X = X0 IS TRACKED UNTIL LAMBDA = 1 BY SOLVING THE C ORDINARY DIFFERENTIAL EQUATION D RHO(A,LAMBDA(S),X(S))/DS = 0 C FOR Y(S) = (LAMBDA(S), X(S)), WHERE S IS ARC LENGTH ALONG THE C ZERO CURVE. ALSO THE HOMOTOPY MAP RHO(A,LAMBDA,X) IS ASSUMED TO C BE CONSTRUCTED SUCH THAT C C D LAMBDA(0)/DS > 0. C C FOR THE FIXED POINT AND ZERO FINDING PROBLEMS, THE USER MUST SUPPLY C A SUBROUTINE F(X,V) WHICH EVALUATES F(X) AT X AND RETURNS THE C VECTOR F(X) IN V, AND A SUBROUTINE FJAC(X,V,K) WHICH RETURNS IN V C THE KTH COLUMN OF THE JACOBIAN MATRIX OF F(X) EVALUATED AT X. FOR C THE CURVE TRACKING PROBLEM, THE USER MUST SUPPLY A SUBROUTINE C RHO(A,LAMBDA,X,V,PAR,IPAR) WHICH EVALUATES THE HOMOTOPY MAP RHO AT C (A,LAMBDA,X) AND RETURNS THE VECTOR RHO(A,LAMBDA,X) IN V, AND C A SUBROUTINE RHOJAC(A,LAMBDA,X,V,K,PAR,IPAR) WHICH RETURNS IN V C THE KTH COLUMN OF THE N X (N+1) JACOBIAN MATRIX C [D RHO/D LAMBDA, D RHO/DX] EVALUATED AT (A,LAMBDA,X). FIXPQF C DIRECTLY OR INDIRECTLY USES THE SUBROUTINES D1MACH, F (OR RHO), C FJAC (OR RHOJAC), QRFAQF, QRSLQF, ROOT, ROOTQF, STEPQF, TANGQF, C UPQRQF AND THE BLAS ROUTINES DAXPY, DCOPY, DDOT, DNRM2, AND DSCAL. C ONLY D1MACH CONTAINS MACHINE DEPENDENT CONSTANTS. NO OTHER C MODIFICATIONS BY THE USER ARE REQUIRED. C C C ON INPUT: C C N IS THE DIMENSION OF X, F(X), AND RHO(A,LAMBDA,X). C C Y(1:N+1) CONTAINS THE STARTING POINT FOR TRACKING THE HOMOTOPY MAP. C (Y(2),...,Y(N+1)) = A FOR THE FIXED POINT AND ZERO FINDING C PROBLEMS. (Y(2),...,Y(N+1)) = X0 FOR THE CURVE TRACKING PROBLEM. C Y(1) NEED NOT BE DEFINED BY THE USER. C C IFLAG CAN BE -2, -1, 0, 2, OR 3. IFLAG SHOULD BE 0 ON THE FIRST C CALL TO FIXPQF FOR THE PROBLEM X=F(X), -1 FOR THE PROBLEM C F(X)=0, AND -2 FOR THE PROBLEM RHO(A,LAMBDA,X)=0. IN CERTAIN C SITUATIONS IFLAG IS SET TO 2 OR 3 BY FIXPQF, AND FIXPQF CAN C BE CALLED AGAIN WITHOUT CHANGING IFLAG. C C ARCRE, ARCAE ARE THE RELATIVE AND ABSOLUTE ERRORS, RESPECTIVELY, C ALLOWED THE QUASI-NEWTON ITERATION ALONG THE ZERO CURVE. IF C ARC?E .LE. 0.0 ON INPUT, IT IS RESET TO .5*SQRT(ANS?E). C NORMALLY ARC?E SHOULD BE CONSIDERABLY LARGER THAN ANS?E. C C ANSRE, ANSAE ARE THE RELATIVE AND ABSOLUTE ERROR VALUES USED FOR C THE ANSWER AT LAMBDA = 1. THE ACCEPTED ANSWER Y = (LAMBDA, X) C SATISFIES C C |Y(1) - 1| .LE. ANSRE + ANSAE .AND. C C ||DZ|| .LE. ANSRE*||Y|| + ANSAE WHERE C C DZ IS THE QUASI-NEWTON STEP TO Y. C C TRACE IS AN INTEGER SPECIFYING THE LOGICAL I/O UNIT FOR C INTERMEDIATE OUTPUT. IF TRACE .GT. 0 THE POINTS COMPUTED ON C THE ZERO CURVE ARE WRITTEN TO I/O UNIT TRACE . C C A(1:*) CONTAINS THE PARAMETER VECTOR A. FOR THE FIXED POINT C AND ZERO FINDING PROBLEMS, A NEED NOT BE INITIALIZED BY THE C USER, AND IS ASSUMED TO HAVE LENGTH N. FOR THE CURVE C TRACKING PROBLEM, A MUST BE INITIALIZED BY THE USER. C C YP(1:N+1) IS A WORK ARRAY CONTAINING THE TANGENT VECTOR TO THE C ZERO CURVE AT THE CURRENT POINT Y. C C YOLD(1:N+1) IS A WORK ARRAY CONTAINING THE PREVIOUS POINT FOUND C ON THE ZERO CURVE. C C YPOLD(1:N+1) IS A WORK ARRAY CONTAINING THE TANGENT VECTOR TO C THE ZERO CURVE AT YOLD. C C QT(1:N+1,1:N+1), R((N+1)*(N+2)/2), F0(1:N+1), F1(1:N+1), Z0(1:N+1), C DZ(1:N+1), W(1:N+1), T(1:N+1), YSAV(1:N+1) ARE ALL WORK ARRAYS C USED BY STEPQF, TANGQF AND ROOTQF TO CALCULATE THE TANGENT C VECTORS AND QUASI-NEWTON STEPS. C C SSPAR(1:4) = (HMIN, HMAX, BMIN, BMAX) IS A VECTOR OF PARAMETERS C USED FOR THE OPTIMAL STEP SIZE ESTIMATION. A DEFAULT VALUE C CAN BE SPECIFIED FOR ANY OF THESE FOUR PARAMETERS BY SETTING IT C .LE. 0.0 ON INPUT. SEE THE COMMENTS IN STEPQF FOR MORE C INFORMATION ABOUT THESE PARAMETERS. C C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS, C WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES C RHO, RHOJAC. C C C ON OUTPUT: C C N , TRACE , A ARE UNCHANGED. C C Y(1) = LAMBDA, (Y(2),...,Y(N+1)) = X, AND Y IS AN APPROXIMATE C ZERO OF THE HOMOTOPY MAP. NORMALLY LAMBDA = 1 AND X IS A C FIXED POINT OR ZERO OF F(X). IN ABNORMAL SITUATIONS, LAMBDA C MAY ONLY BE NEAR 1 AND X NEAR A FIXED POINT OR ZERO. C C IFLAG = C C 1 NORMAL RETURN C C 2 SPECIFIED ERROR TOLERANCE CANNOT BE MET. SOME OR ALL OF C ARCRE, ARCAE, ANSRE, ANSAE HAVE BEEN INCREASED TO C SUITABLE VALUES. TO CONTINUE, JUST CALL FIXPQF AGAIN C WITHOUT CHANGING ANY PARAMETERS. C C 3 STEPQF HAS BEEN CALLED 1000 TIMES. TO CONTINUE, CALL C FIXPQF AGAIN WITHOUT CHANGING ANY PARAMETERS. C C 4 JACOBIAN MATRIX DOES NOT HAVE FULL RANK. THE ALGORITHM C HAS FAILED (THE ZERO CURVE OF THE HOMOTOPY MAP CANNOT BE C FOLLOWED ANY FURTHER). C C 5 THE TRACKING ALGORITHM HAS LOST THE ZERO CURVE OF THE C HOMOTOPY MAP AND IS NOT MAKING PROGRESS. THE ERROR C TOLERANCES ARC?E AND ANS?E WERE TOO LENIENT. THE PROBLEM C SHOULD BE RESTRARTED BY CALLING FIXPQF WITH SMALLER ERROR C TOLERANCES AND IFLAG = 0 (-1, -2). C C 6 THE QUASI-NEWTON ITERATION IN STEPQF OR ROOTQF FAILED TO C CONVERGE. THE ERROR TOLERANCES ANS?E MAY BE TOO STRINGENT. C C 7 ILLEGAL INPUT PARAMETERS, A FATAL ERROR. C C ARCRE, ARCAE, ANSRE, ANSAE ARE UNCHANGED AFTER A NORMAL RETURN C (IFLAG = 1). THEY ARE INCREASED TO APPROPRIATE VALUES ON THE C RETURN IFLAG = 2. C C NFE IS THE NUMBER OF JACOBIAN EVALUATIONS. C C ARCLEN IS THE APPROXIMATE LENGTH OF THE ZERO CURVE. C C ***** DECLARATIONS ***** C C FUNCTION DECLARATIONS C DOUBLE PRECISION D1MACH, DNRM2 C C LOCAL VARIABLES C DOUBLE PRECISION ABSERR, H, HOLD, RELERR, S, WK INTEGER IFLAGC, ITER, JW, LIMITD, LIMIT, NP1 LOGICAL CRASH, START C C SCALAR ARGUMENTS C DOUBLE PRECISION ARCRE, ARCAE, ANSRE, ANSAE, ARCLEN INTEGER N,IFLAG,TRACE,NFE C C ARRAY DECLARATIONS C DOUBLE PRECISION A(N), Y(N+1), YP(N+1), YOLD(N+1), YPOLD(N+1), $ QT(N+1,N+1), R((N+1)*(N+2)/2), F0(N+1), F1(N+1), Z0(N+1), $ DZ(N+1), W(N+1), T(N+1), YSAV(N+1), SSPAR(4), PAR(1) INTEGER IPAR(1) C SAVE C C ***** END OF DECLARATIONS ***** C C LIMITD IS AN UPPER BOUND ON THE NUMBER OF STEPS. IT MAY BE C CHANGED BY CHANGING THE FOLLOWING PARAMETER STATEMENT: PARAMETER (LIMITD =1000) C C ***** FIRST EXECUTABLE STATEMENT ***** C C CHECK IFLAG C IF (N .LE. 0 .OR. ANSRE .LE. 0.0 .OR. ANSAE .LT. 0.0) $ IFLAG = 7 IF (IFLAG .GE. -2 .AND. IFLAG .LE. 0) GO TO 10 IF (IFLAG .EQ. 2) GO TO 50 IF (IFLAG .EQ. 3) GO TO 40 C C ONLY VALID INPUT FOR IFLAG IS -2, -1, 0, 2, 3. C IFLAG = 7 RETURN C C ***** INITIALIZATION BLOCK ***** C 10 ARCLEN = 0.0 IF (ARCRE .LE. 0.0) ARCRE = .5*SQRT(ANSRE) IF (ARCAE .LE. 0.0) ARCAE = .5*SQRT(ANSAE) NFE=0 IFLAGC = IFLAG NP1=N+1 C C SET INITIAL CONDITIONS FOR FIRST CALL TO STEPQF. C START=.TRUE. CRASH=.FALSE. RELERR = ARCRE ABSERR = ARCAE HOLD=1.0 H=0.1 S=0.0 YPOLD(1) = 1.0 Y(1) = 0.0 DO 20 JW=2,NP1 YPOLD(JW)=0.0 20 CONTINUE C C SET OPTIMAL STEP SIZE ESTIMATION PARAMETERS. C C MINIMUM STEP SIZE HMIN IF (SSPAR(1) .LE. 0.0) SSPAR(1)= (SQRT(N+1.0)+4.0)*D1MACH(4) C MAXIMUM STEP SIZE HMAX IF (SSPAR(2) .LE. 0.0) SSPAR(2)= 1.0 C MINIMUM STEP REDUCTION FACTOR BMIN IF (SSPAR(3) .LE. 0.0) SSPAR(3)= 0.1 C MAXIMUM STEP EXPANSION FACTOR BMAX IF (SSPAR(4) .LE. 0.0) SSPAR(4)= 7.0 C C LOAD A FOR THE FIXED POINT AND ZERO FINDING PROBLEMS. C IF (IFLAGC .GE. -1) THEN CALL DCOPY(N,Y(2),1,A,1) ENDIF C 40 LIMIT=LIMITD C C ***** END OF INITIALIZATION BLOCK. ***** C C ***** MAIN LOOP. ***** C 50 DO 400 ITER=1,LIMIT IF (Y(1) .LT. 0.0) THEN ARCLEN = S IFLAG = 5 RETURN END IF C C TAKE A STEP ALONG THE CURVE. C CALL STEPQF(N,NFE,IFLAGC,START,CRASH,HOLD,H,WK, $ RELERR,ABSERR,S,Y,YP,YOLD,YPOLD,A,QT,R,F0,F1,Z0,DZ, $ W,T,SSPAR,PAR,IPAR) C C PRINT LATEST POINT ON CURVE IF REQUESTED. C IF (TRACE .GT. 0) THEN WRITE (TRACE,217) ITER,NFE,S,Y(1),(Y(JW),JW=2,NP1) 217 FORMAT(/' STEP',I5,3X,'NFE =',I5,3X,'ARC LENGTH =',F9.4,3X, $ 'LAMBDA =',F7.4,5X,'X vector:'/1P,(1X,6E12.4)) ENDIF C C CHECK IF THE STEP WAS SUCCESSFUL. C IF (IFLAGC .GT. 0) THEN ARCLEN=S IFLAG=IFLAGC RETURN END IF C IF (CRASH) THEN C C RETURN CODE FOR ERROR TOLERANCE TOO SMALL. C IFLAG=2 C C CHANGE ERROR TOLERANCES. C IF (ARCRE .LT. RELERR) THEN ARCRE=RELERR ANSRE=RELERR END IF IF (ARCAE .LT. ABSERR) ARCAE=ABSERR C C CHANGE LIMIT ON NUMBER OF ITERATIONS. C LIMIT = LIMIT - ITER RETURN END IF C C IF LAMBDA >= 1.0, USE ROOTQF TO FIND SOLUTION. C IF (Y(1) .GE. 1.0) GOTO 500 C 400 CONTINUE C C ***** END OF MAIN LOOP ***** C C DID NOT CONVERGE IN LIMIT ITERATIONS, SET IFLAG AND RETURN. C ARCLEN = S IFLAG = 3 RETURN C C ***** FINAL STEP -- FIND SOLUTION AT LAMBDA=1 ***** C C SAVE YOLD FOR ARC LENGTH CALCULATION LATER. C 500 CALL DCOPY(NP1,YOLD,1,YSAV,1) C C FIND SOLUTION. C CALL ROOTQF(N,NFE,IFLAGC,ANSRE,ANSAE,Y,YP,YOLD, $ YPOLD,A,QT,R,DZ,Z0,W,T,F0,F1,PAR,IPAR) C C CHECK IF SOLUTION WAS FOUND AND SET IFLAG ACCORDINGLY. C IFLAG=1 C C SET ERROR FLAG IF ROOTQF COULD NOT GET THE POINT ON THE ZERO C CURVE AT LAMBDA = 1.0. C IF (IFLAGC .GT. 0) IFLAG=IFLAGC C C CALCULATE FINAL ARC LENGTH. C CALL DCOPY(NP1,Y,1,DZ,1) WK=-1.0 CALL DAXPY(NP1,WK,YSAV,1,DZ,1) ARCLEN = S - HOLD + DNRM2(NP1,DZ,1) C C ***** END OF FINAL STEP ***** C RETURN C C ***** END OF SUBROUTINE FIXPQF ***** END SUBROUTINE FIXPQS(N,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE, $ A,NFE,ARCLEN,YP,YOLD,YPOLD,QR,LENQR,PIVOT,PP,RHOVEC,Z0,DZ, $ T,WORK,SSPAR,PAR,IPAR) C C SUBROUTINE FIXPQS FINDS A FIXED POINT OR ZERO OF THE C N-DIMENSIONAL VECTOR FUNCTION F(X), OR TRACKS A ZERO CURVE OF A C GENERAL HOMOTOPY MAP RHO(A,X,LAMBDA). FOR THE FIXED POINT PROBLEM C F(X) IS ASSUMED TO BE A C2 MAP OF SOME BALL INTO ITSELF. THE C EQUATION X=F(X) IS SOLVED BY FOLLOWING THE ZERO CURVE OF THE C HOMOTOPY MAP C C LAMBDA*(X - F(X)) + (1 - LAMBDA)*(X - A), C C STARTING FROM LAMBDA = 0, X = A. THE CURVE IS PARAMETERIZED C BY ARC LENGTH S, AND IS FOLLOWED BY SOLVING THE ORDINARY C DIFFERENTIAL EQUATION D(HOMOTOPY MAP)/DS = 0 FOR C Y(S) = (X(S),LAMBDA(S)). THIS IS DONE BY USING A HERMITE CUBIC C PREDICTOR AND A CORRECTOR WHICH RETURNS TO THE ZERO CURVE IN A C HYPERPLANE PERPENDICULAR TO THE TANGENT TO THE ZERO CURVE AT THE C MOST RECENT POINT. C C FOR THE ZERO FINDING PROBLEM F(X) IS ASSUMED TO BE A C2 MAP SUCH C THAT FOR SOME R > 0, X*F(X) >= 0 WHENEVER NORM(X) = R. C THE EQUATION F(X) = 0 IS SOLVED BY FOLLOWING THE ZERO CURVE OF C THE HOMOTOPY MAP C C LAMBDA*F(X) + (1 - LAMBDA)*(X - A) C C EMANATING FROM LAMBDA = 0, X = A. C C A MUST BE AN INTERIOR POINT OF THE ABOVE MENTIONED BALLS. C C FOR THE CURVE TRACKING PROBLEM RHO(A,X,LAMBDA) IS ASSUMED TO C BE A C2 MAP FROM E**M X [0,1) X E**N INTO E**N, WHICH FOR C ALMOST ALL PARAMETER VECTORS A IN SOME NONEMPTY OPEN SUBSET C OF E**M SATISFIES C C RANK [D RHO(A,X,LAMBDA)/D LAMBDA, D RHO(A,X,LAMBDA)/DX] = N C C FOR ALL POINTS (X,LAMBDA) SUCH THAT RHO(A,X,LAMBDA) = 0. IT IS C FURTHER ASSUMED THAT C C RANK [ D RHO(A,X0,0)/DX ] = N. C C WITH A FIXED, THE ZERO CURVE OF RHO(A,X,LAMBDA) EMANATING FROM C LAMBDA = 0, X = X0 IS TRACKED UNTIL LAMBDA = 1 BY SOLVING THE C ORDINARY DIFFERENTIAL EQUATION D RHO(A,X(S),LAMBDA(S))/DS = 0 C FOR Y(S) = (X(S),LAMBDA(S)), WHERE S IS ARC LENGTH ALONG THE C ZERO CURVE. ALSO THE HOMOTOPY MAP RHO(A,X,LAMBDA) IS ASSUMED TO C BE CONSTRUCTED SUCH THAT C C D LAMBDA(0)/DS > 0. C C FOR THE FIXED POINT AND ZERO FINDING PROBLEMS, THE USER MUST SUPPLY C A SUBROUTINE F(X,V) WHICH EVALUATES F(X) AT X AND RETURNS THE C VECTOR F(X) IN V, AND A SUBROUTINE FJACS(X,QR,LENQR,PIVOT) WHICH C EVALUATES THE (SYMMETRIC) JACOBIAN MATRIX OF F(X) AT X, AND RETURNS C THE SYMMETRIC JACOBIAN MATRIX IN PACKED SKYLINE STORAGE FORMAT IN QR. C LENQR AND PIVOT DESCRIBE THE DATA STRUCTURE IN QR. FOR THE CURVE C TRACKING PROBLEM, THE USER MUST SUPPLY A SUBROUTINE C RHO(A,LAMBDA,X,V,PAR,IPAR) WHICH EVALUATES THE HOMOTOPY MAP RHO C AT (A,X,LAMBDA) AND RETURNS THE VECTOR RHO(A,X,LAMBDA) IN V, C AND A SUBROUTINE RHOJS(A,LAMBDA,X,QR,LENQR,PIVOT,PP,PAR,IPAR) WHICH C RETURNS IN QR THE SYMMETRIC N X N JACOBIAN MATRIX [D RHO/DX] C EVALUATED AT (A,X,LAMBDA) AND STORED IN PACKED SKYLINE FORMAT, C AND RETURNS IN PP THE VECTOR -(D RHO/D LAMBDA) EVALUATED AT C (A,X,LAMBDA). LENQR AND PIVOT DESCRIBE THE DATA STRUCTURE IN C QR. C *** NOTE THE MINUS SIGN IN THE DEFINITION OF PP. *** C C C FIXPQS DIRECTLY OR INDIRECTLY USES THE SUBROUTINES D1MACH, F C (OR RHO), FJACS (OR RHOJS), GMFADS, MULTDS, PCGQS, ROOTQS, STEPQS, C SOLVDS, AND THE BLAS ROUTINES DAXPY, DCOPY, DDOT, DNRM2, AND DSCAL. C ONLY D1MACH CONTAINS MACHINE DEPENDENT CONSTANTS. NO OTHER C MODIFICATIONS BY THE USER ARE REQUIRED. C C C ON INPUT: C C N IS THE DIMENSION OF X, F(X), AND RHO(A,X,LAMBDA). C C Y(1:N+1) CONTAINS THE STARTING POINT FOR TRACKING THE HOMOTOPY MAP. C (Y(1),...,Y(N)) = A FOR THE FIXED POINT AND ZERO FINDING C PROBLEMS. (Y(1),...,Y(N)) = X0 FOR THE CURVE TRACKING PROBLEM. C Y(N+1) NEED NOT BE DEFINED BY THE USER. C C IFLAG CAN BE -2, -1, 0, 2, OR 3. IFLAG SHOULD BE 0 ON THE FIRST C CALL TO FIXPQS FOR THE PROBLEM X=F(X), -1 FOR THE PROBLEM C F(X)=0, AND -2 FOR THE PROBLEM RHO(A,X,LAMBDA)=0. IN CERTAIN C SITUATIONS IFLAG IS SET TO 2 OR 3 BY FIXPQS, AND FIXPQS CAN C BE CALLED AGAIN WITHOUT CHANGING IFLAG. C C ARCRE, ARCAE ARE THE RELATIVE AND ABSOLUTE ERRORS, RESPECTIVELY, C ALLOWED THE ITERATION ALONG THE ZERO CURVE. IF C ARC?E .LE. 0.0 ON INPUT, IT IS RESET TO .5*SQRT(ANS?E). C NORMALLY ARC?E SHOULD BE CONSIDERABLY LARGER THAN ANS?E. C C ANSRE, ANSAE ARE THE RELATIVE AND ABSOLUTE ERROR VALUES USED FOR C THE ANSWER AT LAMBDA = 1. THE ACCEPTED ANSWER Y = (X,LAMBDA) C SATISFIES C C |Y(1) - 1| .LE. ANSRE + ANSAE .AND. C C ||DZ|| .LE. ANSRE*||Y|| + ANSAE WHERE C C DZ IS THE NEWTON STEP TO Y. C C TRACE IS AN INTEGER SPECIFYING THE LOGICAL I/O UNIT FOR C INTERMEDIATE OUTPUT. IF TRACE .GT. 0 THE POINTS COMPUTED ON C THE ZERO CURVE ARE WRITTEN TO I/O UNIT TRACE . C C A(1:*) CONTAINS THE PARAMETER VECTOR A. FOR THE FIXED POINT C AND ZERO FINDING PROBLEMS, A NEED NOT BE INITIALIZED BY THE C USER, AND IS ASSUMED TO HAVE LENGTH N. FOR THE CURVE C TRACKING PROBLEM, A MUST BE INITIALIZED BY THE USER. C C YP(1:N+1) IS A WORK ARRAY CONTAINING THE TANGENT VECTOR TO THE C ZERO CURVE AT THE CURRENT POINT Y. C C YOLD(1:N+1) IS A WORK ARRAY CONTAINING THE PREVIOUS POINT FOUND C ON THE ZERO CURVE. C C YPOLD(1:N+1) IS A WORK ARRAY CONTAINING THE TANGENT VECTOR TO C THE ZERO CURVE AT YOLD. C C QR(1:LENQR) IS A WORK ARRAY CONTAINING THE N X N SYMMETRIC C JACOBIAN MATRIX WITH RESPECT TO X STORED IN PACKED SKYLINE C STORAGE FORMAT. LENQR AND PIVOT DESCRIBE THE DATA C STRUCTURE IN QR. (SEE SUBROUTINE PCGQS FOR A DESCRIPTION C OF THIS DATA STRUCTURE). C C LENQR IS THE LENGTH OF THE N-DIMENSIONAL ARRAY QR. I.E. C IT IS THE NUMBER OF NON-ZERO ENTRIES IN THE JACOBIAN C MATRIX [DF/DX] (OR [D RHO/DX]). C C PIVOT(1:N+2) IS A WORK ARRAY WHOSE FIRST N+1 COMPONENTS CONTAIN C THE INDICES OF THE DIAGONAL ELEMENTS OF THE N X N SYMMETRIC C JACOBIAN MATRIX (WITH RESPECT TO X) WITHIN QR. C C PP(1:N) IS A WORK ARRAY CONTAINING THE NEGATIVE OF THE LAST COLUMN C OF THE JACOBIAN MATRIX -[D RHO/D LAMBDA]. C C RHOVEC(1:N+1), Z0(1:N+1), DZ(1:N+1), T(1:N+1) ARE ALL WORK ARRAYS C USED BY STEPQS, TANGQS, AND ROOTQS TO CALCULATE THE TANGENT C VECTORS AND NEWTON STEPS. C C WORK(1:8*(N+1)+LENQR) IS A WORK ARRAY USED BY THE CONJUGATE GRADIENT C ALGORITHM TO SOLVE LINEAR SYSTEMS. C C SSPAR(1:4) = (HMIN, HMAX, BMIN, BMAX) IS A VECTOR OF PARAMETERS C USED FOR THE OPTIMAL STEP SIZE ESTIMATION. A DEFAULT VALUE C CAN BE SPECIFIED FOR ANY OF THESE FOUR PARAMETERS BY SETTING IT C .LE. 0.0 ON INPUT. SEE THE COMMENTS IN STEPQS FOR MORE C INFORMATION ABOUT THESE PARAMETERS. C C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS, C WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES C RHO, RHOJS. C C C ON OUTPUT: C C N , TRACE , A , LENQR ARE UNCHANGED. C C Y(N+1) = LAMBDA, (Y(1),...,Y(N)) = X, AND Y IS AN APPROXIMATE C ZERO OF THE HOMOTOPY MAP. NORMALLY LAMBDA = 1 AND X IS A C FIXED POINT OR ZERO OF F(X). IN ABNORMAL SITUATIONS, LAMBDA C MAY ONLY BE NEAR 1 AND X NEAR A FIXED POINT OR ZERO. C C IFLAG = C C 1 NORMAL RETURN. C C 2 SPECIFIED ERROR TOLERANCE CANNOT BE MET. SOME OR ALL OF C ARCRE, ARCAE, ANSRE, ANSAE HAVE BEEN INCREASED TO C SUITABLE VALUES. TO CONTINUE, JUST CALL FIXPQS AGAIN C WITHOUT CHANGING ANY PARAMETERS. C C 3 STEPQS HAS BEEN CALLED 1000 TIMES. TO CONTINUE, CALL C FIXPQS AGAIN WITHOUT CHANGING ANY PARAMETERS. C C 4 JACOBIAN MATRIX DOES NOT HAVE FULL RANK. THE ALGORITHM C HAS FAILED (THE ZERO CURVE OF THE HOMOTOPY MAP CANNOT BE C FOLLOWED ANY FURTHER). C C 5 THE TRACKING ALGORITHM HAS LOST THE ZERO CURVE OF THE C HOMOTOPY MAP AND IS NOT MAKING PROGRESS. THE ERROR C TOLERANCES ARC?E AND ANS?E WERE TOO LENIENT. THE PROBLEM C SHOULD BE RESTRARTED BY CALLING FIXPQS WITH SMALLER ERROR C TOLERANCES AND IFLAG = 0 (-1, -2). C C 6 THE NEWTON ITERATION IN STEPQS OR ROOTQS FAILED TO C CONVERGE. THE ERROR TOLERANCES ANS?E MAY BE TOO STRINGENT. C C 7 ILLEGAL INPUT PARAMETERS, A FATAL ERROR. C C ARCRE, ARCAE, ANSRE, ANSAE ARE UNCHANGED AFTER A NORMAL RETURN C (IFLAG = 1). THEY ARE INCREASED TO APPROPRIATE VALUES ON THE C RETURN IFLAG = 2. C C NFE IS THE NUMBER OF JACOBIAN EVALUATIONS. C C ARCLEN IS THE APPROXIMATE LENGTH OF THE ZERO CURVE. C C ***** DECLARATIONS ***** C C FUNCTION DECLARATIONS C DOUBLE PRECISION D1MACH, DNRM2 C C LOCAL VARIABLES C DOUBLE PRECISION ABSERR, H, HOLD, RELERR, S, WK INTEGER IFLAGC, ITER, JW, LIMITD, LIMIT, NP1, PCGWK LOGICAL CRASH, START C C SCALAR ARGUMENTS C DOUBLE PRECISION ARCRE, ARCAE, ANSRE, ANSAE, ARCLEN INTEGER N, IFLAG, TRACE, NFE, LENQR C C ARRAY DECLARATIONS C DOUBLE PRECISION A(N), Y(N+1), YP(N+1), YOLD(N+1), YPOLD(N+1), $ QR(LENQR), PP(N), RHOVEC(N+1), Z0(N+1), DZ(N+1), T(N+1), $ WORK(8*(N+1)+LENQR), SSPAR(4), PAR(1) INTEGER PIVOT(N+2), IPAR(1) C SAVE C C ***** END OF DECLARATIONS ***** C C LIMITD IS AN UPPER BOUND ON THE NUMBER OF STEPS. IT MAY BE C CHANGED BY CHANGING THE FOLLOWING PARAMETER STATEMENT: PARAMETER (LIMITD =1000) C C ***** FIRST EXECUTABLE STATEMENT ***** C C CHECK IFLAG C IF (N .LE. 0 .OR. ANSRE .LE. 0.0 .OR. ANSAE .LT. 0.0) $ IFLAG = 7 IF (IFLAG .GE. -2 .AND. IFLAG .LE. 0) GO TO 10 IF (IFLAG .EQ. 2) GO TO 50 IF (IFLAG .EQ. 3) GO TO 40 C C ONLY VALID INPUT FOR IFLAG IS -2, -1, 0, 2, 3. C IFLAG = 7 RETURN C C ***** INITIALIZATION BLOCK ***** C 10 ARCLEN = 0.0 IF (ARCRE .LE. 0.0) ARCRE = .5*SQRT(ANSRE) IF (ARCAE .LE. 0.0) ARCAE = .5*SQRT(ANSAE) NFE=0 IFLAGC = IFLAG NP1=N+1 PCGWK = 2*N+3 C C SET INITIAL CONDITIONS FOR FIRST CALL TO STEPQS. C START=.TRUE. CRASH=.FALSE. RELERR = ARCRE ABSERR = ARCAE HOLD=1.0 H=0.1 S=0.0 YPOLD(NP1) = 1.0 Y(NP1) = 0.0 DO 20 JW=1,N YPOLD(JW)=0.0 20 CONTINUE C C SET OPTIMAL STEP SIZE ESTIMATION PARAMETERS. C C MINIMUM STEP SIZE HMIN IF (SSPAR(1) .LE. 0.0) SSPAR(1)= (SQRT(N+1.0)+4.0)*D1MACH(4) C MAXIMUM STEP SIZE HMAX IF (SSPAR(2) .LE. 0.0) SSPAR(2)= 1.0 C MINIMUM STEP REDUCTION FACTOR BMIN IF (SSPAR(3) .LE. 0.0) SSPAR(3)= 0.1 C MAXIMUM STEP EXPANSION FACTOR BMAX IF (SSPAR(4) .LE. 0.0) SSPAR(4)= 7.0 C C LOAD A FOR THE FIXED POINT AND ZERO FINDING PROBLEMS. C IF (IFLAGC .GE. -1) THEN CALL DCOPY(N,Y,1,A,1) ENDIF C 40 LIMIT=LIMITD C C ***** END OF INITIALIZATION BLOCK. ***** C C ***** MAIN LOOP. ***** C 50 DO 400 ITER=1,LIMIT IF (Y(NP1) .LT. 0.0) THEN ARCLEN = S IFLAG = 5 RETURN END IF C C TAKE A STEP ALONG THE CURVE. C CALL STEPQS(N,NFE,IFLAGC,LENQR,START,CRASH,HOLD,H,WK,RELERR, $ ABSERR,S,Y,YP,YOLD,YPOLD,A,QR,PIVOT,PP,RHOVEC,Z0,DZ,T, $ WORK,SSPAR,PAR,IPAR) C C PRINT LATEST POINT ON CURVE IF REQUESTED. C IF (TRACE .GT. 0) THEN WRITE (TRACE,217) ITER,NFE,S,Y(NP1),(Y(JW),JW=1,N) 217 FORMAT(/' STEP',I5,3X,'NFE =',I5,3X,'ARC LENGTH =',F9.4,3X, $ 'LAMBDA =',F7.4,5X,'X vector:'/1P,(1X,6E12.4)) ENDIF C C CHECK IF THE STEP WAS SUCCESSFUL. C IF (IFLAGC .GT. 0) THEN ARCLEN=S IFLAG=IFLAGC RETURN END IF C IF (CRASH) THEN C C RETURN CODE FOR ERROR TOLERANCE TOO SMALL. C IFLAG=2 C C CHANGE ERROR TOLERANCES. C IF (ARCRE .LT. RELERR) THEN ARCRE=RELERR ANSRE=RELERR ENDIF IF (ARCAE .LT. ABSERR) ARCAE=ABSERR C C CHANGE LIMIT ON NUMBER OF ITERATIONS. C LIMIT = LIMIT - ITER RETURN END IF C C IF LAMBDA >= 1.0, USE ROOTQS TO FIND SOLUTION. C IF (Y(NP1) .GE. 1.0) GOTO 500 C 400 CONTINUE C C ***** END OF MAIN LOOP ***** C C DID NOT CONVERGE IN LIMIT ITERATIONS, SET IFLAG AND RETURN. C ARCLEN = S IFLAG = 3 RETURN C C ***** FINAL STEP -- FIND SOLUTION AT LAMBDA=1 ***** C C SAVE YOLD FOR ARC LENGTH CALCULATION LATER. C 500 CALL DCOPY(NP1,YOLD,1,T,1) C C FIND SOLUTION. C CALL ROOTQS(N,NFE,IFLAGC,LENQR,ANSRE,ANSAE,Y,YP,YOLD,YPOLD, $ A,QR,PIVOT,PP,RHOVEC,Z0,DZ,WORK(PCGWK),PAR,IPAR) C C CHECK IF SOLUTION WAS FOUND AND SET IFLAG ACCORDINGLY. C IFLAG=1 C C SET ERROR FLAG IF ROOTQS COULD NOT GET THE POINT ON THE ZERO C CURVE AT LAMBDA = 1.0 . C IF (IFLAGC .GT. 0) IFLAG=IFLAGC C C CALCULATE FINAL ARC LENGTH. C CALL DCOPY(NP1,Y,1,DZ,1) WK=-1.0 CALL DAXPY(NP1,WK,T,1,DZ,1) ARCLEN=S - HOLD + DNRM2(NP1,DZ,1) C C ***** END OF FINAL STEP ***** C RETURN C C ***** END OF SUBROUTINE FIXPQS ***** END SUBROUTINE FJAC(X,V,K) DOUBLE PRECISION X(1),V(1) INTEGER K C C RETURN IN V THE KTH COLUMN OF THE JACOBIAN MATRIX OF C F(X) EVALUATED AT X . C RETURN END SUBROUTINE FJACS(X,QR,LENQR,PIVOT) C INTEGER LENQR,N,PIVOT(N+2) C DOUBLE PRECISION QR(LENQR),X(N) C C Evaluate the N x N symmetric Jacobian matrix of F(X) at X, and return C the result in packed skyline storage format in QR. LENQR is the lengt C of QR, and PIVOT contains the indices of the diagonal elements of the C Jacobian matrix within QR. PIVOT(N+1) and PIVOT(N+2) are set by C subroutine FODE. C RETURN END SUBROUTINE FODE(S,Y,YP,YPOLD,A,QR,ALPHA,TZ,PIVOT,NFE,N,IFLAG, $ PAR,IPAR) C C SUBROUTINE FODE IS USED BY SUBROUTINE STEPS TO SPECIFY THE C ORDINARY DIFFERENTIAL EQUATION DY/DS = G(S,Y) , WHOSE SOLUTION C IS THE ZERO CURVE OF THE HOMOTOPY MAP. S = ARC LENGTH, C YP = DY/DS, AND Y(S) = (LAMBDA(S), X(S)) . C C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS, C WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES C RHOA, RHOJAC. C DOUBLE PRECISION DDOT,DNRM2,S,SUM,YPNORM INTEGER I,IERR,IFLAG,IK,J,K,KP1,KPIV,LW,N,NFE,NP1 C C ***** ARRAY DECLARATIONS. ***** C DOUBLE PRECISION Y(N+1),YP(N+1),YPOLD(N+1),A(N),PAR(1) INTEGER IPAR(1) C C ARRAYS FOR COMPUTING THE JACOBIAN MATRIX AND ITS KERNEL. DOUBLE PRECISION QR(N,N+1),ALPHA(N),TZ(N+1) INTEGER PIVOT(N+1) C C ***** END OF DIMENSIONAL INFORMATION. ***** C C NP1=N+1 NFE=NFE+1 C NFE CONTAINS THE NUMBER OF JACOBIAN EVALUATIONS. C * * * * * * * * * * * * * * * * * C C COMPUTE THE JACOBIAN MATRIX, STORE IT IN QR. C IF (IFLAG .EQ. -2) THEN C C QR = ( D RHO(A,LAMBDA,X)/D LAMBDA , D RHO(A,LAMBDA,X)/DX ) . C DO 30 K=1,NP1 CALL RHOJAC(A,Y(1),Y(2),QR(1,K),K,PAR,IPAR) 30 CONTINUE ELSE CALL F(Y(2),TZ) IF (IFLAG .EQ. 0) THEN C C QR = ( A - F(X), I - LAMBDA*DF(X) ) . C DO 100 J=1,N 100 QR(J,1)=A(J)-TZ(J) DO 120 K=1,N CALL FJAC(Y(2),TZ,K) KP1=K+1 DO 110 J=1,N 110 QR(J,KP1)=-Y(1)*TZ(J) 120 QR(K,KP1)=1.0+QR(K,KP1) ELSE C C QR = ( F(X) - X + A, LAMBDA*DF(X) + (1 - LAMBDA)*I ) . C 140 DO 150 J=1,N 150 QR(J,1)=TZ(J)-Y(J+1)+A(J) DO 170 K=1,N CALL FJAC(Y(2),TZ,K) KP1=K+1 DO 160 J=1,N 160 QR(J,KP1)=Y(1)*TZ(J) 170 QR(K,KP1)=1.0-Y(1)+QR(K,KP1) ENDIF ENDIF C C * * * * * * * * * * * * * * * * * C REDUCE THE JACOBIAN MATRIX TO UPPER TRIANGULAR FORM. 210 CALL DCPOSE(N,N,QR,ALPHA,PIVOT,IERR,TZ,YP) IF (IERR .EQ. 0) GO TO 220 IFLAG=4 RETURN C COMPUTE KERNEL OF JACOBIAN, WHICH SPECIFIES YP=DY/DS. 220 TZ(NP1)=1.0 DO 240 LW=1,N I=NP1-LW IK=I+1 SUM=0.0 DO 230 J=IK,NP1 230 SUM=SUM+QR(I,J)*TZ(J) 240 TZ(I)=-SUM/ALPHA(I) YPNORM=DNRM2(NP1,TZ,1) DO 260 K=1,NP1 KPIV=PIVOT(K) 260 YP(KPIV)=TZ(K)/YPNORM IF (DDOT(NP1,YP,1,YPOLD,1) .GE. 0.0) GO TO 280 DO 270 I=1,NP1 270 YP(I)=-YP(I) C C SAVE CURRENT DERIVATIVE (= TANGENT VECTOR) IN YPOLD . 280 DO 290 I=1,NP1 290 YPOLD(I)=YP(I) RETURN END SUBROUTINE FODEDS(S,Y,YP,YPOLD,A,QR,LENQR,PIVOT,PP,WORK, $ NFE,N,IFLAG,PAR,IPAR) C C SUBROUTINE FODEDS IS USED BY SUBROUTINE STEPDS TO SPECIFY THE C ORDINARY DIFFERENTIAL EQUATION DY/DS = G(S,Y) , WHOSE SOLUTION C IS THE ZERO CURVE OF THE HOMOTOPY MAP. S = ARC LENGTH, C YP = DY/DS, AND Y(S) = (X(S), LAMBDA(S)) . C C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS, C WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES C RHOA, RHOJS. C DOUBLE PRECISION DDOT,DNRM2,LAMBDA,S,TEMP,YPNORM INTEGER IFLAG,J,LENQR,N,NFE,NP1 C C ***** ARRAY DECLARATIONS. ***** C DOUBLE PRECISION Y(N+1),YP(N+1),YPOLD(N+1),A(N),PAR(1) INTEGER IPAR(1) C C ARRAYS FOR COMPUTING THE JACOBIAN MATRIX AND ITS KERNEL. DOUBLE PRECISION QR(LENQR),PP(N),WORK(6*(N+1)+LENQR) INTEGER PIVOT(N+2) C C ***** END OF DIMENSIONAL INFORMATION. ***** C C NP1=N+1 NFE=NFE+1 C NFE CONTAINS THE NUMBER OF JACOBIAN EVALUATIONS. LAMBDA=Y(NP1) C * * * * * * * * * * * * * * * * * C C COMPUTE THE JACOBIAN MATRIX, STORE IT IN [QR | -PP] . C IF (IFLAG .EQ. -2) THEN C C [QR | -PP] = [ D RHO(A,X,LAMBDA)/DX | D RHO(A,X,LAMBDA)/D LAMBDA ] . C CALL RHOJS(A,LAMBDA,Y,QR,LENQR,PIVOT,PP,PAR,IPAR) C PP = - (D RHO(A,X,LAMBDA)/D LAMBDA) . C ELSE CALL F(Y,PP) IF (IFLAG .EQ. 0) THEN C C [QR | -PP] = [ I - LAMBDA*DF(X) | A - F(X) ] . C CALL DAXPY(N,-1.0D0,A,1,PP,1) CALL FJACS(Y,QR,LENQR,PIVOT) CALL DSCAL(LENQR,-LAMBDA,QR,1) DO 120 J=1,N QR(PIVOT(J))=QR(PIVOT(J)) + 1.0 120 CONTINUE ELSE C C [QR | -PP] = [ LAMBDA*DF(X) + (1 - LAMBDA)*I | F(X) - X + A ] . C CALL DSCAL(N,-1.0D0,PP,1) CALL DAXPY(N,1.0D0,Y,1,PP,1) CALL DAXPY(N,-1.0D0,A,1,PP,1) CALL FJACS(Y,QR,LENQR,PIVOT) CALL DSCAL(LENQR,LAMBDA,QR,1) TEMP=1.0 - LAMBDA DO 170 J=1,N QR(PIVOT(J))=QR(PIVOT(J)) + TEMP 170 CONTINUE ENDIF ENDIF C C * * * * * * * * * * * * * * * * * CALL DCOPY(NP1,YPOLD,1,YP,1) C COMPUTE KERNEL OF JACOBIAN, WHICH SPECIFIES YP=DY/DS, USING A C PRECONDITIONED CONJUGATE GRADIENT ALGORITHM. CALL PCGDS(N,QR,LENQR,PIVOT,PP,YP,WORK,IFLAG) IF (IFLAG .GT. 0) RETURN C C NORMALIZE TANGENT VECTOR YP. YPNORM=DNRM2(NP1,YP,1) CALL DSCAL(NP1,1.0/YPNORM,YP,1) C C CHOOSE UNIT TANGENT VECTOR DIRECTION TO MAINTAIN CONTINUITY. IF (DDOT(NP1,YP,1,YPOLD,1) .LT. 0.0) $ CALL DSCAL(NP1,-1.0D0,YP,1) C C SAVE CURRENT DERIVATIVE (= TANGENT VECTOR) IN YPOLD . CALL DCOPY(NP1,YP,1,YPOLD,1) C RETURN END SUBROUTINE GFUNP(N,IDEG,PDG,QDG,X, $ XDGM1,XDG,PXDGM1,PXDG,G,DG) C C GFUNP EVALUATES THE START EQUATION "G". C C ON INPUT: C C N IS THE NUMBER OF VARIABLES. C C IDEG(J) IS THE DEGREE OF THE J-TH EQUATION. C C PDG(1,J), PDG(2,J) ARE THE REAL AND IMAGINARY PARTS C OF THE POWERS OF P USED TO DEFINE G. C C QDG(1,J), QDG(2,J) ARE THE REAL AND IMAGINARY PARTS C OF THE POWERS OF Q USED TO DEFINE G. C C X(1,J), X(2,J) ARE THE REAL AND IMAGINARY PARTS OF THE C J-TH INDEPENDENT VARIABLE. C C XDGM1,XDG,PXDGM1,PXDG ARE WORKSPACE ARRAYS. C C ON OUTPUT: C C N,IDEG,PDG,QDG, AND X ARE UNCHANGED. C C G(1,J),G(2,J) ARE THE REAL AND IMAGINARY PARTS OF THE C J-TH START EQUATION. C C DG(1,J),DG(2,J) ARE THE REAL AND IMAGINARY PARTS OF THE C PARTIAL DERIVATIVES OF THE J-TH START EQUATION WITH RESPECT TO THE C J-TH INDEPENDENT VARIABLE. C C SUBROUTINE: MULP. C C DECLARATION OF INPUT AND OUTPUT: INTEGER N,IDEG DOUBLE PRECISION PDG,QDG,X,XDGM1,XDG,PXDGM1,PXDG,G,DG DIMENSION IDEG(N),PDG(2,N),QDG(2,N),X(2,N), $ XDGM1(2,N),XDG(2,N),PXDGM1(2,N),PXDG(2,N), $ G(2,N),DG(2,N) C C DECLARATION OF VARIABLES INTEGER I,J C C COMPUTE THE (IDEG-1)-TH AND IDEG-TH POWER OF X DO 5 J=1,N CALL POWP(IDEG(J)-1,X(1,J), XDGM1(1,J)) CALL MULP(X(1,J),XDGM1(1,J), XDG(1,J)) 5 CONTINUE C C COMPUTE THE PRODUCT OF PDG AND XDGM1 DO 10 J=1,N CALL MULP( PDG(1,J), XDGM1(1,J), PXDGM1(1,J) ) 10 CONTINUE C C COMPUTE THE PRODUCT OF PDG AND XDG DO 20 J=1,N CALL MULP( PDG(1,J), XDG(1,J), PXDG(1,J) ) 20 CONTINUE DO 30 J=1,N DO 30 I=1,2 G(I,J)=PXDG(I,J) - QDG(I,J) DG(I,J)= IDEG(J)*PXDGM1(I,J) 30 CONTINUE RETURN END * SUBROUTINE GMFADS(NN,A,NWK,MAXA) C C This subroutine computes the LDU decomposition of a symmetric posi C definite matrix B where only the upper triangular skyline structur C is stored. The decomposition is done by the Gill-Murray C strategy from P.E. Gill and W. Murray, Newton type Methods C for Unconstrained and Linearly Constrained Optimization, C Mathematical Programming, 7, 311-350 (1974) and gives an C approximate decomposition in the case of a nonpositive C definite or ill-conditioned matrix. C C Input variables: C C NN -- dimension of B. C C A -- one dimensional real array containing the upper C triangular skyline portion of a symmetric matrix B in C packed skyline storage format. C C NWK -- number of elements in A. C C MAXA -- an integer array of dimension NN+1 containing the C locations of the diagonal elements of B in A. C By convention, MAXA(NN+1)=NWK+1. C C Output variables: C C A -- the upper triangular skyline portion of the LDU C decomposition of the symmetric matrix B (or B + E if B C was not sufficiently positive definite). C C C No working storage is required by this routine. C C Subroutines called: D1MACH C INTEGER I,I0,I1,I2,I3,I4,J,J1,K,K1,K2,KH,KL,KN,KU,KZ,L,L1, $ L2,L3,M,M1,MAXA(NN+1),N1,NN,NNN,NWK DOUBLE PRECISION A(NWK),BET,DEL,DJ,D1MACH,G,GAM,GAM1,PHI, $ THE,THE1,XT1,XT2,ZET,ZET1 C LOGICAL GMALT C GMALT=.FALSE. G=0.0 GAM=0.0 DO 1 I=1,NN K=MAXA(I) G=G+A(K)*A(K) GAM1=ABS(A(K)) IF(GAM1.GT.GAM)GAM=GAM1 1 CONTINUE ZET=0.0 DO 3 I=1,NN K=MAXA(I) K1=MAXA(I+1)-1 K2=K1-K IF(K2.EQ.0)GO TO 3 L=K+1 DO 2 J=L,K1 G=G+2.0*A(J)*A(J) ZET1=ABS(A(J)) IF(ZET1.GT.ZET)ZET=ZET1 2 CONTINUE 3 CONTINUE ZET=ZET/NN DEL=D1MACH(4) BET=DEL IF(ZET.GT.BET)BET=ZET IF(GAM.GT.BET)BET=GAM G=SQRT(G) IF(G.GT.1.0)DEL=DEL*G DO 4 I=1,NN N1=I-1 KN=MAXA(I) KL=KN+1 KU=MAXA(I+1)-1 KH=KU-KL PHI=A(KN) IF(KH.LT.0)GO TO 10 K1=KN+1 K2=I DO 5 J=K1,KU K2=K2-1 KZ=MAXA(K2) PHI=PHI-A(J)*A(J)*A(KZ) 5 CONTINUE C10 IF(PHI.LE.0.0)GMALT=.TRUE. 10 PHI=ABS(PHI) L=I+1 THE=0.0 NNN=NN+1 IF(L.EQ.NNN)GO TO 11 DO 6 J=L,NN L1=MAXA(J) L2=MAXA(J+1) L3=L2-L1-1 M=J-I IF(L3.LT.M)GO TO 6 M1=L1+M IF(N1.EQ.0)GO TO 7 DO 8 J1=1,N1 I0=MAXA(J1) I1=MAXA(L) I2=I-J1 I3=I1-KN-1 I4=J-J1 IF(I3.LT.I2)GO TO 8 IF(L3.LT.I4)GO TO 8 XT1=A(KN+I2) XT2=A(L1+I4) A(M1)=A(M1)-XT1*XT2*A(I0) 8 CONTINUE 7 THE1=ABS(A(M1)) IF(THE.LT.THE1)THE=THE1 6 CONTINUE 11 THE=THE*THE/BET DJ=DEL IF(PHI.GT.DJ)DJ=PHI IF(THE.GT.DJ)DJ=THE C IF(ABS(DJ).NE.PHI)GMALT=.TRUE. A(KN)=DJ IF(L.EQ.NNN)GO TO 4 DO 9 J=L,NN L1=MAXA(J) L2=MAXA(J+1) L3=L2-L1-1 M=J-I IF(L3.LT.M)GO TO 9 M1=L1+M A(M1)=A(M1)/A(KN) 9 CONTINUE 4 CONTINUE RETURN END SUBROUTINE HFUN1P(QDG,LAMBDA,X, $ PDG,CL,COEF,RHO, $ DRHOX,DRHOL,XDGM1,XDG, $ G,DG,PXDGM1,PXDG, $ F,DF,XX,TRM, $ DTRM,CLX,DXNP1, $ N,MMAXT,IDEG, $ NUMT,KDEG) C C HFUN1P EVALUATES THE CONTINUATION EQUATION "RHO". C C NOTE THAT: C DRHOX IS THE "REALIFICATION" OF DCRHOX, WHERE C DCRHOX DENOTES THE (COMPLEX) PARTIAL C DERIVATIVE MATRIX OF THE CONTINUATION SYSTEM C WITH RESPECT TO X, AND C DRHOL IS THE "REALIFICATION" OF DCRHOL, WHERE C DCRHOL DENOTES THE (COMPLEX) PARTIAL C DERIVATIVE MATRIX OF THE CONTINUATION SYSTEM C WITH RESPECT TO LAMBDA. THUS C DRHOX(2J-1,2K-1) = DCRHOX(1,J,K) C DRHOX(2J ,2K ) = DCRHOX(1,J,K) C DRHOX(2J-1,2K ) =-DCRHOX(2,J,K) C DRHOX(2J ,2K-1) = DCRHOX(2,J,K) C DRHOL(2J-1,N2P1) = DCRHOL(1,J) C DRHOL(2J ,N2P1) = DCRHOL(2,J) C RHO(2J-1) = CRHO(1,J) C RHO(2J ) = CRHO(2,J) C WHERE CRHO DENOTES THE (COMPLEX) CONTINUATION SYSTEM, C THE INITIAL "1" OR "2" DENOTES REAL OR IMAGINARY PARTS, C RESPECTIVELY, "J" INDEXES THE EQUATION, "K" INDEXES THE PARTIAL C DERIVATIVE, AND NEITHER DCRHOX NOR DCRHOL ARE PROGRAM VARIABLES. C C ON INPUT: C C QDG IS THE "RANDOM" PARAMETER "A". C C LAMBDA IS THE CONTINUATION PARAMETER. C C X IS THE INDEPENDENT VARIABLE. C C PDG IS ONE OF THE PARAMETERS THAT DEFINES G (SEE SUBROUTINE C GFUNP). C C CL IS ONE OF THE PARAMETERS THAT DEFINES F (SEE SUBROUTINE C FFUNP). C C COEF IS ONE OF THE PARAMETERS THAT DEFINES F (SEE SUBROUTINE C FFUNP). C C ON OUTPUT: C C RHO IS THE HOMOTOPY. C C DRHOX CONTAINS THE PARTIAL DERIVATIVES OF RHO WITH RESPECT C TO X. C C DRHOL CONTAINS THE PARTIAL DERIVATIVES OF RHO WITH RESPECT C TO LAMBDA. C C THE FOLLOWING ARE VARIABLES WHOSE WORKSPACE IS PASSED FROM HFUNP: C XDGM1 C XDG C G C DG C PXDGM1 C PXDG C F C DF C XX C TRM C DTRM C CLX C DXNP1 C N C MMAXT C IDEG C NUMT C KDEG C C OTHER VARIABLES: C ONEML C C SUBROUTINES: GFUNP, FFUNP. C C DECLARATION OF INPUT, WORKSPACE, AND OUTPUT: INTEGER N,MMAXT,IDEG, $ NUMT,KDEG DOUBLE PRECISION QDG,LAMBDA,X, $ PDG,CL,COEF,RHO, $ DRHOX,DRHOL,XDGM1,XDG, $ G,DG,PXDGM1,PXDG, $ F,DF,XX,TRM, $ DTRM,CLX,DXNP1 DIMENSION IDEG(N),NUMT(N),KDEG(N,N+1,MMAXT) DIMENSION QDG(2,N),X(2,N), $ PDG(2,N),CL(2,N+1),COEF(N,MMAXT),RHO(2*N), $ DRHOX(2*N,2*N),DRHOL(2*N),XDGM1(2,N),XDG(2,N), $ G(2,N),DG(2,N),PXDGM1(2,N),PXDG(2,N), $ F(2,N), DF(2,N,N+1),XX(2,N,N+1,MMAXT),TRM(2,N,MMAXT), $ DTRM(2,N,N+1,MMAXT),CLX(2,N),DXNP1(2,N) C C DECLARATION OF VARIABLES: INTEGER J,J2,J2M1,K,K2,K2M1 DOUBLE PRECISION ONEML C CALL GFUNP(N,IDEG,PDG,QDG,X,XDGM1,XDG,PXDGM1,PXDG,G,DG) CALL FFUNP(N,NUMT,MMAXT,KDEG,COEF,CL,X, $ XX,TRM,DTRM,CLX,DXNP1,F,DF) ONEML=1.0 - LAMBDA DO 30 J=1,N J2=2*J J2M1=J2-1 DO 20 K=1,N K2=2*K K2M1=K2-1 DRHOX(J2M1,K2M1)= LAMBDA*DF(1,J,K) DRHOX(J2 ,K2 )= DRHOX(J2M1,K2M1) DRHOX(J2 ,K2M1)= LAMBDA*DF(2,J,K) DRHOX(J2M1,K2 )=-DRHOX(J2 ,K2M1) 20 CONTINUE DRHOX(J2M1,J2M1)= DRHOX(J2M1,J2M1) + ONEML*DG(1,J) DRHOX(J2 ,J2 )= DRHOX(J2M1,J2M1) DRHOX(J2 ,J2M1)= DRHOX(J2 ,J2M1) + ONEML*DG(2,J) DRHOX(J2M1,J2 )=-DRHOX(J2 ,J2M1) DRHOL(J2M1) = F(1,J) - G(1,J) DRHOL(J2) = F(2,J) - G(2,J) RHO(J2M1) = LAMBDA*F(1,J) + ONEML* G(1,J) RHO(J2 ) = LAMBDA*F(2,J) + ONEML* G(2,J) 30 CONTINUE RETURN END * SUBROUTINE HFUNP(QDG,LAMBDA,X,PAR,IPAR) C C HFUNP ALLOCATES STORAGE FOR SUBROUTINE HFUN1P FROM THE WORK ARRAYS C PAR AND IPAR, AS FOLLOWS: C C DOUBLE PRECISION VARIABLES AND ARRAYS PASSED IN PAR C C PAR INDEX VARIABLE NAME LENGTH C ---------- ------------- ----------------- C 1 PDG 2*N C 2 CL 2*(N+1) C 3 COEF N*MMAXT C 4 RHO N2 C 5 DRHOX N2*N2 C 6 DRHOL N2 C 7 XDGM1 2*N C 8 XDG 2*N C 9 G 2*N C 10 DG 2*N C 11 PXDGM1 2*N C 12 PXDG 2*N C 13 F 2*N C 14 DF 2*N*(N+1) C 15 XX 2*N*(N+1)*MMAXT C 16 TRM 2*N*MMAXT C 17 DTRM 2*N*(N+1)*MMAXT C 18 CLX 2*N C 19 DXNP1 2*N C C INTEGER VARIABLES AND ARRAYS PASSED IN IPAR C C IPAR INDEX VARIABLE NAME LENGTH OFFSET C ---------- ------------- ----------------- C 1 N 1 1 C 2 MMAXT 1 2 C 3 PROFF 25 3 C 4 IPROFF 15 28 C 5 IDEG N 43 C 6 NUMT N 43+N C 7 KDEG N*(N+1)*MMAXT 43+N2+1 C C ON INPUT: C C QDG IS THE "RANDOM" VECTOR DENOTED "A" IN HOMPACK DOCUMENTATION. C C LAMBDA IS THE CONTINUATION PARAMETER. C C X IS THE INDEPENDENT VARIABLE. C C PAR IS THE REAL PARAMETER ARRAY. C C IPAR IS THE INTEGER PARAMETER ARRAY. C C ON OUTPUT: C C THE WORK ARRAYS PAR AND IPAR HAVE BEEN UPDATED. C C SUBROUTINES: HFUN1P. C INTEGER IPAR DOUBLE PRECISION QDG,LAMBDA,X,PAR DIMENSION QDG(2,1),X(2,1),PAR(*),IPAR(*) C CALL HFUN1P(QDG,LAMBDA,X, $ PAR( IPAR(3 + ( 1-1))), PAR( IPAR(3 + ( 2-1))), $ PAR( IPAR(3 + ( 3-1))), PAR( IPAR(3 + ( 4-1))), $ PAR( IPAR(3 + ( 5-1))), PAR( IPAR(3 + ( 6-1))), $ PAR( IPAR(3 + ( 7-1))), PAR( IPAR(3 + ( 8-1))), $ PAR( IPAR(3 + ( 9-1))), PAR( IPAR(3 + (10-1))), $ PAR( IPAR(3 + (11-1))), PAR( IPAR(3 + (12-1))), $ PAR( IPAR(3 + (13-1))), PAR( IPAR(3 + (14-1))), $ PAR( IPAR(3 + (15-1))), PAR( IPAR(3 + (16-1))), $ PAR( IPAR(3 + (17-1))), PAR( IPAR(3 + (18-1))), $ PAR( IPAR(3 + (19-1))), $IPAR( IPAR(28+ ( 1-1))),IPAR( IPAR(28+ ( 2-1))), $IPAR( IPAR(28+ ( 5-1))),IPAR( IPAR(28+ ( 6-1))), $IPAR( IPAR(28+ ( 7-1))) ) C RETURN END * INTEGER FUNCTION IDAMAX(N,DX,INCX) C C FINDS THE INDEX OF ELEMENT HAVING MAX. ABSOLUTE VALUE. C JACK DONGARRA, LINPACK, 3/11/78. C DOUBLE PRECISION DX(1),DMAX INTEGER I,INCX,IX,N C IDAMAX = 0 IF( N .LT. 1 ) RETURN IDAMAX = 1 IF(N.EQ.1)RETURN IF(INCX.EQ.1)GO TO 20 C C CODE FOR INCREMENT NOT EQUAL TO 1 C IX = 1 DMAX = DABS(DX(1)) IX = IX + INCX DO 10 I = 2,N IF(DABS(DX(IX)).LE.DMAX) GO TO 5 IDAMAX = I DMAX = DABS(DX(IX)) 5 IX = IX + INCX 10 CONTINUE RETURN C C CODE FOR INCREMENT EQUAL TO 1 C 20 DMAX = DABS(DX(1)) DO 30 I = 2,N IF(DABS(DX(I)).LE.DMAX) GO TO 30 IDAMAX = I DMAX = DABS(DX(I)) 30 CONTINUE RETURN END * SUBROUTINE INITP(IFLG1,N,NUMT,KDEG,COEF,NN,MMAXT,PAR,IPAR, $ IDEG,FACV,CL,PDG,QDG,R) C C INITP INITIALIZES THE CONSTANTS THAT DEFINE THE POLSYS HOMOTOPY, C INITIALIZES THE CONSTANTS THAT DEFINE THE PROJECTIVE TRANSFORMATION, C AND SCALES THE COEFFICIENTS (IF SCALING IS SPECIFIED). C C ON INPUT: C C IFLG1 IS A FLAG THAT SPECIFIES WHETHER THE COEFFICIENTS ARE TO C BE SCALED OR NOT AND WHETHER THE PROJECTIVE TRANSFORMATION IS TO C BE USED OR NOT. IFLG1=A*10+B. SCALING IS SPECIFIED WHEN B=1. THE C PROJECTIVE TRANSFORMATION IS SPECIFIED WHEN A=1. OTHERWISE, A AND/O C B =0. SCALING IS EVOKED BY A CALL TO THE SUBROUTINE SCLGNP. THE C PROJECTIVE TRANSFORMATION IS EVOKED BY SETTING THE CL ARRAY EQUAL C TO RANDOM COMPLEX NUMBERS. OTHERWISE, CL IS SET TO NOMINAL VALUES C C N IS THE NUMBER OF EQUATIONS AND VARIABLES. C C NUMT(J) IS THE NUMBER OF TERMS IN EQUATION J, FOR J=1 TO N. C C KDEG(J,L,K) IS THE DEGREE OF THE L-TH VARIABLE, X(L), IN THE K-TH C TERM OF THE J-TH EQUATION, WHERE J=1 TO N, L=1 TO N+1, AND K=1 TO C NUMT(J). THE CASE "L=N+1" IS SPECIAL, AND KDEG IS NOT AN INPUT C VALUE TO POLSYS , BUT RATHER IS COMPUTED IN THIS SUBROUTINE. C C COEF(J,K) IS THE COEFFICIENT OF THE K-TH TERM FOR THE J-TH C EQUATION, WHERE J=1 TO N AND K=1 TO NUMT(J). C C NN IS THE DECLARED DIMENSION OF SEVERAL ARRAY INDICES. C C MMAXT IS AN UPPER BOUND FOR NUMT(J) FOR J=1 TO N. C C PAR AND IPAR ARE WORKSPACE ARRAYS. C C ON OUTPUT: C C IDEG(J) IS THE DEGREE OF THE J-TH EQUATION FOR J=1 TO N. C C FACV(J) IS THE SCALE FACTOR FOR THE J-TH VARIABLE. C C CL(2,1:N+1) IS AN ARRAY USED TO DEFINE THE PROJECTIVE C TRANSFORMATION. IT IS USED IN SUBROUTINES FFUNP AND OTPUTP C TO DEFINE THE PROJECTIVE COORDINATE, XNP1. C C PDG IS USED IN SUBROUTINE GFUNP TO DEFINE THE INITIAL SYSTEM, C G(X)=0. C C QDG IS USED IN SUBROUTINE GFUNP TO DEFINE THE INITIAL SYSTEM, C G(X)=0. C C R IS USED IN SUBROUTINE STRPTP TO GENERATE SOLUTIONS TO G(X)=0. C C C DECLARATIONS OF INPUT AND OUTPUT: INTEGER IFLG1,N,NUMT,KDEG,NN,MMAXT,IPAR,IDEG DOUBLE PRECISION COEF,PAR,FACV,CL,PDG,QDG,R DIMENSION NUMT(NN),KDEG(NN,NN+1,MMAXT),IDEG(N),COEF(NN,MMAXT), $ PAR(2 + 28*N + 6*N**2 + 7*N*MMAXT + 4*N**2*MMAXT), $ IPAR(42 + 2*N + N*(N+1)*MMAXT), $ FACV(N),CL(2,N+1),PDG(2,N),QDG(2,N),R(2,N) C C DECLARATIONS OF VARIABLES: INTEGER I,IERR,IIDEG,J,JJ,K,L,N2,NP1 DOUBLE PRECISION P,Q,CCL,ZERO DIMENSION P(2,10),Q(2,10),CCL(2,11) C ZERO=0.0 N2 =2*N NP1=N+1 DO 15 J=1,N IDEG(J)=0 DO 15 K=1,NUMT(J) IIDEG=0 DO 12 L=1,N IIDEG=IIDEG+KDEG(J,L,K) 12 CONTINUE IF(IIDEG.GT.IDEG(J))IDEG(J)=IIDEG 15 CONTINUE DO 25 J=1,N DO 25 K=1,NUMT(J) IIDEG=0 DO 22 L=1,N IIDEG=IIDEG+KDEG(J,L,K) 22 CONTINUE KDEG(J,NP1,K)=IDEG(J)-IIDEG 25 CONTINUE IF ( IFLG1 .EQ. 10 .OR. IFLG1 .EQ. 00) THEN C C DON'T SCALE THE COEFFICIENTS. SET FACV EQUAL TO NOMINAL C VALUES. C DO 30 I=1,N FACV(I)=0.0 30 CONTINUE ELSE C C SET UP THE WORKSPACE FOR SUBROUTINE SCLGNP AND CALL SCLGNP TO C SCALE THE COEFFICIENTS. C C***************************************************************** C VARIABLES THAT ARE PASSED IN ARRAY PAR. C C VARIABLE NAME LENGTH OFFSET C C 1 CCOEF N*MMAXT 1 C 2 ALPHA 4*N**2 1+N*MMAXT C 3 BETA 2*N 1+N*MMAXT+4*N**2 C 4 RWORK N*(2*N+1) 1+N*MMAXT+4*N**2+2*N C 5 XWORK 2*N 1+N*MMAXT+4*N**2+2*N+N*(2*N+1) C 6 FACE N 1+N*MMAXT+4*N**2+4*N+N*(2*N+1) C 7 COESCL N*MMAXT 1+N*MMAXT+4*N**2+5*N+N*(2*N+1) C C***************************************************************** C VARIABLES THAT ARE PASSED IN ARRAY IPAR. C C VARIABLE NAME LENGTH OFFSET C C 1 NNUMT N 1 C 2 KKDEG N*(N+1)*MMAXT 1+N C C***************************************************************** C CALL SCLGNP(N,NN,MMAXT,NUMT,KDEG,0,ZERO,COEF, $ IPAR(1), $ IPAR(1+N), $ PAR(1), $ PAR(1+N*MMAXT), $ PAR(1+N*MMAXT+4*N**2), $ PAR(1+N*MMAXT+4*N**2+2*N), $ PAR(1+N*MMAXT+4*N**2+2*N+N*(2*N+1)), $ FACV, $ PAR(1+N*MMAXT+4*N**2+4*N+N*(2*N+1)), $ PAR(1+N*MMAXT+4*N**2+5*N+N*(2*N+1)), $ IERR) C C SET COEF EQUAL TO THE SCALED COEFFICIENTS C IF (IERR .EQ. 0) THEN DO 40 J=1,N DO 40 K=1,NUMT(J) COEF(J,K)=PAR(N*MMAXT+4*N**2+5*N+N*(2*N+1) + J + N*(K-1)) 40 CONTINUE END IF END IF C P(1, 1)= .12324754231D0 P(2, 1)= .76253746298D0 P(1, 2)= .93857838950D0 P(2, 2)=-.99375892810D0 P(1, 3)=-.23467908356D0 P(2, 3)= .39383930009D0 P(1, 4)= .83542556622D0 P(2, 4)=-.10192888288D0 P(1, 5)=-.55763522521D0 P(2, 5)=-.83729899911D0 P(1, 6)=-.78348738738D0 P(2, 6)=-.10578234903D0 P(1, 7)= .03938347346D0 P(2, 7)= .04825184716D0 P(1, 8)=-.43428734331D0 P(2, 8)= .93836289418D0 P(1, 9)=-.99383729993D0 P(2, 9)=-.40947822291D0 P(1,10)= .09383736736D0 P(2,10)= .26459172298D0 C Q(1, 1)= .58720452864D0 Q(2, 1)= .01321964722D0 Q(1, 2)= .97884134700D0 Q(2, 2)=-.14433009712D0 Q(1, 3)= .39383737289D0 Q(2, 3)= .41543223411D0 Q(1, 4)=-.03938376373D0 Q(2, 4)=-.61253112318D0 Q(1, 5)= .39383737388D0 Q(2, 5)=-.26454678861D0 Q(1, 6)=-.00938376766D0 Q(2, 6)= .34447867861D0 Q(1, 7)=-.04837366632D0 Q(2, 7)= .48252736790D0 Q(1, 8)= .93725237347D0 Q(2, 8)=-.54356527623D0 Q(1, 9)= .39373957747D0 Q(2, 9)= .65573434564D0 Q(1,10)=-.39380038371D0 Q(2,10)= .98903450052D0 C CCL(1, 1)=-.03485644332D0 CCL(2, 1)= .28554634336D0 CCL(1, 2)= .91453454766D0 CCL(2, 2)= .35354566613D0 CCL(1, 3)=-.36568737635D0 CCL(2, 3)= .45634642477D0 CCL(1, 4)=-.89089767544D0 CCL(2, 4)= .34524523544D0 CCL(1, 5)= .13523462465D0 CCL(2, 5)= .43534535555D0 CCL(1, 6)=-.34523544445D0 CCL(2, 6)= .00734522256D0 CCL(1, 7)=-.80004678763D0 CCL(2, 7)=-.009387123644D0 CCL(1, 8)=-.875432124245D0 CCL(2, 8)= .00045687651D0 CCL(1, 9)= .65256352333D0 CCL(2, 9)=-.12356777452D0 CCL(1,10)= .09986798321548D0 CCL(2,10)=-.56753456577D0 CCL(1,11)= .29674947394739D0 CCL(2,11)= .93274302173D0 C C IF THE PROJECTIVE TRANSFORMATION IS TO BE USED, THEN CL IS C SET EQUAL TO THE CCL VALUES. OTHERWISE, CL IS SET C EQUAL TO NOMINAL VALUES. C IF (IFLG1 .EQ. 01 .OR. IFLG1 .EQ. 00) THEN DO 50 I=1,2 DO 50 J=1,N CL(I,J)=0.0 50 CONTINUE CL(1,NP1)=1.0 CL(2,NP1)=0.0 ELSE DO 60 J=1,NP1 JJ=MOD(J-1,11)+1 DO 60 I=1,2 CL(I,J)=CCL(I,JJ) 60 CONTINUE END IF C C COMPUTE POWERS OF P AND Q, AND R=Q/P DO 70 J=1,N JJ=MOD(J-1,10)+1 CALL POWP(IDEG(J),P(1,JJ),PDG(1,J)) CALL POWP(IDEG(J),Q(1,JJ),QDG(1,J)) CALL DIVP(Q(1,JJ),P(1,JJ),R(1,J),IERR) 70 CONTINUE RETURN END * SUBROUTINE MFACDS(NN,Q,LENAA,MAXA) C C SETS UP Q AS THE FACTORIZATION OF THE ENTIRE C (NN+1) X (NN+1) MATRIX M. C C on input: C C NN is the dimension of the symmetric matrix AA, the upper left corner C of the augmented Jacobian matrix B. C C Q contains AA in its first LENAA positions. C C LENAA is the length of the one dimensional packed array AA. C C MAXA is the integer array used for packed skyline storage. It descri C AA and M, the symmetric piece of B. C C on output: C C NN, LENAA, and MAXA are unchanged. C C Q contains an approximate factorization of M, in packed skyline stora C form. C C C Calls GMFADS . C INTEGER I,IMAX,LENAA,LENQ,NN,MAXA(NN+2),NQ DOUBLE PRECISION Q(LENAA+NN+1) C NQ=NN+1 IMAX=MAXA(NN+2)-LENAA-2 LENQ=MAXA(NN+2)-1 C DO 100 I=1,IMAX,1 Q(LENAA+I)=0.0 100 CONTINUE Q(LENQ)=1.0D0 C CALL GMFADS(NQ,Q,LENQ,MAXA) C RETURN END SUBROUTINE MULP(XXXX,YYYY,ZZZZ) C C THIS SUBROUTINE PERFORMS MULTIPLICATION OF COMPLEX NUMBERS: C ZZZZ = XXXX*YYYY C C NOTE: IN THE CALLING ROUTINE, ZZZZ SHOULD NOT BE THE SAME C AS XXXX OR YYYY. HOWEVER, XXXX MAY BE THE SAME AS YYYY. C THUS, "CALL MULP(X,X,Z)" IS OK, BUT "CALL MULP(X,Y,X)" IS NOT. C C ON INPUT: C C XXXX IS AN ARRAY OF LENGTH TWO REPRESENTING THE FIRST COMPLEX C NUMBER, WHERE XXXX(1) = REAL PART OF XXXX AND XXXX(2) = C IMAGINARY PART OF XXXX. C C YYYY IS AN ARRAY OF LENGTH TWO REPRESENTING THE SECOND COMPLEX C NUMBER, WHERE YYYY(1) = REAL PART OF YYYY AND YYYY(2) = C IMAGINARY PART OF YYYY. C C ON OUTPUT: C C ZZZZ IS AN ARRAY OF LENGTH TWO REPRESENTING THE RESULT OF C THE MULTIPLICATION, ZZZZ = XXXX*YYYY, WHERE ZZZZ(1) = C REAL PART OF ZZZZ AND ZZZZ(2) = IMAGINARY PART OF ZZZZ. C C DECLARATION OF INPUT DOUBLE PRECISION XXXX,YYYY DIMENSION XXXX(2),YYYY(2) C C DECLARATION OF OUTPUT DOUBLE PRECISION ZZZZ DIMENSION ZZZZ(2) C ZZZZ(1) = XXXX(1)*YYYY(1) - XXXX(2)*YYYY(2) ZZZZ(2) = XXXX(1)*YYYY(2) + XXXX(2)*YYYY(1) RETURN END * SUBROUTINE MULTDS(Y,AA,X,MAXA,NN,LENAA) C C This subroutine accepts a matrix, AA, in packed skyline storage fo C a vector, x, and returns the product AA*x in y. C C Input Variables: C C AA -- one dimensional real array containing the NN x NN matrix i C packed skyline storage form. C C x -- real vector of length NN to be multiplied by AA. C C MAXA -- integer array used for specifying information about AA. C MAXA has length NN+1, and stores the indices of the C diagonal elements of the matrix packed in AA. By C convention, MAXA(NN+1) = LENAA + 1 . C C NN -- dimension of the matrix packed in AA . C C LENAA -- number of elements in AA. C C C Output Variables: C C y -- real vector of length NN containing the product AA*x . C C C INTEGER I,II,KK,KL,KU,LENAA,NN,MAXA(NN+1) DOUBLE PRECISION AA(LENAA),B,CC,X(NN),Y(NN) IF(LENAA.GT.NN) GO TO 20 DO 10 I=1,NN 10 Y(I)=AA(I)*X(I) RETURN 20 DO 40 I=1,NN 40 Y(I)=0.00 DO 100 I=1,NN KL=MAXA(I) KU=MAXA(I+1)-1 II=I+1 CC=X(I) DO 100 KK=KL,KU II=II-1 100 Y(II)=Y(II)+AA(KK)*CC IF(NN.EQ.1) RETURN DO 200 I=2,NN KL=MAXA(I)+1 KU=MAXA(I+1)-1 IF(KU-KL) 200,210,210 210 II=I B=0.00 DO 220 KK=KL,KU II=II-1 220 B=B+AA(KK)*X(II) Y(I)=Y(I)+B 200 CONTINUE RETURN END SUBROUTINE OTPUTP(N,NUMPAT,CL,FACV,CLX,X,XNP1) C C OTPUTP POSTPROCESSES THE ENDPOINTS OF THE PATHS, UNTRANSFORMING C AND UNSCALING THEM. C C ON INPUT: C C N IS THE NUMBER OF EQUATIONS AND VARIABLES. C C NUMPAT IS THE CURRENT PATH NUMBER. C C CL IS THE ARRAY THAT DEFINES THE PROJECTIVE TRANSFORMATION. C C FACV CONTAINS THE VARIABLE SCALING FACTORS. C C X IS THE ENDPOINT OF THE PATH, POSSIBLY TRANSFORMED AND/OR SCALED C DEPENDING ON THE POLSYS INPUT FLAG IFLG1. C C CLX IS WORKSPACE. C C ON OUTPUT: C C N, NUMPAT, CL, AND FACV ARE UNCHANGED. C C X IS THE UNTRANSFORMED AND UNSCALED VERSION OF X. C C XNP1 IS THE PROJECTIVE COORDINATE "X(N+1)". XNP1 EQUALS UNITY IF C THE PROJECTIVE TRANSFORMATION IS NOT SPECIFIED. C C DECLARATIONS OF INPUT, WORKSPACE, AND OUTPUT: INTEGER N,NUMPAT DOUBLE PRECISION CL,FACV,CLX,X,XNP1 DIMENSION CL(2,N+1),FACV(N),CLX(2,N),X(2,N),XNP1(2) C C DECLARATION OF VARIABLES INTEGER I,IERR,J,NP1 DOUBLE PRECISION D1MACH,FAC,TEMP DIMENSION TEMP(2) C NP1=N+1 C COMPUTE XNP1 DO 1 J=1,N CALL MULP(CL(1,J),X(1,J),CLX(1,J)) 1 CONTINUE DO 2 I=1,2 XNP1(I)=CL(I,NP1) DO 2 J=1,N XNP1(I) = XNP1(I) + CLX(I,J) 2 CONTINUE C UNTRANSFORM VARIABLES DO 10 J=1,N CALL DIVP(X(1,J),XNP1,TEMP,IERR) X(1,J)=TEMP(1) X(2,J)=TEMP(2) 10 CONTINUE C UNSCALE VARIABLES TEMP(1)=D1MACH(2) DO 30 J=1,N FAC=10.**FACV(J) DO 30 I=1,2 IF( (ABS(X(I,J))/TEMP(1))*FAC .LT. 1.0 ) X(I,J)=FAC*X(I,J) 30 CONTINUE RETURN END * SUBROUTINE PCGDS(NN,AA,LENAA,MAXA,PP,START,WORK,IFLAG) C C This subroutine solves a system of equations using the method C of Conjugate Gradients. C C The system to be solved is in the form Bx=b, where C C +-- --+ +- -+ C | | | | 0 | T = START(k), where C | AA | -PP | | ... | C B = | | | , b = | 0 | |START(k)|= max |START C +--------+-----+ +-----+ 1<=i<=NN+1 C | E(k)**t | | T | C +-- --+ +- -+ C C AA is an (NN x NN) symmetric matrix, PP is an (NN x 1) vector, C b is of length NN+1 and E(k)**t is the ( 1 x (NN+1) ) vector C consisting of all zeros, except for a '1' in its k-th position. C It is assumed that rank [AA,-PP]=NN and B is invertible. C C The system is solved by splitting B into two matrices M and L, where C C +- -+ +- -+ C | | | | | C | AA | c | | -PP-c | C M = | | | , L = u * [E(NN+1)**t], u = | | , C +------+---+ +-------+ C | c | d | | 0 | C +- -+ +- -+ C C E(NN+1) is the (NN+1) x 1 vector consisting of all zeros except for C a '1' in its last position, and x**t is the transpose of x. C C The final solution vector, x, is given by C C +- -+ C | [sol(u)]*[E(NN+1)**t] | C x = | I - ----------------------------- | * sol(b) C | {[(sol(u))**t]*E(NN+1)}+1.0 | C +- -+ C C where sol(a)=[M**(-1)]*a. The two systems (Mz=u, Mz=b) are solved C by a preconditioned conjugate gradient algorithm. C C C C Input variables: C C NN -- dimension of the matrix packed in AA. C C AA -- one dimensional real array containing the leading NN x NN C submatrix of B in packed skyline storage form. C C LENAA -- number of elements in the packed array AA. C C MAXA -- integer array used for specifying information about AA. C Using packed skyline storage, it has length NN+2, and C stores the indices of the diagonal elements within AA. C MAXA(NN+1) = LENAA + 1 and MAXA(NN+2) = LENAA + NN + 3 C (k as defined above) by convention. C (NOTE: The value of MAXA(NN+2) is set by this C subroutine when the preconditioning matrix Q is C initialized.) C C For example, using the packed storage scheme, C a symmetric 5 x 5 matrix of the form C C +-- --+ C | 1 3 0 0 0 | C | 3 2 0 7 0 | C | 0 0 4 6 0 | C | 0 7 6 5 9 | C | 0 0 0 9 8 | C +-- --+ C C would result in NN=5, LENAA=9, MAXA=(1,2,4,5,8,10,*), C and AA=(1,2,3,4,5,6,7,8,9). C C PP -- vector of length NN, used for (NN+1)st column of C augmented matrix B . C C START -- vector of length NN+1, normally the solution to the C previous linear system; used to determine the index k C C Output variables: C C START -- solution vector x of B x = b (defined above). C C IFLAG -- normally unchanged on output. If the conjugate gradie C iteration fails to converge in 10*(NN+1) iterations (m C likely due to a singular Jacobian matrix), PCGDS retur C with IFLAG = 4 , and does not compute x. C C Working storage: C C WORK -- array of length 6*(NN+1) + LENAA : C C WORK(1..NN+1) = temporary working storage; C C WORK(NN+2..2NN+2) = intermediate solution vector z for Mz= C input value is used as initial estimate for z; C C WORK(2NN+3..3NN+3) = intermediate solution vector z for Mz C input value is used as initial estimate for z; C C WORK(3NN+4..4NN+4) = storage for residual vectors; C C WORK(4NN+5..5NN+5) = storage for direction vectors; C C WORK(5NN+6.. * ) = storage for the preconditioning matri C Q, normally of length LENAA+NN+1. A storage scheme for C (and AA) other than the default packed skyline storage C scheme can be accomodated by simply extending the lengt C of WORK (and MAXA), and prodiving different versions of C the subroutines MULTDS, MFACDS, and QIMUDS. C C C Three user-defined subroutines are required: C C MULTDS(y,AA,x,MAXA,NN,LENAA) -- computes y = AA x . C C MFACDS(NN,Q,LENAA,MAXA) -- computes the preconditioning matrix C Q based on M. A copy of AA is placed in Q before the call; C after the call, it is assumed that Q contains some factorizat C for the preconditioning matrix Q. If no preconditioning is C required, MFACDS may be a dummy subroutine. C C QIMUDS(Q,f,MAXA,NN,LENAA) -- computes f := [Q**(-1)]*f for any C vector f, given the factorization of Q produced by subroutine C MFACDS. Again, if no preconditioning is required, QIMUDS C may be a dummy subroutine. C C C Subroutines and functions called: C C BLAS -- DAXPY, DCOPY, DDOT, DNRM2, DSCAL, IDAMAX C D1MACH,MULTDS,MFACDS,QIMUDS C C INTEGER IFLAG,IMAX,IND,J,K,LENAA,NN,MAXA(NN+2),NP1,NP2,N2P3, $ N3P4,N4P5,N5P6 DOUBLE PRECISION AA(LENAA),AB,AU,BB,BU,DZNRM,PBNPRD,PP(NN), $ PUNPRD,RBNPRD,RBTOL,RNPRD,RUNPRD,RUTOL,START(NN+1), $ STARTK,TEMP,UNRM,WORK(5*(NN+1)+LENAA+NN+1), $ ZLEN,ZTOL LOGICAL STILLU,STILLB C DOUBLE PRECISION D1MACH,DDOT,DNRM2 INTEGER IDAMAX C C C SET UP BASES FOR VECTORS STORED IN WORK ARRAY. C NP1=NN+1 NP2=NN+2 N2P3=(2*NN)+3 N3P4=(3*NN)+4 N4P5=(4*NN)+5 N5P6=(5*NN)+6 C C FIND THE ELEMENT OF LARGEST MAGNITUDE IN THE INITIAL VECTOR, AND C RECORD ITS POSITION IN K. C K=IDAMAX(NP1,START,1) STARTK=START(K) C C INITIALIZE Q, SET VALUES OF MAXA(NN+1) AND MAXA(NN+2), C COMPUTE PRECONDITIONER. C CALL DCOPY(LENAA,AA,1,WORK(N5P6),1) MAXA(NN+1)=LENAA+1 MAXA(NN+2)=LENAA+NN+3-K CALL MFACDS(NN,WORK(N5P6),LENAA,MAXA) C C COMPUTE ALL TOLERANCES NEEDED FOR EXIT CRITERIA. C CALL DCOPY(NN,PP,1,WORK,1) IF (K .LT. NP1) WORK(K)=WORK(K)+1.0D0 UNRM=DNRM2(NN,WORK,1) C IMAX=10*NP1 STILLU=.TRUE. STILLB=.TRUE. ZTOL=100.0*D1MACH(4) RBTOL=ZTOL*ABS(STARTK) RUTOL=ZTOL*UNRM C C COMPUTE INITIAL RESIDUAL VECTOR FOR THE SYSTEM M z = u . C CALL MULTDS(WORK(N3P4),AA,WORK(NP2),MAXA,NN,LENAA) WORK(N3P4+NN)=WORK(NP2+K-1) IND=N3P4+K-1 IF (K .LT. NP1) WORK(IND)=WORK(IND)+WORK(NP2+NN) CALL DSCAL(NP1,-1.0D0,WORK(N3P4),1) CALL DAXPY(NN,-1.0D0,PP,1,WORK(N3P4),1) IF (K .LT. NP1) WORK(IND)=WORK(IND)-1.0D0 CALL QIMUDS(WORK(N5P6),WORK(N3P4),MAXA,NN,LENAA) C C COMPUTE INITIAL DIRECTION VECTOR, ALL INNER PRODUCTS FOR M z = u . C CALL DCOPY(NP1,WORK(N3P4),1,WORK,1) CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA) CALL MULTDS(WORK(N4P5),AA,WORK,MAXA,NN,LENAA) WORK(N4P5+NN)=WORK(K) IF (K .LT. NP1) WORK(N4P5+K-1)=WORK(N4P5+K-1)+WORK(NP1) C RUNPRD=DDOT(NP1,WORK(N3P4),1,WORK(N3P4),1) PUNPRD=DDOT(NP1,WORK(N4P5),1,WORK(N4P5),1) C J=1 C C DO WHILE ((STILLU) .AND. (J .LE. IMAX)) 100 IF (.NOT. ((STILLU) .AND. (J .LE. IMAX)) ) GO TO 200 C C IF ||RESIDUAL|| IS STILL NOT SMALL ENOUGH, CONTINUE. IF (SQRT(RUNPRD) .GT. RUTOL) THEN IF (PUNPRD .EQ. 0.0) THEN CALL MULTDS(WORK(N3P4),AA,WORK(NP2),MAXA,NN,LENAA) WORK(N3P4+NN)=WORK(NP2+K-1) IND=N3P4+K-1 IF (K .LT. NP1) WORK(IND)=WORK(IND)+WORK(NP2+NN) CALL DSCAL(NP1,-1.0D0,WORK(N3P4),1) CALL DAXPY(NN,-1.0D0,PP,1,WORK(N3P4),1) IF (K .LT. NP1) WORK(N3P4+K-1)=WORK(N3P4+K-1)-1.0D0 CALL QIMUDS(WORK(N5P6),WORK(N3P4),MAXA,NN,LENAA) CALL DCOPY(NP1,WORK(N3P4),1,WORK,1) CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA) CALL MULTDS(WORK(N4P5),AA,WORK,MAXA,NN,LENAA) WORK(N4P5+NN)=WORK(K) IND=N4P5+K-1 IF (K .LT. NP1) WORK(IND)=WORK(IND)+WORK(NP1) RUNPRD=DDOT(NP1,WORK(N3P4),1,WORK(N3P4),1) PUNPRD=DDOT(NP1,WORK(N4P5),1,WORK(N4P5),1) IF (SQRT(RUNPRD) .LE. RUTOL) THEN STILLU=.FALSE. ENDIF ENDIF IF (STILLU) THEN C UPDATE SOLUTION VECTOR; COMPUTE ||DELTA SOL||/||UPDATED|| AU=RUNPRD/PUNPRD CALL DCOPY(NP1,WORK(NP2),1,WORK,1) CALL DAXPY(NP1,AU,WORK(N4P5),1,WORK(NP2),1) CALL DAXPY(NP1,-1.0D0,WORK(NP2),1,WORK,1) ZLEN=DNRM2(NP1,WORK(NP2),1) DZNRM=DNRM2(NP1,WORK,1) C IF RELATIVE CHANGE IN SOLUTIONS IS SMALL ENOUGH, EXIT. IF ( (DZNRM/ZLEN) .LT. ZTOL) STILLU=.FALSE. ENDIF ELSE STILLU=.FALSE. ENDIF C C IF NO EXIT CRITERIA FOR Mz=u HAVE BEEN MET, CONTINUE. IF (STILLU) THEN C UPDATE RESIDUAL VECTOR; COMPUTE (RNEW,RNEW), ||RNEW|| . CALL MULTDS(WORK,AA,WORK(N4P5),MAXA,NN,LENAA) WORK(NP1)=WORK(N4P5+K-1) IF (K .LT. NP1) WORK(K)=WORK(K)+WORK(N4P5+NN) CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA) CALL DAXPY(NP1,-AU,WORK,1,WORK(N3P4),1) RNPRD=DDOT(NP1,WORK(N3P4),1,WORK(N3P4),1) C UPDATE DIRECTION VECTOR; COMPUTE (PNEW,PNEW). BU=RNPRD/RUNPRD RUNPRD=RNPRD CALL DCOPY(NP1,WORK(N3P4),1,WORK,1) CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA) CALL MULTDS(START,AA,WORK,MAXA,NN,LENAA) START(NP1)=WORK(K) IF (K .LT. NP1) START(K)=START(K)+WORK(NP1) CALL DAXPY(NP1,BU,WORK(N4P5),1,START,1) CALL DCOPY(NP1,START,1,WORK(N4P5),1) PUNPRD=DDOT(NP1,WORK(N4P5),1,WORK(N4P5),1) ENDIF C J=J+1 GO TO 100 200 CONTINUE C END DO C C SET ERROR FLAG IF THE CONJUGATE GRADIENT ITERATION DID NOT CONVERG C IF (J .GT. IMAX) THEN IFLAG=4 RETURN ENDIF C C COMPUTE INITIAL RESIDUAL VECTOR FOR THE SYSTEM M z = b . C CALL MULTDS(WORK(N3P4),AA,WORK(N2P3),MAXA,NN,LENAA) WORK(N3P4+NN)=WORK(N2P3+K-1) IND=N3P4+K-1 IF (K .LT. NP1) WORK(IND)=WORK(IND)+WORK(N2P3+NN) CALL DSCAL(NP1,-1.0D0,WORK(N3P4),1) WORK(N3P4+NN)=STARTK+WORK(N3P4+NN) CALL QIMUDS(WORK(N5P6),WORK(N3P4),MAXA,NN,LENAA) C C COMPUTE INITIAL DIRECTION VECTOR, ALL INNER PRODUCTS FOR M z = b . C CALL DCOPY(NP1,WORK(N3P4),1,WORK,1) CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA) CALL MULTDS(WORK(N4P5),AA,WORK,MAXA,NN,LENAA) WORK(N4P5+NN)=WORK(K) IF (K .LT. NP1) WORK(N4P5+K-1)=WORK(N4P5+K-1)+WORK(NP1) C RBNPRD=DDOT(NP1,WORK(N3P4),1,WORK(N3P4),1) PBNPRD=DDOT(NP1,WORK(N4P5),1,WORK(N4P5),1) C J=1 C C DO WHILE ( STILLB .AND. (J .LE. IMAX) ) 300 IF (.NOT. ( STILLB .AND. (J .LE. IMAX) ) ) GO TO 400 C C IF ||RESIDUAL|| IS STILL NOT SMALL ENOUGH, CONTINUE. IF (SQRT(RBNPRD) .GT. RBTOL) THEN IF (PBNPRD .EQ. 0.0) THEN CALL MULTDS(WORK(N3P4),AA,WORK(N2P3),MAXA,NN,LENAA) WORK(N3P4+NN)=WORK(N2P3+K-1) IND=N3P4+K-1 IF (K .LT. NP1) WORK(IND)=WORK(IND)+WORK(N2P3+NN) CALL DSCAL(NP1,-1.0D0,WORK(N3P4),1) WORK(N3P4+NN)=STARTK+WORK(N3P4+NN) CALL QIMUDS(WORK(N5P6),WORK(N3P4),MAXA,NN,LENAA) CALL DCOPY(NP1,WORK(N3P4),1,WORK,1) CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA) CALL MULTDS(WORK(N4P5),AA,WORK,MAXA,NN,LENAA) WORK(N4P5+NN)=WORK(K) IND=N4P5+K-1 IF (K .LT. NP1) WORK(IND)=WORK(IND)+WORK(NP1) RBNPRD=DDOT(NP1,WORK(N3P4),1,WORK(N3P4),1) PBNPRD=DDOT(NP1,WORK(N4P5),1,WORK(N4P5),1) IF (SQRT(RBNPRD) .LE. RBTOL) THEN STILLB=.FALSE. ENDIF ENDIF IF (STILLB) THEN C UPDATE SOLUTION VECTOR; COMPUTE ||DELTA SOL||/||UPDATED|| AB=RBNPRD/PBNPRD CALL DCOPY(NP1,WORK(N2P3),1,WORK,1) CALL DAXPY(NP1,AB,WORK(N4P5),1,WORK(N2P3),1) CALL DAXPY(NP1,-1.0D0,WORK(N2P3),1,WORK,1) ZLEN=DNRM2(NP1,WORK(N2P3),1) DZNRM=DNRM2(NP1,WORK,1) C IF RELATIVE CHANGE IN SOLUTIONS IS SMALL ENOUGH, EXIT. IF ( (DZNRM/ZLEN) .LT. ZTOL) STILLB=.FALSE. ENDIF ELSE STILLB=.FALSE. ENDIF C C IF NO EXIT CRITERIA FOR Mz=b HAVE BEEN MET, CONTINUE. IF (STILLB) THEN C UPDATE RESIDUAL VECTOR; COMPUTE (RNEW,RNEW), ||RNEW|| . CALL MULTDS(WORK,AA,WORK(N4P5),MAXA,NN,LENAA) WORK(NP1)=WORK(N4P5+K-1) IF (K .LT. NP1) WORK(K)=WORK(K)+WORK(N4P5+NN) CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA) CALL DAXPY(NP1,-AB,WORK,1,WORK(N3P4),1) RNPRD=DDOT(NP1,WORK(N3P4),1,WORK(N3P4),1) C UPDATE DIRECTION VECTOR; COMPUTE (PNEW,PNEW). BB=RNPRD/RBNPRD RBNPRD=RNPRD CALL DCOPY(NP1,WORK(N3P4),1,WORK,1) CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA) CALL MULTDS(START,AA,WORK,MAXA,NN,LENAA) START(NP1)=WORK(K) IF (K .LT. NP1) START(K)=START(K)+WORK(NP1) CALL DAXPY(NP1,BB,WORK(N4P5),1,START,1) CALL DCOPY(NP1,START,1,WORK(N4P5),1) PBNPRD=DDOT(NP1,WORK(N4P5),1,WORK(N4P5),1) ENDIF C J=J+1 GO TO 300 400 CONTINUE C END DO C C SET ERROR FLAG IF THE CONJUGATE GRADIENT ITERATION DID NOT CONVERG C IF (J .GT. IMAX) THEN IFLAG=4 RETURN ENDIF C C COMPUTE FINAL SOLUTION VECTOR X, RETURN IT IN START. C TEMP=-WORK(N2P3+NN)/(1.0D0+WORK(NP2+NN)) CALL DCOPY(NP1,WORK(N2P3),1,START,1) CALL DAXPY(NP1,TEMP,WORK(NP2),1,START,1) C RETURN END SUBROUTINE PCGNS(NN,AA,LENAA,MAXA,PP,RHO,START,WORK,IFLAG) C C This subroutine solves a system of equations using the method C of Conjugate Gradients. C C The system to be solved is in the form Bx=b, where C C +-- --+ +- -+ C | | | | | T = START(k), where C | AA | -PP | | -RHO | C B = | | | , b = | | |START(k)|= max |START( C +--------+-----+ +------+ 1<=i<=NN+1 C | E(k)**t | | T | C +-- --+ +- -+ C C AA is an (NN x NN) symmetric matrix, PP, RHO are (NN x 1) vectors, C b is of length NN+1 and E(k)**t is the ( 1 x (NN+1) ) vector C consisting of all zeros, except for a '1' in its k-th position. C It is assumed that rank [AA,-PP]=NN and B is invertible. C C The system is solved by splitting B into two matrices M and L, where C C +- -+ +- -+ C | | | | | C | AA | c | | -PP-c | C M = | | | , L = u * [E(NN+1)**t], u = | | , C +------+---+ +-------+ C | c | d | | 0 | C +- -+ +- -+ C C E(NN+1) is the (NN+1) x 1 vector consisting of all zeros except for C a '1' in its last position, and x**t is the transpose of x. C C The final solution vector, x, is given by C C +- -+ C | [sol(u)]*[E(NN+1)**t] | C x = | I - ----------------------------- | * sol(b) C | {[(sol(u))**t]*E(NN+1)}+1.0 | C +- -+ C C where sol(a)=[M**(-1)]*a. The two systems (Mz=u, Mz=b) are solved C by a preconditioned conjugate gradient algorithm. C C C C Input variables: C C NN -- dimension of the matrix packed in AA. C C AA -- one dimensional real array containing the leading NN x NN C submatrix of B in packed skyline storage form. C C LENAA -- number of elements in the packed array AA. C C MAXA -- integer array used for specifying information about AA. C Using packed skyline storage, it has length NN+2, and C stores the indices of the diagonal elements within AA. C MAXA(NN+1) = LENAA + 1 and MAXA(NN+2) = LENAA + NN + 3 C (k as defined above) by convention. C (NOTE: The value of MAXA(NN+2) is set by this C subroutine when the preconditioning matrix Q is C initialized.) C C For example, using the packed storage scheme, C a symmetric 5 x 5 matrix of the form C C +-- --+ C | 1 3 0 0 0 | C | 3 2 0 7 0 | C | 0 0 4 6 0 | C | 0 7 6 5 9 | C | 0 0 0 9 8 | C +-- --+ C C would result in NN=5, LENAA=9, MAXA=(1,2,4,5,8,10,*), C and AA=(1,2,3,4,5,6,7,8,9). C C PP -- vector of length NN, used for (NN+1)st column of C augmented matrix B . C C RHO -- vector of length NN, negative of top part of right hand C side b . C C START -- vector of length NN+1, normally the solution to the C previous linear system; used to determine the index k C C Output variables: C C START -- solution vector x of B x = b (defined above). C C IFLAG -- normally unchanged on output. If the conjugate gradie C iteration fails to converge in 10*(NN+1) iterations (m C likely due to a singular Jacobian matrix), PCGNS retur C with IFLAG = 4 , and does not compute x. C C Working storage: C C WORK -- array of length 6*(NN+1) + LENAA : C C WORK(1..NN+1) = temporary working storage; C C WORK(NN+2..2NN+2) = intermediate solution vector z for Mz= C input value is used as initial estimate for z; C C WORK(2NN+3..3NN+3) = intermediate solution vector z for Mz C input value is used as initial estimate for z; C C WORK(3NN+4..4NN+4) = storage for residual vectors; C C WORK(4NN+5..5NN+5) = storage for direction vectors; C C WORK(5NN+6.. * ) = storage for the preconditioning matri C Q, normally of length LENAA+NN+1. A storage scheme for C (and AA) other than the default packed skyline storage C scheme can be accomodated by simply extending the lengt C of WORK (and MAXA), and prodiving different versions of C the subroutines MULTDS, MFACDS, and QIMUDS. C C C Three user-defined subroutines are required: C C MULTDS(y,AA,x,MAXA,NN,LENAA) -- computes y = AA x . C C MFACDS(NN,Q,LENAA,MAXA) -- computes the preconditioning matrix C Q based on M. A copy of AA is placed in Q before the call; C after the call, it is assumed that Q contains some factorizat C for the preconditioning matrix Q. If no preconditioning is C required, MFACDS may be a dummy subroutine. C C QIMUDS(Q,f,MAXA,NN,LENAA) -- computes f := [Q**(-1)]*f for any C vector f, given the factorization of Q produced by subroutine C MFACDS. Again, if no preconditioning is required, QIMUDS C may be a dummy subroutine. C C C Subroutines and functions called: C C BLAS -- DAXPY, DCOPY, DDOT, DNRM2, DSCAL, IDAMAX C D1MACH,MULTDS,MFACDS,QIMUDS C C INTEGER IFLAG,IMAX,IND,J,K,LENAA,NN,MAXA(NN+2),NP1,NP2,N2P3, $ N3P4,N4P5,N5P6 DOUBLE PRECISION AA(LENAA),AB,AU,BB,BU,DZNRM,PBNPRD,PP(NN), $ PUNPRD,RBNPRD,RBTOL,RHO(NN),RNPRD,RUNPRD,RUTOL, $ START(NN+1),STARTK,TEMP,UNRM,WORK(5*(NN+1)+LENAA+NN+1), $ ZLEN,ZTOL LOGICAL STILLU,STILLB C DOUBLE PRECISION D1MACH,DDOT,DNRM2 INTEGER IDAMAX C C C SET UP BASES FOR VECTORS STORED IN WORK ARRAY. C NP1=NN+1 NP2=NN+2 N2P3=(2*NN)+3 N3P4=(3*NN)+4 N4P5=(4*NN)+5 N5P6=(5*NN)+6 C C FIND THE ELEMENT OF LARGEST MAGNITUDE IN THE INITIAL VECTOR, AND C RECORD ITS POSITION IN K. C K=IDAMAX(NP1,START,1) STARTK=START(K) C C INITIALIZE Q, SET VALUES OF MAXA(NN+1) AND MAXA(NN+2), C COMPUTE PRECONDITIONER. C CALL DCOPY(LENAA,AA,1,WORK(N5P6),1) MAXA(NN+1)=LENAA+1 MAXA(NN+2)=LENAA+NN+3-K CALL MFACDS(NN,WORK(N5P6),LENAA,MAXA) C C COMPUTE ALL TOLERANCES NEEDED FOR EXIT CRITERIA. C CALL DCOPY(NN,PP,1,WORK,1) IF (K .LT. NP1) WORK(K)=WORK(K)+1.0D0 UNRM=DNRM2(NN,WORK,1) C IMAX=10*NP1 STILLU=.TRUE. STILLB=.TRUE. ZTOL=100.0*D1MACH(4) RBTOL=ZTOL*SQRT(STARTK**2 + DNRM2(NN,RHO,1)**2) RUTOL=ZTOL*UNRM C C COMPUTE INITIAL RESIDUAL VECTOR FOR THE SYSTEM M z = u . C CALL MULTDS(WORK(N3P4),AA,WORK(NP2),MAXA,NN,LENAA) WORK(N3P4+NN)=WORK(NP2+K-1) IND=N3P4+K-1 IF (K .LT. NP1) WORK(IND)=WORK(IND)+WORK(NP2+NN) CALL DSCAL(NP1,-1.0D0,WORK(N3P4),1) CALL DAXPY(NN,-1.0D0,PP,1,WORK(N3P4),1) IF (K .LT. NP1) WORK(IND)=WORK(IND)-1.0D0 CALL QIMUDS(WORK(N5P6),WORK(N3P4),MAXA,NN,LENAA) C C COMPUTE INITIAL DIRECTION VECTOR, ALL INNER PRODUCTS FOR M z = u . C CALL DCOPY(NP1,WORK(N3P4),1,WORK,1) CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA) CALL MULTDS(WORK(N4P5),AA,WORK,MAXA,NN,LENAA) WORK(N4P5+NN)=WORK(K) IF (K .LT. NP1) WORK(N4P5+K-1)=WORK(N4P5+K-1)+WORK(NP1) C RUNPRD=DDOT(NP1,WORK(N3P4),1,WORK(N3P4),1) PUNPRD=DDOT(NP1,WORK(N4P5),1,WORK(N4P5),1) C J=1 C C DO WHILE ((STILLU) .AND. (J .LE. IMAX)) 100 IF (.NOT. ((STILLU) .AND. (J .LE. IMAX)) ) GO TO 200 C C IF ||RESIDUAL|| IS STILL NOT SMALL ENOUGH, CONTINUE. IF (SQRT(RUNPRD) .GT. RUTOL) THEN IF (PUNPRD .EQ. 0.0) THEN CALL MULTDS(WORK(N3P4),AA,WORK(NP2),MAXA,NN,LENAA) WORK(N3P4+NN)=WORK(NP2+K-1) IND=N3P4+K-1 IF (K .LT. NP1) WORK(IND)=WORK(IND)+WORK(NP2+NN) CALL DSCAL(NP1,-1.0D0,WORK(N3P4),1) CALL DAXPY(NN,-1.0D0,PP,1,WORK(N3P4),1) IF (K .LT. NP1) WORK(N3P4+K-1)=WORK(N3P4+K-1)-1.0D0 CALL QIMUDS(WORK(N5P6),WORK(N3P4),MAXA,NN,LENAA) CALL DCOPY(NP1,WORK(N3P4),1,WORK,1) CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA) CALL MULTDS(WORK(N4P5),AA,WORK,MAXA,NN,LENAA) WORK(N4P5+NN)=WORK(K) IND=N4P5+K-1 IF (K .LT. NP1) WORK(IND)=WORK(IND)+WORK(NP1) RUNPRD=DDOT(NP1,WORK(N3P4),1,WORK(N3P4),1) PUNPRD=DDOT(NP1,WORK(N4P5),1,WORK(N4P5),1) IF (SQRT(RUNPRD) .LE. RUTOL) THEN STILLU=.FALSE. ENDIF ENDIF IF (STILLU) THEN C UPDATE SOLUTION VECTOR; COMPUTE ||DELTA SOL||/||UPDATED|| AU=RUNPRD/PUNPRD CALL DCOPY(NP1,WORK(NP2),1,WORK,1) CALL DAXPY(NP1,AU,WORK(N4P5),1,WORK(NP2),1) CALL DAXPY(NP1,-1.0D0,WORK(NP2),1,WORK,1) ZLEN=DNRM2(NP1,WORK(NP2),1) DZNRM=DNRM2(NP1,WORK,1) C IF RELATIVE CHANGE IN SOLUTIONS IS SMALL ENOUGH, EXIT. IF ( (DZNRM/ZLEN) .LT. ZTOL) STILLU=.FALSE. ENDIF ELSE STILLU=.FALSE. ENDIF C C IF NO EXIT CRITERIA FOR Mz=u HAVE BEEN MET, CONTINUE. IF (STILLU) THEN C UPDATE RESIDUAL VECTOR; COMPUTE (RNEW,RNEW), ||RNEW|| . CALL MULTDS(WORK,AA,WORK(N4P5),MAXA,NN,LENAA) WORK(NP1)=WORK(N4P5+K-1) IF (K .LT. NP1) WORK(K)=WORK(K)+WORK(N4P5+NN) CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA) CALL DAXPY(NP1,-AU,WORK,1,WORK(N3P4),1) RNPRD=DDOT(NP1,WORK(N3P4),1,WORK(N3P4),1) C UPDATE DIRECTION VECTOR; COMPUTE (PNEW,PNEW). BU=RNPRD/RUNPRD RUNPRD=RNPRD CALL DCOPY(NP1,WORK(N3P4),1,WORK,1) CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA) CALL MULTDS(START,AA,WORK,MAXA,NN,LENAA) START(NP1)=WORK(K) IF (K .LT. NP1) START(K)=START(K)+WORK(NP1) CALL DAXPY(NP1,BU,WORK(N4P5),1,START,1) CALL DCOPY(NP1,START,1,WORK(N4P5),1) PUNPRD=DDOT(NP1,WORK(N4P5),1,WORK(N4P5),1) ENDIF C J=J+1 GO TO 100 200 CONTINUE C END DO C C SET ERROR FLAG IF THE CONJUGATE GRADIENT ITERATION DID NOT CONVERG C IF (J .GT. IMAX) THEN IFLAG=4 RETURN ENDIF C C COMPUTE INITIAL RESIDUAL VECTOR FOR THE SYSTEM M z = b . C CALL MULTDS(WORK(N3P4),AA,WORK(N2P3),MAXA,NN,LENAA) WORK(N3P4+NN)=WORK(N2P3+K-1) IND=N3P4+K-1 IF (K .LT. NP1) WORK(IND)=WORK(IND)+WORK(N2P3+NN) CALL DSCAL(NP1,-1.0D0,WORK(N3P4),1) CALL DAXPY(NN,-1.0D0,RHO,1,WORK(N3P4),1) WORK(N3P4+NN)=STARTK+WORK(N3P4+NN) CALL QIMUDS(WORK(N5P6),WORK(N3P4),MAXA,NN,LENAA) C C COMPUTE INITIAL DIRECTION VECTOR, ALL INNER PRODUCTS FOR M z = b . C CALL DCOPY(NP1,WORK(N3P4),1,WORK,1) CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA) CALL MULTDS(WORK(N4P5),AA,WORK,MAXA,NN,LENAA) WORK(N4P5+NN)=WORK(K) IF (K .LT. NP1) WORK(N4P5+K-1)=WORK(N4P5+K-1)+WORK(NP1) C RBNPRD=DDOT(NP1,WORK(N3P4),1,WORK(N3P4),1) PBNPRD=DDOT(NP1,WORK(N4P5),1,WORK(N4P5),1) C J=1 C C DO WHILE ( STILLB .AND. (J .LE. IMAX) ) 300 IF (.NOT. ( STILLB .AND. (J .LE. IMAX) ) ) GO TO 400 C C IF ||RESIDUAL|| IS STILL NOT SMALL ENOUGH, CONTINUE. IF (SQRT(RBNPRD) .GT. RBTOL) THEN IF (PBNPRD .EQ. 0.0) THEN CALL MULTDS(WORK(N3P4),AA,WORK(N2P3),MAXA,NN,LENAA) WORK(N3P4+NN)=WORK(N2P3+K-1) IND=N3P4+K-1 IF (K .LT. NP1) WORK(IND)=WORK(IND)+WORK(N2P3+NN) CALL DSCAL(NP1,-1.0D0,WORK(N3P4),1) CALL DAXPY(NN,-1.0D0,RHO,1,WORK(N3P4),1) WORK(N3P4+NN)=STARTK+WORK(N3P4+NN) CALL QIMUDS(WORK(N5P6),WORK(N3P4),MAXA,NN,LENAA) CALL DCOPY(NP1,WORK(N3P4),1,WORK,1) CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA) CALL MULTDS(WORK(N4P5),AA,WORK,MAXA,NN,LENAA) WORK(N4P5+NN)=WORK(K) IND=N4P5+K-1 IF (K .LT. NP1) WORK(IND)=WORK(IND)+WORK(NP1) RBNPRD=DDOT(NP1,WORK(N3P4),1,WORK(N3P4),1) PBNPRD=DDOT(NP1,WORK(N4P5),1,WORK(N4P5),1) IF (SQRT(RBNPRD) .LE. RBTOL) THEN STILLB=.FALSE. ENDIF ENDIF IF (STILLB) THEN C UPDATE SOLUTION VECTOR; COMPUTE ||DELTA SOL||/||UPDATED|| AB=RBNPRD/PBNPRD CALL DCOPY(NP1,WORK(N2P3),1,WORK,1) CALL DAXPY(NP1,AB,WORK(N4P5),1,WORK(N2P3),1) CALL DAXPY(NP1,-1.0D0,WORK(N2P3),1,WORK,1) ZLEN=DNRM2(NP1,WORK(N2P3),1) DZNRM=DNRM2(NP1,WORK,1) C IF RELATIVE CHANGE IN SOLUTIONS IS SMALL ENOUGH, EXIT. IF ( (DZNRM/ZLEN) .LT. ZTOL) STILLB=.FALSE. ENDIF ELSE STILLB=.FALSE. ENDIF C C IF NO EXIT CRITERIA FOR Mz=b HAVE BEEN MET, CONTINUE. IF (STILLB) THEN C UPDATE RESIDUAL VECTOR; COMPUTE (RNEW,RNEW), ||RNEW|| . CALL MULTDS(WORK,AA,WORK(N4P5),MAXA,NN,LENAA) WORK(NP1)=WORK(N4P5+K-1) IF (K .LT. NP1) WORK(K)=WORK(K)+WORK(N4P5+NN) CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA) CALL DAXPY(NP1,-AB,WORK,1,WORK(N3P4),1) RNPRD=DDOT(NP1,WORK(N3P4),1,WORK(N3P4),1) C UPDATE DIRECTION VECTOR; COMPUTE (PNEW,PNEW). BB=RNPRD/RBNPRD RBNPRD=RNPRD CALL DCOPY(NP1,WORK(N3P4),1,WORK,1) CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA) CALL MULTDS(START,AA,WORK,MAXA,NN,LENAA) START(NP1)=WORK(K) IF (K .LT. NP1) START(K)=START(K)+WORK(NP1) CALL DAXPY(NP1,BB,WORK(N4P5),1,START,1) CALL DCOPY(NP1,START,1,WORK(N4P5),1) PBNPRD=DDOT(NP1,WORK(N4P5),1,WORK(N4P5),1) ENDIF C J=J+1 GO TO 300 400 CONTINUE C END DO C C SET ERROR FLAG IF THE CONJUGATE GRADIENT ITERATION DID NOT CONVERG C IF (J .GT. IMAX) THEN IFLAG=4 RETURN ENDIF C C COMPUTE FINAL SOLUTION VECTOR X, RETURN IT IN START. C TEMP=-WORK(N2P3+NN)/(1.0D0+WORK(NP2+NN)) CALL DCOPY(NP1,WORK(N2P3),1,START,1) CALL DAXPY(NP1,TEMP,WORK(NP2),1,START,1) C RETURN END SUBROUTINE PCGQS(NN,AA,LENAA,MAXA,PP,YP,RHO,START,WORK,IFLAG) C C THIS SUBROUTINE SOLVES A SYSTEM OF EQUATION USING THE METHOD OF C CONJUGATE GRADIENTS. THE SYSTEM TO BE SOLVED IS IN THE FORM C C (AUG)*X = B, C C WHERE C C +-- --+ +- -+ C | | | | | C | AA | -PP | | | C AUG = | | | , B = | -RHO | C +--------------+ | | C | YP | | | C +-- --+ +- -+ C C C C THE SYSTEM IS SOLVED BY SPLITTING AUG INTO TWO MATRICES C AUG = M + L, WHERE C C +- -+ +- -+ C | | | | | C | AA | C | | -PP-C | C M = | | | , L = U * [E(NN+1)**T], U = | | , C +------+---+ +-------+ C | C | D | | 0 | C +- -+ +- -+ C C E(NN+1) IS THE (NN+1) X 1 VECTOR CONSISTING OF ALL ZEROS EXCEPT FOR C A '1' IN ITS LAST POSITION. C C THE FINAL SOLUTION VECTOR, X, IS GIVEN BY C C +- -+ C | [SOL(U)]*[E(NN+1)**T] | C X = | I - ----------------------------- | * SOL(B) C | {[(SOL(U))**T]*E(NN+1)}+1.0 | C +- -+ C C WHERE SOL(A)=[M**(-1)]*A. THE TWO SYSTEMS (MZ=U, MZ=B) ARE SOLVED C BY A PRECONDITIONED CONJUGATE GRADIENT ALGORITHM. C C C ON INPUT: C C NN = THE DIMENSION OF THE MATRIX PACKED IN AA. C C AA(1:LENAA) CONTAINS THE MATRIX AA, STORED IN PACKED SKYLINE C FORMAT. LENAA AND MAXA DESCRIBE THE DATA STRUCTURE. C C LENAA = THE LENGTH OF THE ONE-DIMENSIONAL ARRAY AA. C C MAXA(1:NN+2) IN ITS FIRST N+1 COMPONENTS CONTAINS THE INDICES OF C THE DIAGONAL ELEMENTS OF THE MATRIX STORED IN AA. C MAXA(NN+2) IS ASSIGNED THE VALUE LENNAA + NN + 2. C C AS AN EXAMPLE OF THE PACKED SKYLINE STORAGE FORMAT, CONSIDER THE C SYMMETRIC MATRIX C C C +-- --+ C | 1 3 0 0 0 | C | 3 2 0 7 0 | C | 0 0 4 6 0 | C | 0 7 6 5 9 | C | 0 0 0 9 8 | C +-- --+ C C THIS WOULD RESULT IN NN=5, LENAA=9, MAXA=(1,2,4,5,8,10,16), C AND AA=(1,2,3,4,5,6,7,8,9). C C PP(1:NN) = THE NEGATIVE OF THE LAST COLUMN OF AUG. C C YP(1:NN+1) = THE LAST ROW OF AUG. C C RHO(1:NN+1) = THE NEGATIVE OF THE RIGHT HAND SIDE OF THE EQUATION TO C BE SOLVED. C C WORK(1:6*(NN+1)+LENAA) IS A WORK ARRAY DIVIDED UP AS FOLLOWS: C C WORK(1:NN+1) = TEMPORARY WORKING STORAGE. C C WORK(NN+2:2*NN+2) = INTERMEDIATE SOLUTION VECTOR Z FOR MZ=U. C THE INPUT VALUE IS USED AS THE INITIAL ESTIMATE FOR Z. C C WORK(2*NN+3:3*NN+3) = INTERMEDIATE SOLUTION VECTOR Z FOR MZ=B. C C WORK(3*NN+4:4*NN+4) = STORAGE FOR THE RESIDUAL VECTORS. C C WORK(4*NN+5:5*NN+5) = STORAGE FOR THE DIRECTION VECTORS. C C WORK(5*NN+6:6*NN+6+LENAA) = STORAGE FOR THE PRECONDITIONING C MATRIX Q. C C C ON OUTPUT: C C NN, AA, LENAA, MAXA, PP, YP, AND RHO ARE UNCHANGED. C C START(1:N+1) CONTAINS THE SOLUTION VECTOR X. C C IFLAG IS UNCHANGED UNLESS THE CONJUGATE GRADIENT ITERATION C FAILS TO CONVERGE IN 10*(NN+1) ITERATIONS (MOST LIKELY DUE C TO A SINGULAR JACOBIAN MATRIX). IN THIS CASE, PCGQS RETURNS C IFLAG = 4, AND DOES NOT COMPUTE X. C C C CALLS D1MACH, DAXPY, DCOPY, DDOT, DNRM2, DSCAL, GMFADS, MULTDS, C SOLVDS. C C ***** DECLARATIONS ***** C C FUNCTION DECLARATIONS C DOUBLE PRECISION D1MACH, DDOT, DNRM2 C C LOCAL VARIABLES C DOUBLE PRECISION AB, AU, BB, BU, DZNRM, PBNPRD, PUNPRD, $ RBNPRD, RBTOL, RNPRD, RUNPRD, RUTOL, TEMP, ZLEN, ZTOL INTEGER DIR, IMAX, J, LENQ, NP1, Q, RES, ZB, ZU LOGICAL STILLU, STILLB C C SCALAR ARGUMENTS C INTEGER NN, LENAA, IFLAG C C ARRAY DECLARATIONS C DOUBLE PRECISION AA(LENAA), PP(NN), YP(NN+1), RHO(NN+1), $ START(NN+1), WORK(6*(NN+1)+LENAA) INTEGER MAXA(NN+2) C C ***** END OF DECLARATIONS ***** C C ***** FIRST EXECUTABLE STATEMENT ***** C C SET UP BASES FOR VECTORS STORED IN WORK ARRAY. C NP1=NN+1 ZU=NN+2 ZB=(2*NN)+3 RES=(3*NN)+4 DIR=(4*NN)+5 Q=(5*NN)+6 C C INITIALIZE PRECONDITIONING MATRIX Q, SET VALUES OF MAXA(NN+1) C AND MAXA(NN+2), COMPUTE PRECONDITIONER. C CALL DCOPY(LENAA,AA,1,WORK(Q),1) CALL DCOPY(NP1,YP,1,WORK(Q+LENAA),1) MAXA(NN+1)=LENAA+1 MAXA(NN+2)=LENAA+NN+2 LENQ = MAXA(NN+2)-1 CALL GMFADS(NP1,WORK(Q),LENQ,MAXA) C C COMPUTE ALL TOLERANCES NEEDED FOR EXIT CRITERIA. C CALL DCOPY(NN,PP,1,WORK,1) WORK(NP1)=0.0 CALL DAXPY(NP1,1.0D0,YP,1,WORK,1) IMAX=10*NP1 STILLU=.TRUE. STILLB=.TRUE. ZTOL=100.0*D1MACH(4) RUTOL=ZTOL*DNRM2(NP1,WORK,1) RBTOL=ZTOL*DNRM2(NP1,RHO,1) C C ***** END OF INITIALIZATION ***** C C ***** SOLVE SYSTEM M Z = U ***** C C COMPUTE INITIAL RESIDUAL VECTOR FOR THE SYSTEM M Z = U . C RES = (Q**(-1))*(U - M*Z.) * CALL MULTDS(WORK(RES),AA,WORK(ZU),MAXA,NN,LENAA) WORK(RES+NN)= DDOT(NN,YP,1,WORK(ZU),1) CALL DAXPY(NP1,WORK(ZU+NN),YP,1,WORK(RES),1) CALL DSCAL(NP1,-1.0D0,WORK(RES),1) CALL DAXPY(NN,-1.0D0,PP,1,WORK(RES),1) CALL DAXPY(NN,-1.0D0,YP,1,WORK(RES),1) CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK(RES)) C C COMPUTE INITIAL DIRECTION VECTOR. C DIR = (A**T)*(Q**(-T))*RES. C CALL DCOPY(NP1,WORK(RES),1,WORK,1) CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK) CALL MULTDS(WORK(DIR),AA,WORK,MAXA,NN,LENAA) WORK(DIR+NN)=DDOT(NN,YP,1,WORK,1) CALL DAXPY(NP1,WORK(NP1),YP,1,WORK(DIR),1) C C COMPUTE INITIAL INNER PRODUCTS. C RUNPRD=DDOT(NP1,WORK(RES),1,WORK(RES),1) PUNPRD=DDOT(NP1,WORK(DIR),1,WORK(DIR),1) C C REPEAT UNTIL CONVERGENCE OR TOO MANY ITERATIONS. C J=1 C C DO WHILE ((STILLU) .AND. (J .LE. IMAX)) 100 IF (.NOT. ((STILLU) .AND. (J .LE. IMAX)) ) GO TO 200 C C IF ||RESIDUAL|| IS STILL NOT SMALL ENOUGH, CONTINUE. C IF (SQRT(RUNPRD) .GT. RUTOL) THEN C C IF DIRECTION VECTOR IS ZERO, THEN RE-COMPUTE RESIDUAL, C DIRECTION VECTOR, AND INNER PRODUCTS FROM SCRATCH C (RATHER THAN FROM UPDATES OF PREVIOUS VALUES). C IF (PUNPRD .EQ. 0.0) THEN C C COMPUTE RESIDUAL. C CALL MULTDS(WORK(RES),AA,WORK(ZU),MAXA,NN,LENAA) WORK(RES+NN)= DDOT(NN,YP,1,WORK(ZU),1) CALL DAXPY(NP1,WORK(ZU+NN),YP,1,WORK(RES),1) CALL DSCAL(NP1,-1.0D0,WORK(RES),1) CALL DAXPY(NN,-1.0D0,PP,1,WORK(RES),1) CALL DAXPY(NN,-1.0D0,YP,1,WORK(RES),1) CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK(RES)) C C COMPUTE DIRECTION VECTOR. C CALL DCOPY(NP1,WORK(RES),1,WORK,1) CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK) CALL MULTDS(WORK(DIR),AA,WORK,MAXA,NN,LENAA) WORK(DIR+NN)=DDOT(NN,YP,1,WORK,1) CALL DAXPY(NP1,WORK(NP1),YP,1,WORK(DIR),1) C C COMPUTE INNER PRODUCTS C RUNPRD=DDOT(NP1,WORK(RES),1,WORK(RES),1) PUNPRD=DDOT(NP1,WORK(DIR),1,WORK(DIR),1) C C CHECK FOR CONVERGENCE. C IF (SQRT(RUNPRD) .LE. RUTOL) THEN STILLU=.FALSE. ENDIF ENDIF IF (STILLU) THEN C C UPDATE SOLUTION VECTOR. C Z = Z + AU*DIR, WHERE AU= RUNPRD/PUNPRD. C AU=RUNPRD/PUNPRD CALL DAXPY(NP1,AU,WORK(DIR),1,WORK(ZU),1) C C COMPUTE RELATIVE CHANGE IN THE SOLUTION. C DZNRM=AU*SQRT(PUNPRD) ZLEN=DNRM2(NP1,WORK(ZU),1) C C IF RELATIVE CHANGE IN SOLUTIONS IS SMALL ENOUGH, EXIT. C IF ( (DZNRM/ZLEN) .LT. ZTOL) STILLU=.FALSE. ENDIF ELSE STILLU=.FALSE. ENDIF C C IF NO EXIT CRITERIA FOR MZ=U HAVE BEEN MET, UPDATE RESIDUAL, C DIRECTION VECTORS, AND INNER PRODUCTS FOR NEXT ITERATION. C IF (STILLU) THEN C C UPDATE RESIDUAL VECTOR; COMPUTE . C RES = RES - AU*(Q**(-1))*M*DIR. C CALL MULTDS(WORK,AA,WORK(DIR),MAXA,NN,LENAA) WORK(NP1)=DDOT(NN,YP,1,WORK(DIR),1) CALL DAXPY(NP1,WORK(DIR+NN),YP,1,WORK,1) CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK) CALL DAXPY(NP1,-AU,WORK,1,WORK(RES),1) RNPRD=DDOT(NP1,WORK(RES),1,WORK(RES),1) C C UPDATE DIRECTION VECTOR; COMPUTE . C DIR = (M**T)*(Q**(-T))*RES + BU*DIR, C WHERE BU = RNPRD/RUNPRD. (NOTE: START IS USED AS C A WORK ARRAY HERE). C BU=RNPRD/RUNPRD RUNPRD=RNPRD CALL DCOPY(NP1,WORK(RES),1,WORK,1) CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK) CALL MULTDS(START,AA,WORK,MAXA,NN,LENAA) START(NP1)=DDOT(NN,YP,1,WORK,1) CALL DAXPY(NP1,WORK(NP1),YP,1,START,1) CALL DAXPY(NP1,BU,WORK(DIR),1,START,1) CALL DCOPY(NP1,START,1,WORK(DIR),1) PUNPRD=DDOT(NP1,WORK(DIR),1,WORK(DIR),1) ENDIF C J=J+1 GO TO 100 200 CONTINUE C END DO C C SET ERROR FLAG IF THE CONJUGATE GRADIENT ITERATION DID NOT CONVERGE. C IF (J .GT. IMAX) THEN IFLAG=4 RETURN ENDIF C C ***** END OF M Z = U SYSTEM ***** C C ***** SOLVE SYSTEM M Z = B ***** C C C COMPUTE INITIAL RESIDUAL VECTOR FOR THE SYSTEM M Z = B . C CALL MULTDS(WORK(RES),AA,WORK(ZB),MAXA,NN,LENAA) WORK(RES+NN)=DDOT(NN,YP,1,WORK(ZB),1) CALL DAXPY(NP1,WORK(ZB+NN),YP,1,WORK(RES),1) CALL DSCAL(NP1,-1.0D0,WORK(RES),1) CALL DAXPY(NP1,-1.0D0,RHO,1,WORK(RES),1) CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK(RES)) C C COMPUTE INITIAL DIRECTION VECTOR. C CALL DCOPY(NP1,WORK(RES),1,WORK,1) CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK) CALL MULTDS(WORK(DIR),AA,WORK,MAXA,NN,LENAA) WORK(DIR+NN)=DDOT(NN,YP,1,WORK,1) CALL DAXPY(NP1,WORK(NP1),YP,1,WORK(DIR),1) C C COMPUTE INITIAL INNER PRODUCTS. C RBNPRD=DDOT(NP1,WORK(RES),1,WORK(RES),1) PBNPRD=DDOT(NP1,WORK(DIR),1,WORK(DIR),1) C C REPEAT UNTIL CONVERGENCE, OR TOO MANY ITERATIONS. C J=1 C C DO WHILE ( STILLB .AND. (J .LE. IMAX) ) 300 IF (.NOT. ( STILLB .AND. (J .LE. IMAX) ) ) GO TO 400 C C IF ||RESIDUAL|| IS STILL NOT SMALL ENOUGH, CONTINUE. C IF (SQRT(RBNPRD) .GT. RBTOL) THEN C C IF DIRECTION VECTOR IS ZERO, RE-COMPUTE RESIDUAL, C DIRECTION VECTOR, AND INNER PRODUCTS FROM SCRATCH. C IF (PBNPRD .EQ. 0.0) THEN C C COMPUTE RESIDUAL. C CALL MULTDS(WORK(RES),AA,WORK(ZB),MAXA,NN,LENAA) WORK(RES+NN)=DDOT(NN,YP,1,WORK(ZB),1) CALL DAXPY(NP1,WORK(ZB+NN),YP,1,WORK(RES),1) CALL DSCAL(NP1,-1.0D0,WORK(RES),1) CALL DAXPY(NP1,-1.0D0,RHO,1,WORK(RES),1) CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK(RES)) C C COMPUTE DIRECTION VECTOR. C CALL DCOPY(NP1,WORK(RES),1,WORK,1) CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK) CALL MULTDS(WORK(DIR),AA,WORK,MAXA,NN,LENAA) WORK(DIR+NN)=DDOT(NN,YP,1,WORK,1) CALL DAXPY(NP1,WORK(NP1),YP,1,WORK(DIR),1) C C COMPUTE INNER PRODUCTS. C RBNPRD=DDOT(NP1,WORK(RES),1,WORK(RES),1) PBNPRD=DDOT(NP1,WORK(DIR),1,WORK(DIR),1) C C CHECK FOR CONVERGENCE. C IF (SQRT(RBNPRD) .LE. RBTOL) THEN STILLB=.FALSE. ENDIF ENDIF IF (STILLB) THEN C C UPDATE SOLUTION VECTOR. C Z = Z + AB*DIR, WHERE AB=RBNPRD/PBNPRD. C AB=RBNPRD/PBNPRD CALL DAXPY(NP1,AB,WORK(DIR),1,WORK(ZB),1) C C COMPUTE RELATIVE CHANGE IN SOLUTIONS. C DZNRM=AB*SQRT(PBNPRD) ZLEN=DNRM2(NP1,WORK(ZB),1) C C IF RELATIVE CHANGE IN SOLUTIONS IS SMALL ENOUGH, EXIT. C IF ( (DZNRM/ZLEN) .LT. ZTOL) STILLB=.FALSE. ENDIF ELSE STILLB=.FALSE. ENDIF C C IF NO EXIT CRITERIA FOR MZ=B HAVE BEEN MET, UPDATE RESIDUAL, C DIRECTION VECTORS, AND INNER PRODUCTS. C IF (STILLB) THEN C C UPDATE RESIDUAL VECTOR; COMPUTE . C RES = RES - AB*(Q**(-1))*M*DIR. C CALL MULTDS(WORK,AA,WORK(DIR),MAXA,NN,LENAA) WORK(NP1)=DDOT(NN,YP,1,WORK(DIR),1) CALL DAXPY(NP1,WORK(DIR+NN),YP,1,WORK,1) CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK) CALL DAXPY(NP1,-AB,WORK,1,WORK(RES),1) RNPRD=DDOT(NP1,WORK(RES),1,WORK(RES),1) C C UPDATE DIRECTION VECTOR; COMPUTE . C DIR = (M**T)*(Q**(-T))*RES + BB*DIR, C WHERE BB=RNPRD/RBNPRD. C (NOTE: START IS USED AS A WORK ARRAY HERE). C BB=RNPRD/RBNPRD RBNPRD=RNPRD CALL DCOPY(NP1,WORK(RES),1,WORK,1) CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK) CALL MULTDS(START,AA,WORK,MAXA,NN,LENAA) START(NP1)=DDOT(NN,YP,1,WORK,1) CALL DAXPY(NP1,WORK(NP1),YP,1,START,1) CALL DAXPY(NP1,BB,WORK(DIR),1,START,1) CALL DCOPY(NP1,START,1,WORK(DIR),1) PBNPRD=DDOT(NP1,WORK(DIR),1,WORK(DIR),1) ENDIF C J=J+1 GO TO 300 400 CONTINUE C END DO C C SET ERROR FLAG IF THE CONJUGATE GRADIENT ITERATION DID NOT CONVERGE. C IF (J .GT. IMAX) THEN IFLAG=4 RETURN ENDIF C C ***** END OF M Z = B SYSTEM ***** C C COMPUTE FINAL SOLUTION VECTOR X, AND RETURN IT IN START. C TEMP=-WORK(ZB+NN)/(1.0D0+WORK(ZU+NN)) CALL DCOPY(NP1,WORK(ZB),1,START,1) CALL DAXPY(NP1,TEMP,WORK(ZU),1,START,1) C RETURN END SUBROUTINE POLSYS(N,NUMT,COEF,KDEG,IFLG1,IFLG2,EPSBIG,EPSSML, $ SSPAR,NUMRR,NN,MMAXT,TTOTDG,LENWK,LENIWK, $ LAMBDA,ROOTS,ARCLEN,NFE,WK,IWK) C C POLSYS FINDS ALL (COMPLEX) SOLUTIONS TO A SYSTEM C F(X)=0 OF N POLYNOMIAL EQUATIONS IN N UNKNOWNS C WITH REAL COEFFICIENTS. IF IFLG=10 OR IFLG=11, POLSYS C RETURNS THE SOLUTIONS AT INFINITY ALSO. C C THE SYSTEM F(X)=0 IS DESCRIBED VIA THE COEFFICENTS, C "COEF", AND THE PARAMETERS "N, NUMT, KDEG", AS FOLLOWS. C C C NUMT(J) C C F(J) = SUM COEF(J,K) * X(1)**KDEG(J,1,K)...X(N)**KDEG(J,N,K) C C K=1 C C FOR J=1, ..., N. C C C POLSYS HAS TWO MAIN RUN OPTIONS: AUTOMATIC SCALING AND C THE PROJECTIVE TRANSFORMATION. THESE ARE EVOKED VIA THE C FLAG "IFLG1", AS DESCRIBED BELOW. THE OTHER INPUT C PARAMETERS ARE THE SAME WHETHER ONE OR BOTH OF THESE OPTIONS C ARE SPECIFIED, AND THE OUTPUT IS ALWAYS RETURNED UNSCALED C AND UNTRANSFORMED. C C IF AUTOMATIC SCALING IS SPECIFIED, THEN THE INPUT C COEFFICIENTS ARE MODIFIED BY SUBROUTINE SCLGNP . THE PROBLEM C IS SOLVED WITH THE SCALED COEFFICIENTS AND SCALED VARIABLES. C THE COEFFICIENTS ARE RETURNED SCALED. C C IF THE PROJECTIVE TRANSFORMATION IS SPECIFIED, THEN C ESSENTIALLY THE SYSTEM IS REFORMULATED IN HOMOGENEOUS C COORDINATES, Z(1), ..., Z(N+1), AND SOLVED IN COMPLEX C PROJECTIVE SPACE. THE RESULTING SOLUTIONS ARE C UNTRANSFORMED VIA C C X(J) = Z(J)/Z(N+1) J=1, ..., N. C C ON RETURN, C C ROOTS(1,J,M) = REAL PART OF X(J) FOR THE M-TH PATH, C C ROOTS(2,J,M) = IMAGINARY PART OF X(J) FOR THE M-TH PATH, C C FOR J=1, ..., N, AND C C ROOTS(1,N+1,M) = REAL PART OF Z(N+1) FOR THE M-TH PATH, C C ROOTS(2,N+1,M) = IMAGINARY PART OF Z(N+1) FOR THE M-TH PATH. C C IF ROOTS(*,N+1,M) IS SMALL, THEN THE ASSOCIATED SOLUTION C SHOULD BE REGARDED AS BEING "NEAR INFINITY". NOTE THAT, C WHEN THE PROJECTIVE TRANSFORMATION HAS BEEN SPECIFIED, THE C ROOTS VALUES HAVE BEEN UNTRANSFORMED -- THAT IS, DIVIDED C THROUGH BY Z(N+1) -- UNLESS SUCH DIVISION WOULD HAVE CAUSED C OVERFLOW. IN THIS LATTER CASE, THE AFFECTED COMPONENTS OF C ROOTS ARE SET TO THE LARGEST FLOATING POINT NUMBER (MACHINE C INFINITY). C C THE CODE CAN BE MODIFIED EASILY TO SOLVE SYSTEMS WITH COMPLEX C COEFFICIENTS, COEF . ONLY THE SUBROUTINES INITP AND FFUNP C NEED BE CHANGED. C C THE FORTRAN COMPLEX DECLARATION IS NOT USED IN POLSYS. C COMPLEX VARIABLES ARE REPRESENTED BY REAL ARRAYS WITH FIRST C INDEX DIMENSIONED 2 AND COMPLEX OPERATIONS ARE EVOKED BY C SUBROUTINE CALLS. C C THE TOTAL NUMBER OF PATHS THAT WILL THE TRACKED (IF C IFLG2(M)=-2 FOR ALL M) IS EQUAL TO THE "TOTAL DEGREE" OF THE C SYSTEM, TOTDG. TOTDG IS EQUAL TO THE PRODUCTS OF THE C DEGREES OF ALL THE EQUATIONS IN THE SYSTEM. THE DEGREE OF C AN EQUATION IS THE MAXIMUM OF THE DEGREES OF ITS TERMS. THE C DEGREE OF A TERM IS THE SUM OF THE DEGREES OF THE VARIABLES. C THUS, TOTDG = IDEG(1) * ... * IDEG(N) WHERE IDEG(J) = C MAX {JDEG(J,K) | K=1,...,NUMT(J)} WHERE JDEG(J,K) = KDEG(J,1,K) + C ... + KDEG(J,N,K). C C IFLG1 DETERMINES WHETHER THE SYSTEM IS TO BE AUTOMATICALLY C SCALED BY POLSYS AND WHETHER THE PROJECTIVE TRANSFORMATION C OF THE SYSTEM IS TO BE AUTOMATICALLY EVOKED BY POLSYS. SEE C "ON INPUT" BELOW. C C IFLG2, EPSBIG, EPSSML, AND SSPAR TELL THE PATH TRACKER C POLYNF WHICH PATHS TO TRACK AND SET PARAMETERS FOR THE PATH C TRACKER. C C NUMRR TELLS POLSYS HOW MANY MULTIPLES OF 1000 STEPS TO TRY C BEFORE ABANDONING A PATH. C C NN, MMAXT, TTOTDG, LENWK, LENIWK GIVE THE DIMENSIONS OF ARRAYS. C C THE OUTPUT CONSISTS OF IFLG1, AND OF LAMBDA, ROOTS, ARCLEN, AND C NFE FOR EACH PATH. IFLG1 RETURNS INPUT DATA ERROR INFORMATION. C ROOTS GIVES THE SOLUTIONS THEMSELVES, WHILE LAMBDA, ARCLEN, C AND NFE GIVE INFORMATION ABOUT THE ASSOCIATED PATHS. C C THE FOLLOWING SUBROUTINES ARE USED DIRECTLY OR INDIRECTLY BY C POLSYS: C SPECIAL FOR POLSYS: C POLYP , INITP , STRPTP , C OTPUTP , RHO , RHOJAC , C HFUNP , HFUN1P , GFUNP , FFUNP , C MULP , POWP , DIVP, C SCLGNP. C FROM THE GENERAL HOMPACK ROUTINES: C POLYNF , STEPNF , TANGNF , ROOTNF , ROOT , C QRFAQF, QRSLQF , D1MACH , DDOT , DNRM2. C C ON INPUT: C C N IS THE NUMBER OF EQUATIONS AND VARIABLES. C C NUMT(1:NN) IS AN INTEGER ARRAY. NUMT(J) IS THE NUMBER OF TERMS C IN THE JTH EQUATION FOR J=1 TO N. C C COEF(1:NN,1:MMAXT) IS A REAL ARRAY. COEF(J,K) IS C THE K-TH COEFFICIENT OF THE J-TH EQUATION FOR J=1 TO N, C K=1 TO NUMT(J). C C KDEG(1:NN,1:NN+1,1:MMAXT) IS AN INTEGER ARRAY. C KDEG(J,L,K) IS THE DEGREE OF THE L-TH VARIABLE IN THE K-TH C TERM OF THE J-TH EQUATION FOR J=1 TO N, L=1 TO N, K=1 TO NUMT(J). C C IFLG1 = C 00 IF THE PROBLEM IS TO BE SOLVED WITHOUT C CALLING POLSYS' SCALING ROUTINE, SCLGNP, AND C WITHOUT USING THE PROJECTIVE TRANSFORMTION. C C 01 IF SCALING BUT NO PROJECTIVE TRANSFORMATION IS TO BE USED. C C 10 IF NO SCALING BUT PROJECTIVE TRANSFORMATION IS TO BE USED. C C 11 IF BOTH SCALING AND PROJECTIVE TRANSFORMATION ARE TO BE USED. C C IFLG2(1:TTOTDG) IS AN INTEGER ARRAY. IF IFLG2(M) = -2, THEN THE C M-TH PATH IS TRACKED. OTHERWISE THE M-TH PATH IS SKIPPED. C THUS, TO FIND ALL SOLUTIONS SET IFLG2(M) = -2 FOR M=1,...,TOTDG. C SELECTED PATHS CAN BE RERUN BY SETTING IFLG2(M)=-2 FOR C THE PATHS TO BE RERUN AND IFLG(M).NE.-2 FOR THE OTHERS. C C EPSBIG IS THE LOCAL ERROR TOLERANCE ALLOWED THE PATH TRACKER ALONG C THE PATH. ARCRE AND ARCAE (IN POLYNF ) ARE SET TO EPSBIG. C C EPSSML IS THE ACCURACY DESIRED FOR THE FINAL SOLUTION. ANSRE AND C ANSAE (IN POLYNF ) ARE SET TO EPSSML. C C SSPAR(1:8) = (LIDEAL, RIDEAL, DIDEAL, HMIN, HMAX, BMIN, BMAX, P) IS C A VECTOR OF PARAMETERS USED FOR THE OPTIMAL STEP SIZE ESTIMATION. C IF SSPAR(J) .LE. 0.0 ON INPUT, IT IS RESET TO A DEFAULT VALUE C BY POLYNF . OTHERWISE THE INPUT VALUE OF SSPAR(J) IS USED. C SEE THE COMMENTS IN POLYNF AND IN STEPNF FOR MORE INFORMATION C ABOUT THESE CONSTANTS. C C NUMRR IS THE NUMBER OF MULTIPLES OF 1000 STEPS THAT WILL BE TRIED C BEFORE ABANDONING A PATH. C C NN IS THE DECLARED DIMENSION OF NUMT AND OF THE C FIRST INDEX OF COEF AND KDEG . THE SECOND INDEX OF C KDEG AND ROOTS IS DIMENSIONED NN+1. NN MUST C BE GREATER THAN OR EQUAL TO N. C C MMAXT IS THE DECLARED DIMENSION OF THE SECOND INDEX OF C COEF AND THE THIRD INDEX OF KDEG. MMAXT MUST BE C GREATER THAN OR EQUAL TO THE MAXIMUM NUMBER OF C TERMS IN EACH EQUATION. IN OTHER WORDS, C MMAXT .GE. MAX {NUMT(J) | J=1, ..., N} . C C TTOTDG IS THE DECLARED DIMENSION OF IFLG2 , LAMBDA , ARCLEN , C NFE , AND OF THE THIRD INDEX OF ROOTS. TTOTDG C MUST BE GREATER THAN OR EQUAL TO TOTDG, THE TOTAL C DEGREE OF THE SYSTEM. C C LENWK IS THE DIMENSION OF THE WORKSPACE WK . LENWK MUST C BE GREATER THAN OR EQUAL TO C 21 + 61*N + 10*N**2 + 7*N*MMAXT + 4*N**2*MMAXT. C C LENIWK IS THE DIMENSION OF THE WORKSPACE IWK . LENIWK MUST BE C GREATER THAN OR EQUAL TO 43 + 7*N + N*(N+1)*MMAXT. C C C ON OUTPUT: C C N, NUMT, COEF, KDEG, NN, MMAXT, TTOTDG, LENWK, AND LENIWK C ARE UNCHANGED. C C IFLG1= C -1 IF NN IS TOO SMALL. C -2 IF MMAXT IS TOO SMALL. C -3 IF TTOTDG IS TOO SMALL. C -4 IF LENWK IS TOO SMALL. C -5 IF LENIWK IS TOO SMALL. C -6 IF IFLG1 ON INPUT IS NOT 00 OR 01 OR 10 OR 11. C UNCHANGED OTHERWISE. C C IFLG2(1:TOTDG) GIVES INFORMATION ABOUT HOW THE M-TH PATH TERMINATED: C IFLG2(M) = C 1 NORMAL RETURN. C C 2 SPECIFIED ERROR TOLERANCE CANNOT BE MET. INCREASE EPSBIG C AND EPSSML AND RERUN. C C 3 MAXIMUM NUMBER OF STEPS EXCEEDED. TO TRACK THE PATH FURTHER, C INCREASE NUMRR AND RERUN THE PATH. HOWEVER, THE PATH MAY C BE DIVERGING, IF THE LAMBDA VALUE IS NEAR 1 AND THE ROOTS C VALUES ARE LARGE. C C 4 JACOBIAN MATRIX DOES NOT HAVE FULL RANK. THE ALGORITHM C HAS FAILED (THE ZERO CURVE OF THE HOMOTOPY MAP CANNOT BE C FOLLOWED ANY FURTHER). C C 5 THE TRACKING ALGORITHM HAS LOST THE ZERO CURVE OF THE C HOMOTOPY MAP AND IS NOT MAKING PROGRESS. THE ERROR TOLERANCES C EPSBIG AND EPSSML WERE TOO LENIENT. THE PROBLEM SHOULD BE C RESTARTED WITH SMALLER ERROR TOLERANCES. C C 6 THE NORMAL FLOW NEWTON ITERATION IN STEPNF OR ROOTNF C FAILED TO CONVERGE. THE ERROR TOLERANCE EPSBIG MAY BE TOO C STRINGENT. C C 7 ILLEGAL INPUT PARAMETERS, A FATAL ERROR. C C LAMBDA(M) IS THE FINAL LAMBDA VALUE FOR THE M-TH PATH, M = 1, ..., C TOTDG, WHERE LAMBDA IS THE CONTINUATION PARAMETER. C C ROOTS(1,J,M), ROOTS(2,J,M) ARE THE REAL AND IMAGINARY PARTS C OF THE JTH VARIABLE RESPECTIVELY, FOR J = 1,...,N, FOR C THE M-TH PATH, FOR M = 1,...,TOTDG. IF IFLG1 = 10 OR 11, THEN C ROOTS(1,N+1,M) AND ROOTS(2,N+1,M) ARE THE REAL AND C IMAGINARY PARTS RESPECTIVELY OF THE PROJECTIVE C COORDINATE OF THE SOLUTION. C C ARCLEN(M) IS THE ARC LENGTH OF THE M-TH PATH FOR M = 1, ..., TOTDG. C C NFE(M) IS THE NUMBER OF JACOBIAN MATRIX EVALUATIONS REQUIRED TO C TRACK THE M-TH PATH FOR M =1, ..., TOTDG. C C ---------------------------------------------------------------------- C TYPE DECLARATIONS FOR INPUT AND OUTPUT INTEGER N,NUMT,KDEG,IFLG1,IFLG2,NUMRR,NN,MMAXT, $ TTOTDG,LENWK,LENIWK,NFE,IWK DOUBLE PRECISION COEF,EPSBIG,EPSSML,SSPAR,LAMBDA,ROOTS, $ ARCLEN,WK C C ARRAY DECLARATIONS FOR INPUT AND OUTPUT DIMENSION NUMT(NN),KDEG(NN,NN+1,MMAXT),IFLG2(TTOTDG), $ NFE(TTOTDG),IWK(LENIWK) DIMENSION COEF(NN,MMAXT),SSPAR(8),LAMBDA(TTOTDG), $ ROOTS(2,NN+1,TTOTDG), ARCLEN(TTOTDG),WK(LENWK) C C TYPE DECLARATIONS FOR VARIABLES INTEGER I,IDEG,IIDEG,IWKOFF,J,K,L,LENIWW,LENWKK,LIWK,LWK, $ MAXT,N2,TOTDG,WKOFF C C ARRAY DECLARATIONS FOR VARIABLES DIMENSION LWK(19),LIWK(4),WKOFF(19),IWKOFF(4) C C CHECK THAT BASIC DIMENSIONAL PARAMETERS ARE BIG ENOUGH C IF(NN.LT.N) THEN IFLG1=-1 RETURN END IF MAXT=0 DO 50 J=1,N IF(MAXT.LT.NUMT(J))MAXT=NUMT(J) 50 CONTINUE IF(MMAXT.LT.MAXT) THEN IFLG1=-2 RETURN END IF TOTDG=1 DO 80 J=1,N IDEG=0 DO 70 K=1,NUMT(J) IIDEG=0 DO 60 L=1,N IIDEG=IIDEG+KDEG(J,L,K) 60 CONTINUE IF(IIDEG.GT.IDEG)IDEG=IIDEG 70 CONTINUE TOTDG=TOTDG*IDEG 80 CONTINUE IF(TTOTDG.LT.TOTDG) THEN IFLG1=-3 RETURN END IF LENWKK = 21 + 61*N + 10*N**2 + 7*N*MMAXT + 4*N**2*MMAXT IF(LENWK.LT.LENWKK) THEN IFLG1=-4 RETURN END IF LENIWW = 43 + 7*N + N*(N+1)*MMAXT IF(LENIWK.LT.LENIWW) THEN IFLG1=-5 RETURN END IF IF(IFLG1.NE.0.AND.IFLG1.NE.1.AND.IFLG1.NE.10.AND.IFLG1.NE.11) THEN IFLG1=-6 RETURN END IF C C VARIABLES THAT ARE PASSED IN ARRAY WK: (LENGTHS ARE IN THE C INTEGER ARRAY LWK.) C C VARIABLE NAME LENGTH C C 1 PDG N2 C 2 QDG N2 C 3 R N2 C 4 FACV N C 5 CL 2*(N+1) C 6 Y N2+1 C 7 YP N2+1 C 8 YOLD N2+1 C 9 YPOLD N2+1 C 10 QR N2*(N2+2) C 11 ALPHA N2 C 12 TZ N2+1 C 13 W N2+1 C 14 WP N2+1 C 15 Z0 N2+1 C 16 Z1 N2+1 C 17 SSPAR 8 C 18 PAR 2 + 28*N + 6*N**2 + 7*N*MMAXT + 4*N**2*MMAXT C C VARIABLES THAT ARE PASSED IN ARRAY IWK: (LENGTHS ARE IN THE C INTEGER ARRAY LIWK.) C C VARIABLE NAME LENGTH C C 1 IDEG N C 2 ICOUNT N C 3 PIVOT N2+1 C 4 IPAR 42 + 2*N + N*(N+1)*MMAXT C N2=2*N LWK(1)= N2 LWK(2)= N2 LWK(3)= N2 LWK(4)= N LWK(5)= 2*(N+1) LWK(6)= N2+1 LWK(7)= N2+1 LWK(8)= N2+1 LWK(9)= N2+1 LWK(10)=N2*(N2+2) LWK(11)=N2 LWK(12)=N2+1 LWK(13)=N2+1 LWK(14)=N2+1 LWK(15)=N2+1 LWK(16)=N2+1 LWK(17)=8 LWK(18)= 2 + 28*N + 6* N**2 + 7*N*MMAXT + 4* N**2 *MMAXT C LIWK(1)=N LIWK(2)=N LIWK(3)=2*N+1 LIWK(4)= 42 + 2*N + N*(N+1)*MMAXT C C WKOFF AND IWKOFF ARE OFFSETS THAT DEFINE THE VARIABLES LISTED ABOVE C WKOFF(1)=1 DO 100 I=2,18 WKOFF(I)=WKOFF(I-1)+LWK(I-1) 100 CONTINUE IWKOFF(1)=1 DO 200 I=2,4 IWKOFF(I)=IWKOFF(I-1)+LIWK(I-1) 200 CONTINUE DO 300 J=1,8 WK(WKOFF(17) + (J-1))=SSPAR(J) 300 CONTINUE C CALL POLYP(N,NUMT,COEF,KDEG,IFLG1,IFLG2,EPSBIG,EPSSML, $ NUMRR,NN,MMAXT,TTOTDG,LAMBDA,ROOTS,ARCLEN,NFE,TOTDG, $ WK( WKOFF( 1)),WK( WKOFF( 2)),WK( WKOFF( 3)),WK( WKOFF( 4)), $ WK( WKOFF( 5)),WK( WKOFF( 6)),WK( WKOFF( 7)),WK( WKOFF( 8)), $ WK( WKOFF( 9)),WK( WKOFF(10)),WK( WKOFF(11)),WK( WKOFF(12)), $ WK( WKOFF(13)),WK( WKOFF(14)),WK( WKOFF(15)),WK( WKOFF(16)), $ WK( WKOFF(17)),WK( WKOFF(18)), $IWK(IWKOFF( 1)),IWK(IWKOFF( 2)),IWK(IWKOFF( 3)),IWK(IWKOFF( 4))) C RETURN END SUBROUTINE POLYP(N,NUMT,COEF,KDEG,IFLG1,IFLG2,EPSBIG,EPSSML, $ NUMRR,NN,MMAXT,TTOTDG,LAMBDA,ROOTS,ARCLEN,NFE,TOTDG, $ PDG,QDG,R,FACV,CL,Y,YP,YOLD,YPOLD,QR,ALPHA,TZ,W, $ WP,Z0,Z1,SSPAR,PAR,IDEG,ICOUNT,PIVOT,IPAR) C C THE PURPOSE OF POLYP IS TO ALIAS THE WORKSPACES "WK" AND C "IWK" IN POLSYS TO THE VARIABLES "PDG" THROUGH "IPAR". C POLYP GENERATES THE START POINTS FOR THE PATHS AND CALLS THE C PATH TRACKER POLYNF . C C SUBROUTINES CALLED: INITP, STRPTP, POLYNF, OTPUTP . C C ON INPUT: C C N,NUMT,COEF,KDEG,IFLG1,IFLG2,EPSBIG,EPSSML,NUMRR,NN, C MMAXT,TTOTDG ARE AS DESCRIBED IN POLSYS. C C TOTDG IS THE TOTAL DEGREE OF THE SYSTEM. C C PDG,QDG,R,FACV,CL,Y,YP,YOLD,YPOLD,QR,ALPHA,TZ,W,WP,Z0, C Z1,SSPAR,PAR,IDEG,ICOUNT,PIVOT,IPAR ARE VARIABLES. C C ON OUTPUT: C C LAMBDA,ROOTS,ARCLEN,NFE ARE AS DESCRIBED IN POLSYS. C ---------------------------------------------------------------------- C C TYPE DECLARATIONS INTEGER N,NUMT,KDEG,IFLG1,IFLG2,NUMRR,NN,MMAXT, $ TTOTDG,NFE,TOTDG,IDEG,ICOUNT,PIVOT,IPAR INTEGER I,I1,I2,I3,IDUMMY,IFLAG,IJ,IJP1,INDEX,IPROFF,J,LIPAR, $ LPAR,N2,N2P1,NNFE,NP1,NUMPAT,PROFF,TRACE DOUBLE PRECISION COEF,EPSBIG,EPSSML,LAMBDA,ROOTS, $ ARCLEN,PDG,QDG,R,FACV,CL,Y,YP,YOLD,YPOLD, $ QR,ALPHA,TZ,W,WP,Z0,Z1,SSPAR,PAR DOUBLE PRECISION AARCLN,ANSAE,ANSRE,ARCAE,ARCRE,XNP1 C C ARRAY DECLARATIONS DIMENSION NUMT(NN),KDEG(NN,NN+1,MMAXT),IFLG2(TTOTDG), $ NFE(TTOTDG),IDEG(N),ICOUNT(N),PIVOT(2*N+1), $ IPAR(42 + 2*N + N*(N+1)*MMAXT) DIMENSION IPROFF(15),LIPAR(15),LPAR(25),PROFF(25) DIMENSION COEF(NN,MMAXT),LAMBDA(TTOTDG), $ ROOTS(2,NN+1,TTOTDG), ARCLEN(TTOTDG), $ PDG(2,N),QDG(2,N),R(2,N),FACV(N),CL(2,N+1), $ Y(2*N+1),YP(2*N+1),YOLD(2*N+1),YPOLD(2*N+1), $ QR(2*N,2*N+2),ALPHA(2*N+1),TZ(2*N+1),W(2*N+1), $ WP(2*N+1),Z0(2*N+1),Z1(2*N+1),SSPAR(8), $ PAR(2 + 28*N + 6*N**2 + 7*N*MMAXT + 4*N**2*MMAXT) DIMENSION XNP1(2) C N2=2*N NP1=N+1 N2P1=N2+1 IF (NUMRR .LE. 0) NUMRR=1 C C INITIALIZATION C CALL INITP(IFLG1,N,NUMT,KDEG,COEF,NN,MMAXT,PAR,IPAR, $ IDEG,FACV,CL,PDG,QDG,R) C C INTEGER VARIABLES AND ARRAYS TO BE PASSED IN IPAR: C C IPAR INDEX VARIABLE NAME LENGTH C ---------- ------------- ----------------- C 1 N 1 C 2 MMAXT 1 C 3 PROFF 25 C 4 IPROFF 15 C 5 IDEG N C 6 NUMT N C 7 KDEG N*(N+1)*MMAXT C C C DOUBLE PRECISION VARIABLES AND ARRAYS TO BE PASSED IN PAR: C C PAR INDEX VARIABLE NAME LENGTH C ---------- ------------- ----------------- C 1 PDG 2*N C 2 CL 2*(N+1) C 3 COEF N*MMAXT C 4 H N2 C 5 DHX N2*N2 C 6 DHT N2 C 7 XDGM1 2*N C 8 XDG 2*N C 9 G 2*N C 10 DG 2*N C 11 PXDGM1 2*N C 12 PXDG 2*N C 13 F 2*N C 14 DF 2*N*(N+1) C 15 XX 2*N*(N+1)*MMAXT C 16 TRM 2*N*MMAXT C 17 DTRM 2*N*(N+1)*MMAXT C 18 CLX 2*N C 19 DXNP1 2*N C C SET LENGTHS OF VARIABLES LIPAR(1)=1 LIPAR(2)=1 LIPAR(3)=25 LIPAR(4)=15 LIPAR(5)=N LIPAR(6)=N LIPAR(7)=N*(N+1)*MMAXT LPAR( 1)=2*N LPAR( 2)=2*NP1 LPAR( 3)=N*MMAXT LPAR( 4)=N2 LPAR( 5)=N2*N2 LPAR( 6)=N2 LPAR( 7)=2*N LPAR( 8)=2*N LPAR( 9)=2*N LPAR(10)=2*N LPAR(11)=2*N LPAR(12)=2*N LPAR(13)=2*N LPAR(14)=2*N*NP1 LPAR(15)=2*N*NP1*MMAXT LPAR(16)=2*N*MMAXT LPAR(17)=2*N*NP1*MMAXT LPAR(18)=2*N LPAR(19)=2*N C C PROFF AND IPROFF ARE OFFSETS THAT DEFINE THE VARIABLES LISTED ABOVE PROFF(1)=1 DO 10 I=2,19 PROFF(I)=PROFF(I-1)+LPAR(I-1) 10 CONTINUE IPROFF(1)=1 DO 11 I=2,7 IPROFF(I)=IPROFF(I-1)+LIPAR(I-1) 11 CONTINUE C C DEFINE VARIABLES IPAR(1)=N IPAR(2)=MMAXT DO 16 I=1,19 IPAR(IPROFF(3) + (I-1))= PROFF(I) 16 CONTINUE DO 18 I=1,7 IPAR(IPROFF(4) + (I-1))= IPROFF(I) 18 CONTINUE DO 20 I=1,N IPAR(IPROFF(5) + (I-1))= IDEG(I) IPAR(IPROFF(6) + (I-1))= NUMT(I) 20 CONTINUE DO 22 I1=1, N DO 22 I2=1, NP1 DO 22 I3=1, NUMT(I1) INDEX=IPROFF(7) + (I1-1) + N*(I2-1) + N*NP1*(I3-1) IPAR(INDEX) = KDEG(I1,I2,I3) 22 CONTINUE DO 36 I1=1,2 DO 36 I2=1,N PAR(PROFF( 1) +(I1-1) + 2*(I2-1))= PDG(I1,I2) 36 CONTINUE DO 37 I1=1,2 DO 37 I2=1,NP1 PAR(PROFF( 2) +(I1-1) +2*(I2-1))= CL(I1,I2) 37 CONTINUE DO 38 I1=1,N DO 38 I2=1, NUMT(I1) PAR(PROFF( 3) +(I1-1) + N*(I2-1))=COEF(I1,I2) 38 CONTINUE C C ICOUNT IS A COUNTER USED BY "STRPTP" ICOUNT(1)=0 DO 50 J=2,N ICOUNT(J)=1 50 CONTINUE C C PATHS LOOP -- ITERATE THROUGH PATHS C DO 1000 NUMPAT = 1,TOTDG C GET A START POINT, Y, FOR THE PATH. Y(1) = 0.0 CALL STRPTP(N,ICOUNT,IDEG,R ,Y(2)) C CHECK WHETHER PATH IS TO BE FOLLOWED. IFLAG = IFLG2(NUMPAT) IF (IFLAG .NE. -2) GO TO 1000 ARCRE = EPSBIG ARCAE = ARCRE ANSRE = EPSSML ANSAE = ANSRE TRACE = 0 C TRACK A HOMOTOPY PATH. DO 65 IDUMMY=1,NUMRR CALL POLYNF(N2,Y,IFLAG,ARCRE,ARCAE,ANSRE,ANSAE,TRACE, $ QDG,NNFE,AARCLN,YP,YOLD,YPOLD,QR,ALPHA,TZ,PIVOT,W,WP, $ Z0,Z1,SSPAR,PAR,IPAR) IF (IFLAG .NE. 2 .AND. IFLAG .NE. 3) GOTO 66 65 CONTINUE 66 CONTINUE C UNSCALE AND UNTRANSFORM COMPUTED SOLUTION. CALL OTPUTP(N,NUMPAT,CL,FACV,PAR(PROFF(18)),Y(2),XNP1) LAMBDA(NUMPAT) = Y(1) DO 70 J=1,N DO 70 I=1,2 IJ=2*J+I-2 IJP1=IJ+1 ROOTS(I,J,NUMPAT) = Y(IJP1) 70 CONTINUE DO 72 I=1,2 ROOTS(I,NP1,NUMPAT) = XNP1(I) 72 CONTINUE ARCLEN(NUMPAT)= AARCLN NFE(NUMPAT) = NNFE IFLG2(NUMPAT) = IFLAG 1000 CONTINUE C RETURN END * SUBROUTINE POWP(NNNN,XXXX,YYYY) C C THIS SUBROUTINE TAKES A NON-NEGATIVE POWER OF A COMPLEX NUMBER: C YYYY = XXXX**NNNN USING DE MOIVRE'S FORMULA: C C YYYY = R**NNNN * (COS(NNNN*THETA),SIN(NNNN*THETA)), C C WHERE R=DNRM2(2,XXXX,1) AND THETA=ATAN2(XXXX(2),XXXX(1)). C C NOTE: POWP SETS 0**0 EQUAL TO 1. C C ON INPUT: C C NNNN IS A NON-NEGATIVE INTEGER. C C XXXX IS AN ARRAY OF LENGTH TWO REPRESENTING A COMPLEX C NUMBER, WHERE XXXX(1) = REAL PART OF XXXX AND XXXX(2) = C IMAGINARY PART OF XXXX. C C ON OUTPUT: C C YYYY IS AN ARRAY OF LENGTH TWO REPRESENTING THE RESULT OF C THE POWER, YYYY = XXXX**NNNN, WHERE YYYY(1) = C REAL PART OF YYYY AND YYYY(2) = IMAGINARY PART OF YYYY. C C SUBROUTINES: COS, SIN, ATAN2, DNRM2 C C DECLARATION OF INPUT INTEGER NNNN DOUBLE PRECISION XXXX DIMENSION XXXX(2) C C DECLARATION OF OUTPUT DOUBLE PRECISION YYYY DIMENSION YYYY(2) C C DECLARATION OF VARIABLES DOUBLE PRECISION R,RR,T,TT C C DECLARATION OF FUNCTIONS DOUBLE PRECISION DNRM2 C IF (NNNN .EQ. 0) THEN YYYY(1)=1. YYYY(2)=0. RETURN ENDIF IF (NNNN .EQ. 1) THEN YYYY(1)=XXXX(1) YYYY(2)=XXXX(2) RETURN ENDIF R = DNRM2(2,XXXX,1) IF (R .EQ. 0.0) THEN YYYY(1)=0.0 YYYY(2)=0.0 RETURN END IF RR= R**NNNN T = ATAN2(XXXX(2),XXXX(1)) TT= NNNN*T YYYY(1) = RR*COS(TT) YYYY(2) = RR*SIN(TT) RETURN END * SUBROUTINE QIMUDS(Q,F,MAXA,NN,LENAA) C C computes f := [Q**(-1)] * f . C C on input: C C Q is the preconditioning matrix, and contains an approximate C factorization of M. C C f is the right hand side vector, Q z = f . C C MAXA, NN, LENAA describe Q in packed skyline storage format. C C on output: C C Q, MAXA, NN, LENAA are unchanged. C C f contains the solution z of Q z = f . C C C Calls SOLVDS . C INTEGER LENAA,LENQ,NN,MAXA(NN+2),NQ DOUBLE PRECISION Q(LENAA+NN+1),F(NN+1) C NQ=NN+1 LENQ=MAXA(NN+2)-1 C CALL SOLVDS(NQ,Q,LENQ,MAXA,F) C RETURN END SUBROUTINE QRFAQF(QT,R,N,IFLAG) C C SUBROUTINE QRFAQF COMPUTES THE QR FACTORIZATION OF A MATRIX A, C WHERE R IS AN UPPER TRIANGULAR MATRIX, AND Q IS AN ORTHOGONAL C MATRIX WHICH IS THE PRODUCT OF N-1 HOUSEHOLDER TRANSFORMATIONS C C Q=H1*H2*...*H(N-1). C C THE ROUTINE HAS TWO MAJOR STEPS. FIRST, THE QR FACTORIZATION C OF A IS COMPUTED, RESULTING IN DEFINING THE VECTOR R, AND C STORING INFORMATION IN THE LOWER TRIANGLE OF QT WHICH WILL C ENABLE THE CONSTRUCTION OF Q TRANSPOSE. C C THE SECOND STEP CONSTRUCTS Q TRANSPOSE FROM THE INFORMATION C STORED IN QT, AND PLACES IT IN QT. C C THE INFORMATION STORED IN THE LOWER TRIANGLE OF QT DURING THE FIRST C STEP ARE THE VECTORS UJ, WHICH DEFINE THE HOUSEHOLDER TRANSFORMATIONS C C T C HJ = I - (UJ*UJ / PJ), WHERE UJ[I]=0 FOR I=1...J-1, C UJ[I]=QT[I,J], FOR I=J...N, C PJ = THE JTH COMPONENT OF UJ. C C C ON INPUT: C C QT(1:N,1:N) CONTAINS THE MATRIX A TO BE FACTORED. C C R(1:N*(N+1)/2) IS UNDEFINED. C C N IS THE DIMENSION OF THE MATRIX TO BE FACTORED. C C IFLAG IS UNDEFINED. C C C ON OUTPUT: C C QT CONTAINS Q TRANSPOSE. C C R(1:N*(N+1)/2) CONTAINS THE UPPER TRIANGLE OF R STORED BY ROWS. C C N IS UNCHANGED. C C IFLAG = 4 IF THE MATRIX A IS SINGULAR. OTHERWISE, IFLAG C IS UNCHANGED. C C C CALLS DAXPY, DCOPY, DDOT, DNRM2, DSCAL. C C ***** DECLARATIONS ***** C C FUNCTION DECLARATIONS C DOUBLE PRECISION DDOT, DNRM2 C C LOCAL VARIABLES C DOUBLE PRECISION ONE, TAU, TEMP INTEGER I, J, K, INDEXR, ISIGN C C SCALAR ARGUMENTS C INTEGER N, IFLAG C C ARRAY DECLARATIONS C DOUBLE PRECISION QT(N,N),R(N) C C ***** END OF DECLARATIONS ***** C C ***** FIRST EXECUTABLE STATEMENT ***** C ONE = 1.0 C C ***** CALCULATION OF QR DECOMPOSITION, PLACING R IN THE VECTOR ***** C R, AND PLACING THE UJ VECTORS IN THE LOWER TRIANGLE OF C QT. C INDEXR = 1 DO 20 K=1,N-1 TEMP = DNRM2(N-K+1,QT(K,K),1) IF (TEMP .EQ. 0.0) THEN C C MATRIX IS SINGULAR, SET IFLAG AND RETURN. C IFLAG = 4 RETURN ELSE C C FORM QK AND PREMULTIPLY QT BY IT. C T C UK = EK - ISIGN*X/||X||, WHERE HK = I-(UK*UK /PK), C PK = THE KTH COMPONENT OF UK, C EK = THE KTH NATURAL BASIS VECTOR, C X = THE KTH COLUMN OF THE MATRIX H(K-1)...H2*H1*QT, C ISIGN = THE SIGN OF PK. C C GET SIGN. C ISIGN = SIGN(ONE,QT(K,K)) C C COMPUTE R(K,K). C R(INDEXR) = -ISIGN*TEMP C C UPDATE KTH COLUMN. C TEMP = ISIGN/TEMP CALL DSCAL(N-K+1,TEMP,QT(K,K),1) QT(K,K) = QT(K,K) + 1.0 C C UPDATE THE K+1ST - NTH COLUMNS OF QT, AND R. C INDEXR = INDEXR + 1 DO 10 J=K+1,N TAU = DDOT(N-K+1,QT(K,K),1,QT(K,J),1)/QT(K,K) R(INDEXR) = QT(K,J) - TAU*QT(K,K) INDEXR = INDEXR + 1 CALL DAXPY(N-K,-TAU,QT(K+1,K),1,QT(K+1,J),1) 10 CONTINUE END IF 20 CONTINUE IF (QT(N,N) .EQ. 0.0) THEN C C MATRIX IS SINGULAR, SET IFLAG AND RETURN. C IFLAG = 4 RETURN END IF R(INDEXR) = QT(N,N) C C ***** END OF FACTORING STEP ***** C C ***** CONSTRUCT Q TRANSPOSE IN QT ***** C C FORM Q BY MULTIPLYING ((I*H(N-1))*...)*H1. C THIS IS DONE IN PLACE IN QT BY UPDATING ONLY THE LOWER C RIGHT HAND CORNER OF QT (QT(K,K) TO QT(N,N)). C C QT(N,N) = 1.0 DO 40 K=N-1,1,-1 C C MULTIPLY QT BY H(K). C TEMP = QT(K,K) C C UPDATE ROW K. C QT(K,K) = 1.0-QT(K,K) CALL DCOPY(N-K,QT(K+1,K),1,QT(K,K+1),N) CALL DSCAL(N-K,-ONE,QT(K,K+1),N) C C UPDATE REMAINING ROWS. C DO 30 I=N,K+1,-1 TAU = -DDOT(N-K,QT(I,K+1),N,QT(K,K+1),N) QT(I,K) = -TAU TAU = TAU/TEMP CALL DAXPY(N-K,TAU,QT(K,K+1),N,QT(I,K+1),N) 30 CONTINUE 40 CONTINUE C C ***** END OF Q TRANSPOSE CONSTRUCTION ***** C RETURN C C ***** END OF SUBROUTINE QRFAQF ***** END SUBROUTINE QRSLQF(QT,R,B,X,N) C C SUBROUTINE QRSLQF SOLVES THE SYSTEM R*S = QT*B FOR S. C C C ON INPUT: C C QT(1:N,1:N) CONTAINS QT IN THE EQUATION ABOVE. C C R(1:N*(N+1)/2) CONTAINS THE UPPER TRIANGLE OF R IN THE EQUATION C ABOVE, STORED BY ROWS. C C B(1:N) CONTAINS B IN THE EQUATION ABOVE. C C N IS THE DIMENSION OF THE PROBLEM. C C C ON OUTPUT: C C QT AND R ARE UNCHANGED. C C B CONTAINS THE SOLUTION VECTOR S. C C X(1:N) IS A WORK ARRAY WHICH CONTAINS QT*B ON OUTPUT. C C C CALLS DDOT. C C ***** DECLARATIONS ***** C C FUNCTION DECLARATIONS C DOUBLE PRECISION DDOT C C LOCAL VARIABLES C DOUBLE PRECISION TAU INTEGER INDEXR, I, J C C SCALAR ARGUMENTS C INTEGER N C C ARRAY DECLARATIONS C DOUBLE PRECISION QT(N,N),R(N*(N+1)/2),B(N),X(N) C C ***** END OF DECLARATIONS ***** C C ***** FIRST EXECUTABLE STATEMENT ***** C C X = QT*B. C DO 10 I=1,N X(I) = DDOT(N,QT(I,1),N,B,1) 10 CONTINUE C C COMPUTE S USING BACK SUBSTITUTION. C INDEXR = N*(N+1)/2 B(N) = X(N)/R(INDEXR) INDEXR = INDEXR - 1 DO 30 I=N-1,1,-1 TAU = X(I) DO 20 J=N,I+1,-1 TAU = TAU - R(INDEXR)*B(J) INDEXR = INDEXR - 1 20 CONTINUE B(I) = TAU/R(INDEXR) INDEXR = INDEXR - 1 30 CONTINUE RETURN C C ***** END OF SUBROUTINE QRSLQF ***** END SUBROUTINE RHO(A,LAMBDA,X,V,PAR,IPAR) DOUBLE PRECISION A(*),LAMBDA,X(*),V(*),PAR(*) INTEGER IPAR(*) C C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS, C WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES C RHO, RHOJAC. C C EVALUATE RHO(A,LAMBDA,X) AND RETURN IN THE VECTOR V . C C THE FOLLOWING CODE IS SPECIFICALLY FOR THE POLYNOMIAL SYSTEM DRIVER C POLSYS , AND SHOULD BE USED VERBATUM WITH POLSYS . IF THE USER IS C CALLING FIXP?? OR STEP?? DIRECTLY, HE MUST SUPPLY APPROPRIATE C REPLACEMENT CODE HERE. INTEGER J,N C FORCE PREDICTED POINT TO HAVE LAMBDA .GE. 0 . IF (LAMBDA .LT. 0.0) LAMBDA=0.0 CALL HFUNP(A,LAMBDA,X,PAR,IPAR) N=IPAR(1) DO 10 J=1,2*N V(J)=PAR(IPAR(3 + (4-1)) + (J-1)) 10 CONTINUE C RETURN END SUBROUTINE RHOA(A,LAMBDA,X,PAR,IPAR) DOUBLE PRECISION A(1),LAMBDA,X(1),PAR(1) INTEGER IPAR(1) C C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS, C WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES C RHOA, RHOJS. C C CALCULATE AND RETURN IN A THE VECTOR Z SUCH THAT C RHO(Z,LAMBDA,X) = 0 . C RETURN END SUBROUTINE RHOJAC(A,LAMBDA,X,V,K,PAR,IPAR) DOUBLE PRECISION A(*),LAMBDA,X(*),V(*),PAR(*) INTEGER IPAR(*),K C C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS, C WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES C RHO, RHOJAC. C C RETURN IN THE VECTOR V THE KTH COLUMN OF THE JACOBIAN C MATRIX [D RHO/D LAMBDA, D RHO/DX] EVALUATED AT THE POINT C (A, LAMBDA, X). C C THE FOLLOWING CODE IS SPECIFICALLY FOR THE POLYNOMIAL SYSTEM DRIVER C POLSYS , AND SHOULD BE USED VERBATUM WITH POLSYS . IF THE USER IS C CALLING FIXP?? OR STEP?? DIRECTLY, HE MUST SUPPLY APPROPRIATE C REPLACEMENT CODE HERE. INTEGER J,N,N2 N=IPAR(1) N2=2*N IF (K .EQ. 1) THEN C FORCE PREDICTED POINT TO HAVE LAMBDA .GE. 0 . IF (LAMBDA .LT. 0.0) LAMBDA=0.0 CALL HFUNP(A,LAMBDA,X,PAR,IPAR) DO 10 J=1,N2 V(J)=PAR(IPAR(3 + (6-1)) + (J-1)) 10 CONTINUE RETURN ELSE DO 20 J=1,N2 V(J)=PAR(IPAR(3 + (5-1)) + (J-1) + N2*(K-2)) 20 CONTINUE ENDIF C RETURN END SUBROUTINE RHOJS(A,LAMBDA,X,QR,LENQR,PIVOT,PP,PAR,IPAR) C INTEGER IPAR(1),LENQR,N,PIVOT(N+2) C DOUBLE PRECISION A(N),LAMBDA,PAR(1),PP(N),QR(LENQR),X(N) C C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS, C WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES C RHOA, RHOJS. C C Evaluate the N X N symmetric Jacobian matrix [D RHO/DX] at (A,X,LAMBDA C and return the result in packed skyline storage format in QR. LENQR i C the length of QR, and PIVOT contains the indices of the diagonal eleme C of [D RHO/DX] within QR. PP contains -[D RHO/D LAMBDA] evaluated at C (A,X,LAMBDA). Note the minus sign in the definition of PP. C RETURN END SUBROUTINE ROOT(T,FT,B,C,RELERR,ABSERR,IFLAG) C C ROOT COMPUTES A ROOT OF THE NONLINEAR EQUATION F(X)=0 C WHERE F(X) IS A CONTINOUS REAL FUNCTION OF A SINGLE REAL C VARIABLE X. THE METHOD USED IS A COMBINATION OF BISECTION C AND THE SECANT RULE. C C NORMAL INPUT CONSISTS OF A CONTINUOS FUNCTION F AND AN C INTERVAL (B,C) SUCH THAT F(B)*F(C).LE.0.0. EACH ITERATION C FINDS NEW VALUES OF B AND C SUCH THAT THE INTERVAL(B,C) IS C SHRUNK AND F(B)*F(C).LE.0.0. THE STOPPING CRITERION IS C C DABS(B-C).LE.2.0*(RELERR*DABS(B)+ABSERR) C C WHERE RELERR=RELATIVE ERROR AND ABSERR=ABSOLUTE ERROR ARE C INPUT QUANTITIES. SET THE FLAG, IFLAG, POSITIVE TO INITIALIZE C THE COMPUTATION. AS B,C AND IFLAG ARE USED FOR BOTH INPUT AND C OUTPUT, THEY MUST BE VARIABLES IN THE CALLING PROGRAM. C C IF 0 IS A POSSIBLE ROOT, ONE SHOULD NOT CHOOSE ABSERR=0.0. C C THE OUTPUT VALUE OF B IS THE BETTER APPROXIMATION TO A ROOT C AS B AND C ARE ALWAYS REDEFINED SO THAT DABS(F(B)).LE.DABS(F(C)). C C TO SOLVE THE EQUATION, ROOT MUST EVALUATE F(X) REPEATEDLY. THIS C IS DONE IN THE CALLING PROGRAM. WHEN AN EVALUATION OF F IS C NEEDED AT T, ROOT RETURNS WITH IFLAG NEGATIVE. EVALUATE FT=F(T) C AND CALL ROOT AGAIN. DO NOT ALTER IFLAG. C C WHEN THE COMPUTATION IS COMPLETE, ROOT RETURNS TO THE CALLING C PROGRAM WITH IFLAG POSITIVE= C C IFLAG=1 IF F(B)*F(C).LT.0 AND THE STOPPING CRITERION IS MET. C C =2 IF A VALUE B IS FOUND SUCH THAT THE COMPUTED VALUE C F(B) IS EXACTLY ZERO. THE INTERVAL (B,C) MAY NOT C SATISFY THE STOPPING CRITERION. C C =3 IF DABS(F(B)) EXCEEDS THE INPUT VALUES DABS(F(B)), C DABS(F(C)). IN THIS CASE IT IS LIKELY THAT B IS CLOSE C TO A POLE OF F. C C =4 IF NO ODD ORDER ROOT WAS FOUND IN THE INTERVAL. A C LOCAL MINIMUM MAY HAVE BEEN OBTAINED. C C =5 IF TOO MANY FUNCTION EVALUATIONS WERE MADE. C (AS PROGRAMMED, 500 ARE ALLOWED.) C C THIS CODE IS A MODIFICATION OF THE CODE ZEROIN WHICH IS COMPLETELY C EXPLAINED AND DOCUMENTED IN THE TEXT NUMERICAL COMPUTING: AN C INTRODUCTION, BY L. F. SHAMPINE AND R. C. ALLEN. C C CALLS D1MACH . C DOUBLE PRECISION A,ABSERR,ACBS,ACMB,AE,B,C,CMB,D1MACH,FA,FB, 1 FC,FT,FX,P,Q,RE,RELERR,T,TOL,U INTEGER IC,IFLAG,KOUNT SAVE C IF(IFLAG.GE.0) GO TO 100 IFLAG=ABS(IFLAG) GO TO (200,300,400), IFLAG 100 U=D1MACH(4) RE=MAX(RELERR,U) AE=MAX(ABSERR,0.0D0) IC=0 ACBS=ABS(B-C) A=C T=A IFLAG=-1 RETURN 200 FA=FT T=B IFLAG=-2 RETURN 300 FB=FT FC=FA KOUNT=2 FX=MAX(ABS(FB),ABS(FC)) 1 IF(ABS(FC).GE.ABS(FB))GO TO 2 C C INTERCHANGE B AND C SO THAT ABS(F(B)).LE.ABS(F(C)). C A=B FA=FB B=C FB=FC C=A FC=FA 2 CMB=0.5*(C-B) ACMB=ABS(CMB) TOL=RE*ABS(B)+AE C C TEST STOPPING CRITERION AND FUNCTION COUNT. C IF(ACMB.LE.TOL)GO TO 8 IF(KOUNT.GE.500)GO TO 12 C C CALCULATE NEW ITERATE EXPLICITLY AS B+P/Q C WHERE WE ARRANGE P.GE.0. THE IMPLICIT C FORM IS USED TO PREVENT OVERFLOW. C P=(B-A)*FB Q=FA-FB IF(P.GE.0.0)GO TO 3 P=-P Q=-Q C C UPDATE A, CHECK IF REDUCTION IN THE SIZE OF BRACKETING C INTERVAL IS SATISFACTORY. IF NOT BISECT UNTIL IT IS. C 3 A=B FA=FB IC=IC+1 IF(IC.LT.4)GO TO 4 IF(8.0*ACMB.GE.ACBS)GO TO 6 IC=0 ACBS=ACMB C C TEST FOR TOO SMALL A CHANGE. C 4 IF(P.GT.ABS(Q)*TOL)GO TO 5 C C INCREMENT BY TOLERANCE C B=B+SIGN(TOL,CMB) GO TO 7 C C ROOT OUGHT TO BE BETWEEN B AND (C+B)/2 C 5 IF(P.GE.CMB*Q)GO TO 6 C C USE SECANT RULE. C B=B+P/Q GO TO 7 C C USE BISECTION. C 6 B=0.5*(C+B) C C HAVE COMPLETED COMPUTATION FOR NEW ITERATE B. C 7 T=B IFLAG=-3 RETURN 400 FB=FT IF(FB.EQ.0.0)GO TO 9 KOUNT=KOUNT+1 IF(SIGN(1.0D0,FB).NE.SIGN(1.0D0,FC))GO TO 1 C=A FC=FA GO TO 1 C C FINISHED. SET IFLAG. C 8 IF(SIGN(1.0D0,FB).EQ.SIGN(1.0D0,FC))GO TO 11 IF(ABS(FB).GT.FX)GO TO 10 IFLAG=1 RETURN 9 IFLAG=2 RETURN 10 IFLAG=3 RETURN 11 IFLAG=4 RETURN 12 IFLAG=5 RETURN END SUBROUTINE ROOTNF(N,NFE,IFLAG,RELERR,ABSERR,Y,YP,YOLD,YPOLD, $ A,QR,ALPHA,TZ,PIVOT,W,WP,PAR,IPAR) C C ROOTNF FINDS THE POINT YBAR = (1, XBAR) ON THE ZERO CURVE OF THE C HOMOTOPY MAP. IT STARTS WITH TWO POINTS YOLD=(LAMBDAOLD,XOLD) AND C Y=(LAMBDA,X) SUCH THAT LAMBDAOLD < 1 <= LAMBDA , AND ALTERNATES C BETWEEN HERMITE CUBIC INTERPOLATION AND NEWTON ITERATION UNTIL C CONVERGENCE. C C ON INPUT: C C N = DIMENSION OF X AND THE HOMOTOPY MAP. C C NFE = NUMBER OF JACOBIAN MATRIX EVALUATIONS. C C IFLAG = -2, -1, OR 0, INDICATING THE PROBLEM TYPE. C C RELERR, ABSERR = RELATIVE AND ABSOLUTE ERROR VALUES. THE ITERATION IS C CONSIDERED TO HAVE CONVERGED WHEN A POINT Y=(LAMBDA,X) IS FOUND C SUCH THAT C C |Y(1) - 1| <= RELERR + ABSERR AND C C ||Z|| <= RELERR*||X|| + ABSERR , WHERE C C (?,Z) IS THE NEWTON STEP TO Y=(LAMBDA,X). C C Y(1:N+1) = POINT (LAMBDA(S), X(S)) ON ZERO CURVE OF HOMOTOPY MAP. C C YP(1:N+1) = UNIT TANGENT VECTOR TO THE ZERO CURVE OF THE HOMOTOPY MAP C AT Y . C C YOLD(1:N+1) = A POINT DIFFERENT FROM Y ON THE ZERO CURVE. C C YPOLD(1:N+1) = UNIT TANGENT VECTOR TO THE ZERO CURVE OF THE HOMOTOPY C MAP AT YOLD . C C A(1:*) = PARAMETER VECTOR IN THE HOMOTOPY MAP. C C QR(1:N,1:N+2), ALPHA(1:N), TZ(1:N+1), PIVOT(1:N+1), W(1:N+1), C WP(1:N+1) ARE WORK ARRAYS USED FOR THE QR FACTORIZATION (IN THE C NEWTON STEP CALCULATION) AND THE INTERPOLATION. C C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS, C WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES C RHO, RHOJAC. C C ON OUTPUT: C C N , RELERR , ABSERR , A ARE UNCHANGED. C C NFE HAS BEEN UPDATED. C C IFLAG C = -2, -1, OR 0 (UNCHANGED) ON A NORMAL RETURN. C C = 4 IF A JACOBIAN MATRIX WITH RANK < N HAS OCCURRED. THE C ITERATION WAS NOT COMPLETED. C C = 6 IF THE ITERATION FAILED TO CONVERGE. Y AND YOLD CONTAIN C THE LAST TWO POINTS FOUND ON THE ZERO CURVE. C C Y IS THE POINT ON THE ZERO CURVE OF THE HOMOTOPY MAP AT LAMBDA = 1 . C C C CALLS D1MACH , DNRM2 , ROOT , TANGNF . C DOUBLE PRECISION ABSERR,AERR,D1MACH,DD001,DD0011,DD01,DD011, $ DELS,DNRM2,F0,F1,FP0,FP1,QOFS,QSOUT,RELERR,RERR,S,SA,SB, $ SOUT,U INTEGER IFLAG,JUDY,JW,LCODE,LIMIT,N,NFE,NP1 C C ***** ARRAY DECLARATIONS. ***** C DOUBLE PRECISION Y(N+1),YP(N+1),YOLD(N+1),YPOLD(N+1),A(N), $ QR(N,N+2),ALPHA(N),TZ(N+1),W(N+1),WP(N+1),PAR(1) INTEGER PIVOT(N+1),IPAR(1) C C ***** END OF DIMENSIONAL INFORMATION. ***** C C THE LIMIT ON THE NUMBER OF ITERATIONS ALLOWED MAY BE CHANGED BY C CHANGING THE FOLLOWING PARAMETER STATEMENT: PARAMETER (LIMIT=20) C C DEFINITION OF HERMITE CUBIC INTERPOLANT VIA DIVIDED DIFFERENCES. C DD01(F0,F1,DELS)=(F1-F0)/DELS DD001(F0,FP0,F1,DELS)=(DD01(F0,F1,DELS)-FP0)/DELS DD011(F0,F1,FP1,DELS)=(FP1-DD01(F0,F1,DELS))/DELS DD0011(F0,FP0,F1,FP1,DELS)=(DD011(F0,F1,FP1,DELS) - $ DD001(F0,FP0,F1,DELS))/DELS QOFS(F0,FP0,F1,FP1,DELS,S)=((DD0011(F0,FP0,F1,FP1,DELS)*(S-DELS) + $ DD001(F0,FP0,F1,DELS))*S + FP0)*S + F0 C C U=D1MACH(4) RERR=MAX(RELERR,U) AERR=MAX(ABSERR,0.0D0) NP1=N+1 C C ***** MAIN LOOP. ***** C 100 DO 300 JUDY=1,LIMIT DO 110 JW=1,NP1 TZ(JW)=Y(JW)-YOLD(JW) 110 CONTINUE DELS=DNRM2(NP1,TZ,1) C C USING TWO POINTS AND TANGENTS ON THE HOMOTOPY ZERO CURVE, CONSTRUCT C THE HERMITE CUBIC INTERPOLANT Q(S). THEN USE ROOT TO FIND THE S C CORRESPONDING TO LAMBDA = 1 . THE TWO POINTS ON THE ZERO CURVE ARE C ALWAYS CHOSEN TO BRACKET LAMBDA=1, WITH THE BRACKETING INTERVAL C ALWAYS BEING [0, DELS]. C SA=0.0 SB=DELS LCODE=1 130 CALL ROOT(SOUT,QSOUT,SA,SB,RERR,AERR,LCODE) IF (LCODE .GT. 0) GO TO 140 QSOUT=QOFS(YOLD(1),YPOLD(1),Y(1),YP(1),DELS,SOUT) - 1.0 GO TO 130 C IF LAMBDA = 1 WERE BRACKETED, ROOT CANNOT FAIL. 140 IF (LCODE .GT. 2) THEN IFLAG=6 RETURN ENDIF C C CALCULATE Q(SA) AS THE INITIAL POINT FOR A NEWTON ITERATION. DO 150 JW=1,NP1 W(JW)=QOFS(YOLD(JW),YPOLD(JW),Y(JW),YP(JW),DELS,SA) 150 CONTINUE C CALCULATE NEWTON STEP AT Q(SA). CALL TANGNF(SA,W,WP,YPOLD,A,QR,ALPHA,TZ,PIVOT,NFE,N,IFLAG, $ PAR,IPAR) IF (IFLAG .GT. 0) RETURN C NEXT POINT = CURRENT POINT + NEWTON STEP. DO 160 JW=1,NP1 W(JW)=W(JW)+TZ(JW) 160 CONTINUE C GET THE TANGENT WP AT W AND THE NEXT NEWTON STEP IN TZ . CALL TANGNF(SA,W,WP,YPOLD,A,QR,ALPHA,TZ,PIVOT,NFE,N,IFLAG, $ PAR,IPAR) IF (IFLAG .GT. 0) RETURN C TAKE NEWTON STEP AND CHECK CONVERGENCE. DO 170 JW=1,NP1 W(JW)=W(JW)+TZ(JW) 170 CONTINUE IF ((ABS(W(1)-1.0) .LE. RERR+AERR) .AND. $ (DNRM2(N,TZ(2),1) .LE. RERR*DNRM2(N,W(2),1)+AERR)) THEN DO 180 JW=1,NP1 Y(JW)=W(JW) 180 CONTINUE RETURN ENDIF C IF THE ITERATION HAS NOT CONVERGED, DISCARD ONE OF THE OLD POINTS C SUCH THAT LAMBDA = 1 IS STILL BRACKETED. IF ((YOLD(1)-1.0)*(W(1)-1.0) .GT. 0.0) THEN DO 200 JW=1,NP1 YOLD(JW)=W(JW) YPOLD(JW)=WP(JW) 200 CONTINUE ELSE DO 210 JW=1,NP1 Y(JW)=W(JW) YP(JW)=WP(JW) 210 CONTINUE ENDIF 300 CONTINUE C C ***** END OF MAIN LOOP. ***** C C THE ALTERNATING OSCULATORY CUBIC INTERPOLATION AND NEWTON ITERATION C HAS NOT CONVERGED IN LIMIT STEPS. ERROR RETURN. IFLAG=6 RETURN END SUBROUTINE ROOTNS(N,NFE,IFLAG,RELERR,ABSERR,Y,YP,YOLD,YPOLD, $ A,QR,LENQR,PIVOT,WORK,PAR,IPAR) C C ROOTNS FINDS THE POINT YBAR = (XBAR, 1) ON THE ZERO CURVE OF THE C HOMOTOPY MAP. IT STARTS WITH TWO POINTS YOLD=(XOLD,LAMBDAOLD) AND C Y=(X,LAMBDA) SUCH THAT LAMBDAOLD < 1 <= LAMBDA , AND ALTERNATES C BETWEEN HERMITE CUBIC INTERPOLATION AND NEWTON ITERATION UNTIL C CONVERGENCE. C C ON INPUT: C C N = DIMENSION OF X AND THE HOMOTOPY MAP. C C NFE = NUMBER OF JACOBIAN MATRIX EVALUATIONS. C C IFLAG = -2, -1, OR 0, INDICATING THE PROBLEM TYPE. C C RELERR, ABSERR = RELATIVE AND ABSOLUTE ERROR VALUES. THE ITERATION IS C CONSIDERED TO HAVE CONVERGED WHEN A POINT Y=(X,LAMBDA) IS FOUND C SUCH THAT C C |Y(NP1) - 1| <= RELERR + ABSERR AND C C ||Z|| <= RELERR*||X|| + ABSERR , WHERE C C (Z,?) IS THE NEWTON STEP TO Y=(X,LAMBDA). C C Y(1:N+1) = POINT (X(S), LAMBDA(S)) ON ZERO CURVE OF HOMOTOPY MAP. C C YP(1:N+1) = UNIT TANGENT VECTOR TO THE ZERO CURVE OF THE HOMOTOPY MAP C AT Y . C C YOLD(1:N+1) = A POINT DIFFERENT FROM Y ON THE ZERO CURVE. C C YPOLD(1:N+1) = UNIT TANGENT VECTOR TO THE ZERO CURVE OF THE HOMOTOPY C MAP AT YOLD . C C A(1:*) = PARAMETER VECTOR IN THE HOMOTOPY MAP. C C QR(1:LENQR) = THE N X N SYMMETRIC JACOBIAN MATRIX WITH RESPECT TO X C STORED IN PACKED SKYLINE STORAGE FORMAT. LENQR AND PIVOT C DESCRIBE THE DATA STRUCTURE IN QR . C C LENQR = LENGTH OF THE ONE-DIMENSIONAL ARRAY QR USED TO CONTAIN THE C N X N SYMMETRIC JACOBIAN MATRIX WITH RESPECT TO X IN PACKED C SKYLINE STORAGE FORMAT. C C PIVOT(1:N+2) = INDICES OF THE DIAGONAL ELEMENTS OF THE N X N SYMMETRIC C JACOBIAN MATRIX (WITH RESPECT TO X) WITHIN QR . C C WORK(1:13*(N+1)+2*N+LENQR) = WORK ARRAY SPLIT UP AND USED FOR THE C CALCULATION OF THE JACOBIAN MATRIX KERNEL, THE NEWTON STEP, C AND INTERPOLATION. C C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS, C WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES C RHO, RHOJS. C C ON OUTPUT: C C N , RELERR , ABSERR , A ARE UNCHANGED. C C NFE HAS BEEN UPDATED. C C IFLAG C = -2, -1, OR 0 (UNCHANGED) ON A NORMAL RETURN. C C = 4 IF THE PRECONDITIONED CONJUGATE GRADIENT ITERATION FAILED TO C CONVERGE (MOST LIKELY DUE TO A JACOBIAN MATRIX WITH RANK < N). C THE ITERATION WAS NOT COMPLETED. C C = 6 IF THE INTERPOLATION/NEWTON ITERATION FAILED TO CONVERGE. C Y AND YOLD CONTAIN THE LAST TWO POINTS FOUND ON THE C ZERO CURVE. C C Y IS THE POINT ON THE ZERO CURVE OF THE HOMOTOPY MAP AT LAMBDA = 1 . C C C CALLS D1MACH , DAXPY , DCOPY , DNRM2 , ROOT , TANGNS . C DOUBLE PRECISION ABSERR,AERR,D1MACH,DD001,DD0011,DD01,DD011, $ DELS,DNRM2,F0,F1,FP0,FP1,QOFS,QSOUT,RELERR,RERR,S,SA,SB, $ SOUT,U INTEGER IFLAG,IPP,IRHO,ITANGW,ITZ,IW,IWP,IZ0,IZ1,JUDY,JW, $ LCODE,LENQR,LIMIT,N,NFE,NP1 C C ***** ARRAY DECLARATIONS. ***** C DOUBLE PRECISION Y(N+1),YP(N+1),YOLD(N+1),YPOLD(N+1),A(N), $ QR(LENQR),WORK(13*(N+1)+2*N+LENQR),PAR(1) INTEGER PIVOT(N+2),IPAR(1) C C ***** END OF DIMENSIONAL INFORMATION. ***** C C THE LIMIT ON THE NUMBER OF ITERATIONS ALLOWED MAY BE CHANGED BY C CHANGING THE FOLLOWING PARAMETER STATEMENT: PARAMETER (LIMIT=20) C C DEFINITION OF HERMITE CUBIC INTERPOLANT VIA DIVIDED DIFFERENCES. C DD01(F0,F1,DELS)=(F1-F0)/DELS DD001(F0,FP0,F1,DELS)=(DD01(F0,F1,DELS)-FP0)/DELS DD011(F0,F1,FP1,DELS)=(FP1-DD01(F0,F1,DELS))/DELS DD0011(F0,FP0,F1,FP1,DELS)=(DD011(F0,F1,FP1,DELS) - $ DD001(F0,FP0,F1,DELS))/DELS QOFS(F0,FP0,F1,FP1,DELS,S)=((DD0011(F0,FP0,F1,FP1,DELS)*(S-DELS) + $ DD001(F0,FP0,F1,DELS))*S + FP0)*S + F0 C C U=D1MACH(4) RERR=MAX(RELERR,U) AERR=MAX(ABSERR,0.0D0) NP1=N+1 IPP=1 IRHO=N+1 IW=IRHO+N IWP=IW+NP1 ITZ=IWP+NP1 IZ0=ITZ+NP1 IZ1=IZ0+NP1 ITANGW=IZ1+NP1 C C ***** MAIN LOOP. ***** C 100 DO 300 JUDY=1,LIMIT DO 110 JW=1,NP1 WORK(ITZ+JW-1)=Y(JW)-YOLD(JW) 110 CONTINUE DELS=DNRM2(NP1,WORK(ITZ),1) C C USING TWO POINTS AND TANGENTS ON THE HOMOTOPY ZERO CURVE, CONSTRUCT C THE HERMITE CUBIC INTERPOLANT Q(S). THEN USE ROOT TO FIND THE S C CORRESPONDING TO LAMBDA = 1 . THE TWO POINTS ON THE ZERO CURVE ARE C ALWAYS CHOSEN TO BRACKET LAMBDA=1, WITH THE BRACKETING INTERVAL C ALWAYS BEING [0, DELS]. C SA=0.0 SB=DELS LCODE=1 130 CALL ROOT(SOUT,QSOUT,SA,SB,RERR,AERR,LCODE) IF (LCODE .GT. 0) GO TO 140 QSOUT=QOFS(YOLD(NP1),YPOLD(NP1),Y(NP1),YP(NP1),DELS,SOUT) - 1.0 GO TO 130 C IF LAMBDA = 1 WERE BRACKETED, ROOT CANNOT FAIL. 140 IF (LCODE .GT. 2) THEN IFLAG=6 RETURN ENDIF C C CALCULATE Q(SA) AS THE INITIAL POINT FOR A NEWTON ITERATION. DO 150 JW=1,NP1 WORK(IW+JW-1)=QOFS(YOLD(JW),YPOLD(JW),Y(JW),YP(JW),DELS,SA) 150 CONTINUE C CALCULATE NEWTON STEP AT Q(SA). CALL TANGNS(SA,WORK(IW),WORK(IWP),WORK(ITZ),YPOLD,A,QR,LENQR, $ PIVOT,WORK(IPP),WORK(IRHO),WORK(ITANGW),NFE,N,IFLAG, $ PAR,IPAR) IF (IFLAG .GT. 0) RETURN C NEXT POINT = CURRENT POINT + NEWTON STEP. CALL DAXPY(NP1,1.0D0,WORK(ITZ),1,WORK(IW),1) C GET THE TANGENT WP AT W AND THE NEXT NEWTON STEP IN TZ . CALL TANGNS(SA,WORK(IW),WORK(IWP),WORK(ITZ),YPOLD,A,QR,LENQR, $ PIVOT,WORK(IPP),WORK(IRHO),WORK(ITANGW),NFE,N,IFLAG, $ PAR,IPAR) IF (IFLAG .GT. 0) RETURN C TAKE NEWTON STEP AND CHECK CONVERGENCE. CALL DAXPY(NP1,1.0D0,WORK(ITZ),1,WORK(IW),1) IF ((ABS(WORK(IW+N)-1.0) .LE. RERR+AERR) .AND. $ (DNRM2(N,WORK(ITZ),1) .LE. RERR*DNRM2(N,WORK(IW),1)+AERR)) $ THEN CALL DCOPY(NP1,WORK(IW),1,Y,1) RETURN ENDIF C IF THE ITERATION HAS NOT CONVERGED, DISCARD ONE OF THE OLD POINTS C SUCH THAT LAMBDA = 1 IS STILL BRACKETED. IF ((YOLD(NP1)-1.0)*(WORK(IW+N)-1.0) .GT. 0.0) THEN CALL DCOPY(NP1,WORK(IW),1,YOLD,1) CALL DCOPY(NP1,WORK(IWP),1,YPOLD,1) ELSE CALL DCOPY(NP1,WORK(IW),1,Y,1) CALL DCOPY(NP1,WORK(IWP),1,YP,1) ENDIF 300 CONTINUE C C ***** END OF MAIN LOOP. ***** C C THE ALTERNATING OSCULATORY CUBIC INTERPOLATION AND NEWTON ITERATION C HAS NOT CONVERGED IN LIMIT STEPS. ERROR RETURN. IFLAG=6 RETURN END SUBROUTINE ROOTQF(N,NFE,IFLAG,RELERR,ABSERR,Y,YP,YOLD, $ YPOLD,A,QT,R,DZ,Z,W,T,F0,F1,PAR,IPAR) C C ROOTQF FINDS THE POINT YBAR = (1, XBAR) ON THE ZERO CURVE OF THE C HOMOTOPY MAP. IT STARTS WITH TWO POINTS YOLD=(LAMBDAOLD,XOLD) AND C Y=(LAMBDA,X) SUCH THAT LAMBDAOLD < 1 <= LAMBDA, AND ALTERNATES C BETWEEN USING A SECANT METHOD TO FIND A PREDICTED POINT ON THE C HYPERPLANE LAMBDA=1, AND TAKING A QUASI-NEWTON STEP TO RETURN TO THE C ZERO CURVE OF THE HOMOTOPY MAP. C C C ON INPUT: C C N = DIMENSION OF X. C C NFE = NUMBER OF JACOBIAN MATRIX EVALUATIONS. C C IFLAG = -2, -1, OR 0, INDICATING THE PROBLEM TYPE. C C RELERR, ABSERR = RELATIVE AND ABSOLUTE ERROR VALUES. THE ITERATION IS C CONSIDERED TO HAVE CONVERGED WHEN A POINT Y=(LAMBDA,X) IS FOUND C SUCH THAT C C |Y(1) - 1| <= RELERR + ABSERR AND C C ||DZ|| <= RELERR*||Y|| + ABSERR, WHERE C C DZ IS THE QUASI-NEWTON STEP TO Y. C C Y(1:N+1) = POINT (LAMBDA(S), X(S)) ON ZERO CURVE OF HOMOTOPY MAP. C C YP(1:N+1) = UNIT TANGENT VECTOR TO THE ZERO CURVE OF THE HOMOTOPY MAP C AT Y. C C YOLD(1:N+1) = A POINT DIFFERENT FROM Y ON THE ZERO CURVE. C C YPOLD(1:N+1) = UNIT TANGENT VECTOR TO THE ZERO CURVE OF THE HOMOTOPY C MAP AT YOLD. C C A(1:*) = PARAMETER VECTOR IN THE HOMOTOPY MAP. C C QT(1:N+1,1:N+1) CONTAINS Q TRANSPOSE OF THE QR FACTORIZATION OF C THE AUGMENTED JACOBIAN MATRIX EVALUATED AT THE POINT Y. C C R((N+1)*(N+2)/2) CONTAINS THE UPPER TRIANGLE OF THE R PART OF C OF THE QR FACTORIZATION, STORED BY ROWS. C C DZ(1:N+1), Z(1:N+1), W(1:N+1), T(1:N+1), F0(1:N+1), F1(1:N+1) C ARE WORK ARRAYS USED FOR THE QUASI-NEWTON STEP AND THE SECANT C STEP. C C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS, C WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES C RHO, RHOJAC. C C C ON OUTPUT: C C N, RELERR, ABSERR, AND A ARE UNCHANGED. C C NFE HAS BEEN UPDATED. C C IFLAG C = -2, -1, OR 0 (UNCHANGED) ON A NORMAL RETURN. C C = 4 IF A SINGULAR JACOBIAN MATRIX OCCURRED. THE C ITERATION WAS NOT COMPLETED. C C = 6 IF THE ITERATION FAILED TO CONVERGE. Y AND YOLD CONTAIN C THE LAST TWO POINTS OBTAINED BY QUASI-NEWTON STEPS, AND YP C CONTAINS A POINT OPPOSITE OF THE HYPERPLANE LAMBDA=1 FROM C Y. C C Y IS THE POINT ON THE ZERO CURVE OF THE HOMOTOPY MAP AT LAMBDA = 1. C C YP AND YOLD CONTAIN POINTS NEAR THE SOLUTION. C C CALLS D1MACH, DAXPY, DCOPY, DDOT, DNRM2, F (OR RHO), C QRSLQF, ROOT, UPQRQF. C C ***** DECLARATIONS ***** C C FUNCTION DECLARATIONS C DOUBLE PRECISION D1MACH, DDOT, DNRM2, QOFS C C LOCAL VARIABLES C DOUBLE PRECISION AERR, DD001, DD0011, DD01, DD011, DELS, ETA, $ ONE, P0, P1, PP0, PP1, QSOUT, RERR, S, SA, SB, SOUT, $ U, ZERO INTEGER ISTEP, I, LCODE, LIMIT,NP1 LOGICAL BRACK C C SCALAR ARGUMENTS C DOUBLE PRECISION RELERR, ABSERR INTEGER N, NFE, IFLAG C C ARRAY DECLARATIONS C DOUBLE PRECISION Y(N+1), YP(N+1), YOLD(N+1), YPOLD(N+1), A(N), $ QT(N+1:N+1), R((N+1)*(N+2)/2), DZ(N+1), Z(N+1), W(N+1), $ T(N+1), F0(N+1), F1(N+1), PAR(1) INTEGER IPAR(1) C C ***** END OF DECLARATIONS ***** C C C DEFINITION OF HERMITE CUBIC INTERPOLANT VIA DIVIDED DIFFERENCES. C DD01(P0,P1,DELS)=(P1-P0)/DELS DD001(P0,PP0,P1,DELS)=(DD01(P0,P1,DELS)-PP0)/DELS DD011(P0,P1,PP1,DELS)=(PP1-DD01(P0,P1,DELS))/DELS DD0011(P0,PP0,P1,PP1,DELS)=(DD011(P0,P1,PP1,DELS) - $ DD001(P0,PP0,P1,DELS))/DELS QOFS(P0,PP0,P1,PP1,DELS,S)=((DD0011(P0,PP0,P1,PP1,DELS)* $ (S-DELS) + DD001(P0,PP0,P1,DELS))*S + PP0)*S + P0 C C ***** FIRST EXECUTABLE STATEMENT ***** C C ***** INITIALIZATION ***** C C ETA = PARAMETER FOR BROYDEN'S UPDATE. C LIMIT = MAXIMUM NUMBER OF ITERATIONS ALLOWED. C ONE=1.0 ZERO=0.0 U=D1MACH(4) RERR=MAX(RELERR,U) AERR=MAX(ABSERR,ZERO) NP1=N+1 ETA = 100.0*U LIMIT = 2*(INT(-LOG10(AERR+RERR*DNRM2(NP1,Y,1)))+1) C C F0 = (RHO(Y), YP*Y) TRANSPOSE. C IF (IFLAG .EQ. -2) THEN C C CURVE TRACKING PROBLEM. C CALL RHO(A,Y(1),Y(2),F0,PAR,IPAR) ELSE IF (IFLAG .EQ. -1) THEN C C ZERO FINDING PROBLEM. C CALL F(Y(2),F0) DO 10 I=1,N F0(I) = Y(1)*F0(I) + (1.0-Y(1))*(Y(I+1)-A(I)) 10 CONTINUE ELSE C C FIXED POINT PROBLEM. C CALL F(Y(2),F0) DO 20 I=1,N F0(I) = Y(1)*(A(I)-F0(I))+Y(I+1)-A(I) 20 CONTINUE END IF F0(NP1) = DDOT(NP1,YP,1,Y,1) C C ***** END OF INITIALIZATION BLOCK ***** C C ***** COMPUTE FIRST INTERPOLANT WITH A HERMITE CUBIC ***** C C FIND DISTANCE BETWEEN Y AND YOLD. DZ=||Y-YOLD||. C CALL DCOPY(NP1,Y,1,DZ,1) CALL DAXPY(NP1,-ONE,YOLD,1,DZ,1) DELS=DNRM2(NP1,DZ,1) C C USING TWO POINTS AND TANGENTS ON THE HOMOTOPY ZERO CURVE, CONSTRUCT C THE HERMITE CUBIC INTERPOLANT Q(S). THEN USE ROOT TO FIND THE S C CORRESPONDING TO LAMBDA = 1. THE TWO POINTS ON THE ZERO CURVE ARE C ALWAYS CHOSEN TO BRACKET LAMBDA=1, WITH THE BRACKETING INTERVAL C ALWAYS BEING [0, DELS]. C SA=0.0 SB=DELS LCODE=1 40 CALL ROOT(SOUT,QSOUT,SA,SB,RERR,AERR,LCODE) IF (LCODE .GT. 0) GO TO 50 QSOUT=QOFS(YOLD(1),YPOLD(1),Y(1),YP(1),DELS,SOUT) - 1.0 GO TO 40 C C IF LAMBDA = 1 WERE BRACKETED, ROOT CANNOT FAIL. C 50 IF (LCODE .GT. 2) THEN IFLAG=6 RETURN ENDIF C C CALCULATE Q(SA) AS THE INITIAL POINT FOR A NEWTON ITERATION. C DO 60 I=1,NP1 Z(I)=QOFS(YOLD(I),YPOLD(I),Y(I),YP(I),DELS,SA) 60 CONTINUE C C CALCULATE DZ = Z-Y. C CALL DCOPY(NP1,Z,1,DZ,1) CALL DAXPY(NP1,-ONE,Y,1,DZ,1) C C ***** END OF CALCULATION OF CUBIC INTERPOLANT ***** C C TANGENT INFORMATION YPOLD IS NO LONGER NEEDED. HEREAFTER, YPOLD C REPRESENTS THE MOST RECENT POINT WHICH IS ON THE OPPOSITE SIDE OF C LAMBDA=1 FROM Y. C C ***** PREPARE FOR MAIN LOOP ***** C CALL DCOPY(NP1,YOLD,1,YPOLD,1) C C INITIALIZE BRACK TO INDICATE THAT THE POINTS Y AND YOLD BRACKET C LAMBDA=1, THUS YOLD = YPOLD. C BRACK = .TRUE. C C ***** MAIN LOOP ***** C DO 300 ISTEP=1,LIMIT C C UPDATE JACOBIAN MATRIX. C C F1=(RHO(Z), YP*Z) TRANSPOSE. C IF (IFLAG .EQ. -2) THEN CALL RHO(A,Z(1),Z(2),F1,PAR,IPAR) ELSE IF (IFLAG .EQ. -1) THEN CALL F(Z(2),F1) DO 80 I=1,N F1(I) = Z(1)*F1(I) + (1-Z(1))*(Z(I+1)-A(I)) 80 CONTINUE ELSE CALL F(Z(2),F1) DO 90 I=1,N F1(I) = Z(1)*(A(I)-F1(I))+Z(I+1)-A(I) 90 CONTINUE END IF F1(NP1) = DDOT(NP1,YP,1,Z,1) C C C PERFORM BROYDEN UPDATE. C CALL UPQRQF(NP1,ETA,DZ,F0,F1,QT,R,W,T) C C QUASI-NEWTON STEP. C C COMPUTE NEWTON STEP. C CALL DCOPY(N,F1,1,DZ,1) CALL DSCAL(N,-ONE,DZ,1) DZ(NP1) = 0.0 CALL QRSLQF(QT,R,DZ,W,NP1) C C TAKE NEWTON STEP. C CALL DCOPY(NP1,Z,1,W,1) CALL DAXPY(NP1,ONE,DZ,1,Z,1) C C CHECK FOR CONVERGENCE. C IF ((ABS(Z(1)-1.0) .LE. RERR+AERR) .AND. $ (DNRM2(NP1,DZ,1) .LE. RERR*DNRM2(N,Z(2),1)+AERR)) THEN CALL DCOPY(NP1,Z,1,Y,1) RETURN END IF C C PREPARE FOR NEXT ITERATION. C C F0 = F1. C CALL DCOPY(NP1,F1,1,F0,1) C C IF Z(1) = 1.0 THEN PERFORM QUASI-NEWTON ITERATION AGAIN C WITHOUT COMPUTING A NEW PREDICTOR. C IF (ABS(Z(1)-1.0) .LE. RERR+AERR) THEN CALL DCOPY(NP1,Z,1,DZ,1) CALL DAXPY(NP1,-ONE,W,1,DZ,1) GOTO 300 END IF C C UPDATE Y AND YOLD. C CALL DCOPY(NP1,Y,1,YOLD,1) CALL DCOPY(NP1,Z,1,Y,1) C C UPDATE YPOLD SUCH THAT YPOLD IS THE MOST RECENT POINT C OPPOSITE OF LAMBDA=1 FROM Y. SET BRACK = .TRUE. IFF C Y & YOLD BRACKET LAMBDA=1 SO THAT YPOLD=YOLD. C IF ((Y(1)-1.0)*(YOLD(1)-1.0) .GT. 0) THEN BRACK = .FALSE. ELSE BRACK = .TRUE. CALL DCOPY(NP1,YOLD,1,YPOLD,1) END IF C C COMPUTE DELS = ||Y-YPOLD||. C CALL DCOPY(NP1,Y,1,DZ,1) CALL DAXPY(NP1,-ONE,YPOLD,1,DZ,1) DELS=DNRM2(NP1,DZ,1) C C COMPUTE DZ FOR THE LINEAR PREDICTOR Z = Y + DZ, C WHERE DZ = SA*(YOLD-Y). C SA = (1.0-Y(1))/(YOLD(1)-Y(1)) CALL DCOPY(NP1,YOLD,1,DZ,1) CALL DAXPY(NP1,-ONE,Y,1,DZ,1) CALL DSCAL(NP1,SA,DZ,1) C C TO INSURE STABILITY, THE LINEAR PREDICTION MUST BE NO FARTHER C FROM Y THAN YPOLD IS. THIS IS GUARANTEED IF BRACK = .TRUE. C IF LINEAR PREDICTION IS TOO FAR AWAY, USE BRACKETING POINTS C TO COMPUTE LINEAR PREDICTION. C IF (.NOT. BRACK) THEN IF (DNRM2(NP1,DZ,1) .GT. DELS) THEN C C COMPUTE DZ = SA*(YPOLD-Y). C SA = (1.0-Y(1))/(YPOLD(1)-Y(1)) CALL DCOPY(NP1,YPOLD,1,DZ,1) CALL DAXPY(NP1,-ONE,Y,1,DZ,1) CALL DSCAL(NP1,SA,DZ,1) END IF END IF C C COMPUTE PREDICTOR Z = Y+DZ, AND DZ = NEW Z - OLD Z (USED FOR C QUASI-NEWTON UPDATE). C CALL DAXPY(NP1,ONE,DZ,1,Z,1) CALL DCOPY(NP1,Z,1,DZ,1) CALL DAXPY(NP1,-ONE,W,1,DZ,1) 300 CONTINUE C C ***** END OF MAIN LOOP. ***** C C THE ALTERNATING OSCULATORY LINEAR PREDICTION AND QUASI-NEWTON C CORRECTION HAS NOT CONVERGED IN LIMIT STEPS. ERROR RETURN. IFLAG=6 RETURN C C ***** END OF SUBROUTINE ROOTQF ***** END SUBROUTINE ROOTQS(N,NFE,IFLAG,LENQR,RELERR,ABSERR,Y,YP,YOLD, $ YPOLD,A,QR,PIVOT,PP,RHOVEC,Z,DZ,WORK,PAR,IPAR) C C ROOTQS FINDS THE POINT YBAR = (XBAR, 1) ON THE ZERO CURVE OF THE C HOMOTOPY MAP. IT STARTS WITH TWO POINTS YOLD=(XOLD,LAMBDAOLD) AND C Y=(X,LAMBDA) SUCH THAT LAMBDAOLD < 1 <= LAMBDA, AND ALTERNATES C BETWEEN USING A SECANT METHOD TO FIND A PREDICTED POINT ON THE C HYPERPLANE LAMBDA=1, AND TAKING A NEWTON STEP TO RETURN TO THE C ZERO CURVE OF THE HOMOTOPY MAP. C C C ON INPUT: C C N = DIMENSION OF X. C C NFE = NUMBER OF JACOBIAN MATRIX EVALUATIONS. C C IFLAG = -2, -1, OR 0, INDICATING THE PROBLEM TYPE. C C LENQR = THE LENGTH OF THE ONE-DIMENSIONAL ARRAY QR. C C RELERR, ABSERR = RELATIVE AND ABSOLUTE ERROR VALUES. THE ITERATION IS C CONSIDERED TO HAVE CONVERGED WHEN A POINT Y=(X,LAMBDA) IS FOUND C SUCH THAT C C |Y(N+1) - 1| <= RELERR + ABSERR AND C C ||DZ|| <= RELERR*||Y|| + ABSERR, WHERE C C DZ IS THE NEWTON STEP TO Y. C C Y(1:N+1) = POINT (X(S),LAMBDA(S)) ON ZERO CURVE OF HOMOTOPY MAP. C C YP(1:N+1) = UNIT TANGENT VECTOR TO THE ZERO CURVE OF THE HOMOTOPY MAP C AT Y. C C YOLD(1:N+1) = A POINT DIFFERENT FROM Y ON THE ZERO CURVE. C C YPOLD(1:N+1) = UNIT TANGENT VECTOR TO THE ZERO CURVE OF THE HOMOTOPY C MAP AT YOLD. C C A(1:*) = PARAMETER VECTOR IN THE HOMOTOPY MAP. C C QR(1:LENQR) IS A WORK ARRAY CONTAINING THE N X N SYMMETRIC C JACOBIAN MATRIX WITH RESPECT TO X STORED IN PACKED SKYLINE C STORAGE FORMAT. LENQR AND PIVOT DESCRIBE THE DATA C STRUCTURE IN QR. (SEE SUBROUTINE PCGQS FOR A DESCRIPTION C OF THIS DATA STRUCTURE). C C PIVOT(1:N+2) IS A WORK ARRAY WHOSE FIRST N+1 COMPONENTS CONTAIN C THE INDICES OF THE DIAGONAL ELEMENTS OF THE N X N SYMMETRIC C JACOBIAN MATRIX (WITH RESPECT TO X) WITHIN QR. C C PP(1:N) IS A WORK ARRAY CONTAINING THE NEGATIVE OF THE LAST COLUMN C OF THE JACOBIAN MATRIX -[D RHO/D LAMBDA]. C C RHOVEC(1:N+1), Z(1:N+1), DZ(1:N+1) ARE ALL WORK ARRAYS C USED TO CALCULATE THE NEWTON STEPS. C C WORK(1:6*(N+1)+LENQR) IS A WORK ARRAY USED BY THE CONJUGATE GRADIENT C ALGORITHM TO SOLVE LINEAR SYSTEMS. C C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS, C WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES C RHO, RHOJS. C C C ON OUTPUT: C C N, LENQR, RELERR, ABSERR, A ARE UNCHANGED. C C NFE HAS BEEN UPDATED. C C IFLAG C = -2, -1, OR 0 (UNCHANGED) ON A NORMAL RETURN. C C = 4 IF A SINGULAR JACOBIAN MATRIX HAS OCCURRED. THE C ITERATION WAS NOT COMPLETED. C C = 6 IF THE ITERATION FAILED TO CONVERGE. Y AND YOLD CONTAIN C THE LAST TWO POINTS OBTAINED BY NEWTON STEPS, AND YP C CONTAINS A POINT OPPOSITE OF THE HYPERPLANE LAMBDA=1 FROM Y. C C Y IS THE POINT ON THE ZERO CURVE OF THE HOMOTOPY MAP AT LAMBDA = 1. C C YP, AND YOLD CONTAIN POINTS NEAR THE SOLUTION. C C CALLS D1MACH, DAXPY, DCOPY, DNRM2, F (OR RHO), C FJACS (OR RHOJS), PCGQS, ROOT C C ***** DECLARATIONS ***** C C FUNCTION DECLARATIONS C DOUBLE PRECISION D1MACH, DNRM2, QOFS C C LOCAL VARIABLES C DOUBLE PRECISION AERR, DD001, DD0011, DD01, DD011, DELS, $ LAMBDA, ONE, P0, P1, PP0, PP1, QSOUT, RERR, S, SA, SB, $ SIGMA, SOUT, U, ZERO INTEGER ISTEP, I, J, LCODE, LIMIT, NP1, ZU LOGICAL BRACK C C SCALAR ARGUMENTS C DOUBLE PRECISION RELERR, ABSERR INTEGER N, NFE, IFLAG, LENQR C C ARRAY DECLARATIONS C DOUBLE PRECISION Y(N+1), YP(N+1), YOLD(N+1), YPOLD(N+1), A(N), $ QR(LENQR), PP(N), RHOVEC(N+1), Z(N+1), DZ(N+1), $ WORK(6*(N+1)+LENQR), PAR(1) INTEGER PIVOT(N+2), IPAR(1) C C ***** END OF DECLARATIONS ***** C C C DEFINITION OF HERMITE CUBIC INTERPOLANT VIA DIVIDED DIFFERENCES. C DD01(P0,P1,DELS)=(P1-P0)/DELS DD001(P0,PP0,P1,DELS)=(DD01(P0,P1,DELS)-PP0)/DELS DD011(P0,P1,PP1,DELS)=(PP1-DD01(P0,P1,DELS))/DELS DD0011(P0,PP0,P1,PP1,DELS)=(DD011(P0,P1,PP1,DELS) - $ DD001(P0,PP0,P1,DELS))/DELS QOFS(P0,PP0,P1,PP1,DELS,S)=((DD0011(P0,PP0,P1,PP1,DELS)* $ (S-DELS) + DD001(P0,PP0,P1,DELS))*S + PP0)*S + P0 C C ***** FIRST EXECUTABLE STATEMENT ***** C C ***** INITIALIZATION ***** C C LIMIT = MAXIMUM NUMBER OF ITERATIONS ALLOWED. C ONE=1.0 ZERO=0.0 U=D1MACH(4) RERR=MAX(RELERR,U) AERR=MAX(ABSERR,ZERO) NP1=N+1 LIMIT = 2*(INT(-LOG10(AERR+RERR*DNRM2(NP1,Y,1)))+1) ZU=N+2 C C ***** END OF INITIALIZATION BLOCK ***** C C ***** COMPUTE FIRST INTERPOLANT WITH A HERMITE CUBIC ***** C C FIND DISTANCE BETWEEN Y AND YOLD. DZ=||Y-YOLD||. C CALL DCOPY(NP1,Y,1,DZ,1) CALL DAXPY(NP1,-ONE,YOLD,1,DZ,1) DELS=DNRM2(NP1,DZ,1) C C USING TWO POINTS AND TANGENTS ON THE HOMOTOPY ZERO CURVE, CONSTRUCT C THE HERMITE CUBIC INTERPOLANT Q(S). THEN USE ROOT TO FIND THE S C CORRESPONDING TO LAMBDA = 1. THE TWO POINTS ON THE ZERO CURVE ARE C ALWAYS CHOSEN TO BRACKET LAMBDA=1, WITH THE BRACKETING INTERVAL C ALWAYS BEING [0, DELS]. C SA=0.0 SB=DELS LCODE=1 40 CALL ROOT(SOUT,QSOUT,SA,SB,RERR,AERR,LCODE) IF (LCODE .GT. 0) GO TO 50 QSOUT=QOFS(YOLD(NP1),YPOLD(NP1),Y(NP1),YP(NP1),DELS,SOUT) $ - 1.0 GO TO 40 C C IF LAMBDA = 1 WERE BRACKETED, ROOT CANNOT FAIL. C 50 IF (LCODE .GT. 2) THEN IFLAG=6 RETURN ENDIF C C CALCULATE Q(SA) AS THE INITIAL POINT FOR A NEWTON ITERATION. C DO 60 I=1,NP1 Z(I)=QOFS(YOLD(I),YPOLD(I),Y(I),YP(I),DELS,SA) 60 CONTINUE C C ***** END OF CALCULATION OF CUBIC INTERPOLANT ***** C C TANGENT INFORMATION YPOLD IS NO LONGER NEEDED. HEREAFTER, YPOLD C REPRESENTS THE MOST RECENT POINT WHICH IS ON THE OPPOSITE SIDE OF C LAMBDA=1 FROM Y. C C ***** PREPARE FOR MAIN LOOP ***** C CALL DCOPY(NP1,YOLD,1,YPOLD,1) C C INITIALIZE BRACK TO INDICATE THAT THE POINTS Y AND YOLD BRACKET C LAMBDA=1, THUS YOLD = YPOLD. C BRACK = .TRUE. C C ***** MAIN LOOP ***** C DO 300 ISTEP=1,LIMIT C C SET STARTING POINTS FOR CONJUGATE GRADIENT ALGORITHM TO ZERO. C DO 70 J=ZU,ZU+2*N+1 WORK(J) = 0.0 70 CONTINUE C C COMPUTE NEWTON STEP. C C COMPUTE QR = [D RHO/DX], RHOVEC = RHO, -PP = (D RHO/D LAMBDA). C LAMBDA = Z(NP1) IF (IFLAG .EQ. -2) THEN C C CURVE TRACKING PROBLEM. C CALL RHOJS(A,LAMBDA,Z,QR,LENQR,PIVOT,PP,PAR,IPAR) CALL RHO(A,LAMBDA,Z,RHOVEC,PAR,IPAR) ELSE IF (IFLAG .EQ. -1) THEN C C ZERO FINDING PROBLEM. C CALL FJACS(Z,QR,LENQR,PIVOT) CALL DSCAL(LENQR,LAMBDA,QR,1) SIGMA = 1.0-LAMBDA DO 80 J=1,N QR(PIVOT(J))=QR(PIVOT(J))+SIGMA 80 CONTINUE CALL DCOPY(N,Z,1,RHOVEC,1) CALL DAXPY(N,-ONE,A,1,RHOVEC,1) CALL F(Z,PP) CALL DSCAL(N,-ONE,PP,1) CALL DAXPY(N,ONE,RHOVEC,1,PP,1) CALL DAXPY(N,-LAMBDA,PP,1,RHOVEC,1) ELSE C C FIXED POINT PROBLEM. C CALL FJACS(Z,QR,LENQR,PIVOT) CALL DSCAL(LENQR,-LAMBDA,QR,1) DO 90 J=1,N QR(PIVOT(J))=QR(PIVOT(J))+1.0 90 CONTINUE CALL DCOPY(N,Z,1,RHOVEC,1) CALL DAXPY(N,-ONE,A,1,RHOVEC,1) CALL F(Z,PP) CALL DAXPY(N,-ONE,A,1,PP,1) CALL DAXPY(N,-LAMBDA,PP,1,RHOVEC,1) END IF RHOVEC(NP1) = 0.0 NFE = NFE+1 C C SOLVE SYSTEM TO FIND NEWTON STEP. C CALL PCGQS(N,QR,LENQR,PIVOT,PP,YP,RHOVEC,DZ,WORK,IFLAG) IF (IFLAG .GT. 0) RETURN C C TAKE NEWTON STEP. C CALL DAXPY(NP1,ONE,DZ,1,Z,1) C C CHECK FOR CONVERGENCE. C IF ((ABS(Z(NP1)-1.0) .LE. RERR+AERR) .AND. $ (DNRM2(NP1,DZ,1) .LE. RERR*DNRM2(N,Z,1)+AERR)) THEN RETURN END IF C C PREPARE FOR NEXT ITERATION. C C IF LAMBDA COMPONENT OF Z=1, THEN DO NOT COMPUTE A C NEW PREDICTOR, BUT RATHER CONTINUE WITH ANOTHER NEWTON C ITERATION. C IF (ABS(Z(NP1)-1.0) .LT. RERR+AERR) GOTO 300 C C UPDATE Y AND YOLD. C CALL DCOPY(NP1,Y,1,YOLD,1) CALL DCOPY(NP1,Z,1,Y,1) C C UPDATE YPOLD SUCH THAT YPOLD IS THE MOST RECENT POINT OPPOSI C OF LAMBDA=1 FROM Y. SET BRACK = .TRUE. IFF Y & YOLD C BRACKET LAMBDA=1 SO THAT YPOLD=YOLD. C IF ((YOLD(NP1)-1.0)*(Y(NP1)-1.0) .GT. 0) THEN BRACK = .FALSE. ELSE BRACK = .TRUE. CALL DCOPY(NP1,YOLD,1,YPOLD,1) END IF C C COMPUTE DELS = ||Y-YPOLD||. C CALL DCOPY(NP1,Y,1,DZ,1) CALL DAXPY(NP1,-ONE,YPOLD,1,DZ,1) DELS=DNRM2(NP1,DZ,1) C C COMPUTE DZ FOR THE LINEAR PREDICTOR Z = DZ + Y, C WHERE DZ = SA*(YOLD-Y). C SA = (1.0-Y(NP1))/(YOLD(NP1)-Y(NP1)) CALL DCOPY(NP1,YOLD,1,DZ,1) CALL DAXPY(NP1,-ONE,Y,1,DZ,1) CALL DSCAL(NP1,SA,DZ,1) C C TO INSURE STABILITY, THE LINEAR PREDICTION MUST BE NO FARTHER C FROM Y THAN YPOLD IS. THIS IS GUARANTEED IF BRACK = .TRUE. C IF LINEAR PREDICTION IS TOO FAR AWAY, USE BRACKETING POINTS C TO COMPUTE LINEAR PREDICTION. C IF (.NOT. BRACK) THEN IF (DNRM2(NP1,DZ,1) .GT. DELS) THEN C C COMPUTE DZ = SA*(YPOLD-Y). C SA = (1.0-Y(NP1))/(YPOLD(NP1)-Y(NP1)) CALL DCOPY(NP1,YPOLD,1,DZ,1) CALL DAXPY(NP1,-ONE,Y,1,DZ,1) CALL DSCAL(NP1,SA,DZ,1) END IF END IF C C COMPUTE PREDICTOR Z = DZ+Y. C CALL DCOPY(NP1,Y,1,Z,1) CALL DAXPY(NP1,ONE,DZ,1,Z,1) 300 CONTINUE C C ***** END OF MAIN LOOP. ***** C C THE ALTERNATING OSCULATORY LINEAR PREDICTION AND NEWTON C CORRECTION HAS NOT CONVERGED IN LIMIT STEPS. ERROR RETURN. IFLAG=6 RETURN C C ***** END OF SUBROUTINE ROOTQS ***** END SUBROUTINE SCLGNP(N,NN,MMAXT,NUMT,DEG,MODE,EPS0,COEF, $ NNUMT,DDEG,CCOEF,ALPHA,BETA,RWORK,XWORK, $ FACV,FACE,COESCL,IERR) C C SCLGNP SCALES THE COEFFICIENTS OF A POLYNOMIAL SYSTEM OF N C EQUATIONS IN N UNKNOWNS, F(X)=0, WHERE THE JTH TERM OF C THE ITH EQUATION LOOKS LIKE: C C COEF(I,J) * X(1)**DEG(I,1,J) ... X(N)**DEG(I,N,J) C C THE ITH EQUATION IS SCALED BY 10**FACE(I). THE KTH C VARIABLE IS SCALED BY 10**FACV(K). IN OTHER WORDS, X(K) = C 10**FACV(K) * Y(K), WHERE Y SOLVES THE SCALED EQUATION. C THE SCALED EQUATION HAS THE SAME FORM AS THE ORIGINAL C EQUATION, EXCEPT THAT COESCL(I,J) REPLACES COEF(I,J), WHERE C C COESCL(I,J)=COEF(I,J)* 10**( FACE(I) + FACV(1)*DEG(I,1,J)+ ... C +FACV(N)*DEG(I,N,J) ) C C THE CRITERION FOR GENERATING FACE AND FACV IS THAT OF C MINIMIZING THE SUM OF SQUARES OF THE EXPONENTS OF THE SCALED C COEFFICIENTS. IT TURNS OUT THAT THIS CRITERION REDUCES TO C SOLVING A SINGLE LINEAR SYSTEM, ALPHA*X = BETA, AS DEFINED C IN THE CODE BELOW. FURTHER, THE FORM OF THE POLYNOMIAL C SYSTEM ALONE DETERMINES THE MATRIX ALPHA. THUS, IN CASES C IN WHICH MANY SYSTEMS OF THE SAME FORM, BUT WITH DIFFERENT C COEFFICIENTS, ARE TO BE SCALED, THE MATRIX ALPHA IS C UNCHANGED AND MAY BE FACTORED ONLY ONCE (BY QRFAQF). WHEN C SCLGNP IS CALLED WITH MODE=1, SCLGNP DOES NOT RECOMPUTE OR C REFACTOR THE MATRIX ALPHA. SEE MEINTJES AND MORGAN "A C METHODOLOGY FOR SOLVING CHEMICAL EQUILIBRIUM SYSTEMS" C (GENERAL MOTORS RESEARCH LABORATORIES TECHNICAL REPORT C GMR-4971). C C SUBROUTINES CALLED DIRECTLY: QRFAQF, QRSLQF. C SUBROUTINES CALLED INDIRECTLY: DAXPY, DCOPY, DDOT, DNRM2, DSCAL. C C ON INPUT: C C N IS THE NUMBER OF EQUATIONS AND THE NUMBER OF VARIABLES. C C NN IS THE DECLARED DIMENSION OF SEVERAL ARRAY INDICES. C C MMAXT IS AN UPPER BOUND ON THE SET NUMT(I), I=1 TO N. C C NUMT(I) IS THE NUMBER OF TERMS IN THE I-TH EQUATION FOR I=1 TO N. C C DEG(I,K,J) IS THE DEGREE OF THE K-TH VARIABLE IN THE C J-TH TERM OF THE I-TH EQUATION FOR I=1 TO N, J=1 TO NUMT(I), AND C K=1 TO N. C C MODE C =1 THIS IS NOT THE FIRST CALL TO SCLGNP, AND THE FORM OF THE C SYSTEM HAS NOT CHANGED. C =0 THIS IS THE FIRST CALL TO SCLGNP. C C EPS0 ZERO-EPSILON FOR TERMS (TERMS LESS THAN EPS0 IN MAGNITUDE C ARE TREATED AS ZERO BY THE SCALING ALGORITHM). C C COEF(I,J) IS THE COEFFICIENT OF THE JTH TERM OF THE ITH EQUATION C FOR I=1 TO N AND J=1 TO NUMT(N). (COEF(I,J) MAY BE ZERO.) C C NNUMT, DDEG, CCOEF, ALPHA, BETA, RWORK, AND XWORK ARE WORKSPACES. C C ON OUTPUT: C C N, NUMT, DEG, MODE, EPS0, AND COEF ARE UNCHANGED. C C FACV(I) IS THE VARIABLE SCALE FACTOR FOR THE I-TH VARIABLE, FOR C I=1 TO N. C C FACE(I) IS THE EQUATION SCALE FACTOR FOR THE I-TH EQUATION, FOR C I=1 TO N. C C COESCL(I,J) IS THE SCALED VERSION OF COEFFICIENT COEF(I,J), FOR C I=1 TO N, J=1 TO NUMT(I), UNLESS IERR=1. C C IERR C =0 IF SCALING MATRIX, ALPHA, IS WELL CONDITIONED. C =1 OTHERWISE. IN THIS CASE, ALPHA IS "REPAIRED" AND A C SCALING IS COMPUTED. C C C DECLARATION OF INPUT INTEGER N,NN,MMAXT,NUMT(NN),DEG(NN,NN+1,MMAXT) INTEGER MODE DOUBLE PRECISION EPS0,COEF DIMENSION COEF(NN,MMAXT) C C DECLARATION OF WORKSPACE INTEGER NNUMT,DDEG DOUBLE PRECISION CCOEF,ALPHA,BETA,RWORK,XWORK DIMENSION NNUMT(N),DDEG(N,N+1,MMAXT) DIMENSION CCOEF(N,MMAXT),ALPHA(2*N,2*N),BETA(2*N), $ RWORK(N*(2*N+1)),XWORK(2*N) C C DECLARATION OF OUTPUT INTEGER IERR DOUBLE PRECISION FACV,FACE,COESCL DIMENSION FACV(N),FACE(N),COESCL(N,MMAXT) C C DECLARATION OF VARIABLES INTEGER I,IDAMAX,IFLAG,INDEX,IRMAX,J,JJ,K,LENR,N2,S DOUBLE PRECISION D1MACH,DUM,LMFPN,NTUR,RTOL,SUM C SAVE C IERR=0 N2=2*N LMFPN=D1MACH(2) NTUR=D1MACH(4)*N LENR=N*(N+1)/2 C C DELETE NEAR ZERO TERMS DO 60 I=1,N JJ=0 NNUMT(I)=0 DO 40 J=1,NUMT(I) IF(ABS(COEF(I,J)) .GT. EPS0) THEN JJ=JJ+1 NNUMT(I)=NNUMT(I)+1 CCOEF(I,JJ)=COEF(I,J) DO 20 K=1,N DDEG(I,K,JJ)=DEG(I,K,J) 20 CONTINUE END IF 40 CONTINUE 60 CONTINUE DO 90 I=1,N DO 80 J=1,NNUMT(I) COESCL(I,J)=LOG10(ABS(CCOEF(I,J))) 80 CONTINUE 90 CONTINUE C C SKIP OVER THE GENERATION AND DECOMPOSITON OF MATRIX ALPHA IF MODE=1 IF (MODE .EQ. 0) THEN C C GENERATE THE MATRIX ALPHA DO 110 S=1,N DO 110 K=1,N ALPHA(S,K)=0 110 CONTINUE DO 200 S=1,N ALPHA(S,S)=NNUMT(S) 200 CONTINUE DO 300 S=1,N DO 300 I=1,N SUM=0 DO 220 J=1,NNUMT(I) SUM=SUM+DDEG(I,S,J) 220 CONTINUE ALPHA(N+S,I)=SUM 300 CONTINUE DO 400 S=1,N DO 330 K=1,N SUM=0 DO 320 I=1,N DO 310 J=1,NNUMT(I) SUM=SUM+DDEG(I,S,J)*DDEG(I,K,J) 310 CONTINUE 320 CONTINUE ALPHA(N+S,N+K)=SUM 330 CONTINUE 400 CONTINUE DO 500 S=1,N DO 500 K=1,N SUM=0 DO 420 J=1,NNUMT(S) SUM=SUM+DDEG(S,K,J) 420 CONTINUE ALPHA(S,N+K)=SUM 500 CONTINUE C C COMPUTE QR FACTORIZATION OF MATRIX ALPHA CALL QRFAQF(ALPHA,RWORK,2*N,IFLAG) C C REPAIR ILL CONDITIONED SCALING MATRIX IRMAX=IDAMAX(LENR,RWORK,1) RTOL=RWORK(IRMAX)*NTUR INDEX=1 DO 510 I=N,2,-1 IF (ABS(RWORK(INDEX)) .LT. RTOL) THEN RWORK(INDEX)=LMFPN IERR=1 ENDIF INDEX=INDEX+I 510 CONTINUE IF (ABS(RWORK(INDEX)) .LT. RTOL) THEN RWORK(INDEX)=LMFPN IERR=1 ENDIF C ENDIF C C CONTROL PASSES HERE IF MODE=1 C C C GENERATE THE COLUMN BETA DO 600 S=1,N SUM=0 DO 550 J=1,NNUMT(S) SUM=SUM+COESCL(S,J) 550 CONTINUE BETA(S)=-SUM 600 CONTINUE DO 700 S=1,N SUM=0 DO 620 I=1,N DO 610 J=1,NNUMT(I) SUM=SUM+COESCL(I,J)*DDEG(I,S,J) 610 CONTINUE 620 CONTINUE BETA(N+S)=-SUM 700 CONTINUE C C SOLVE THE LINEAR SYSTEM ALPHA * X = BETA CALL QRSLQF(ALPHA,RWORK,BETA,XWORK,2*N) C C GENERATE FACE, FACV, AND THE MATRIX COESCL DO 800 I=1,N FACE(I)=BETA(I) FACV(I)=BETA(N+I) 800 CONTINUE DO 900 I=1,N DO 820 J=1,NUMT(I) DUM = ABS(COEF(I,J)) IF (DUM .EQ. 0.0) THEN COESCL(I,J) = 0.0 ELSE SUM = FACE(I) + LOG10( DUM ) DO 810 K=1,N SUM = SUM + FACV(K)*DEG(I,K,J) 810 CONTINUE COESCL(I,J) = SIGN(10.0**(SUM), COEF(I,J)) ENDIF 820 CONTINUE 900 CONTINUE RETURN END * SUBROUTINE SINTRP(X,Y,XOUT,YOUT,YPOUT,NEQN,KOLD,PHI,IVC,IV,KGI,GI, 1 ALPHA,G,W,XOLD,P) C C***BEGIN PROLOGUE SINTRP C***DATE WRITTEN 740101 (YYMMDD) C***REVISION DATE 840201 (YYMMDD) C***CATEGORY NO. D2A2 C***KEYWORDS INITIAL VALUE ORDINARY DIFFERENTIAL EQUATIONS, C VARIABLE ORDER ADAMS METHODS, SMOOTH INTERPOLANT FOR C DEABM IN THE DEPAC PACKAGE C***AUTHOR SHAMPINE, L.F., SNLA C GORDON, M.K. C MODIFIED BY H.A. WATTS C***PURPOSE APPROXIMATES THE SOLUTION AT XOUT BY EVALUATING THE C POLYNOMIAL COMPUTED IN STEPS AT XOUT. MUST BE USED IN C CONJUNCTION WITH STEPS. C***DESCRIPTION C C WRITTEN BY L. F. SHAMPINE AND M. K. GORDON C C ABSTRACT C C C THE METHODS IN SUBROUTINE STEPS APPROXIMATE THE SOLUTION NEAR X C BY A POLYNOMIAL. SUBROUTINE SINTRP APPROXIMATES THE SOLUTION AT C XOUT BY EVALUATING THE POLYNOMIAL THERE. INFORMATION DEFINING THIS C POLYNOMIAL IS PASSED FROM STEPS SO SINTRP CANNOT BE USED ALONE. C C THIS CODE IS COMPLETELY EXPLAINED AND DOCUMENTED IN THE TEXT, C COMPUTER SOLUTION OF ORDINARY DIFFERENTIAL EQUATIONS, THE INITIAL C VALUE PROBLEM BY L. F. SHAMPINE AND M. K. GORDON. C FURTHER DETAILS ON USE OF THIS CODE ARE AVAILABLE IN *SOLVING C ORDINARY DIFFERENTIAL EQUATIONS WITH ODE, STEP, AND INTRP*, C BY L. F. SHAMPINE AND M. K. GORDON, SLA-73-1060. C C INPUT TO SINTRP -- C C THE USER PROVIDES STORAGE IN THE CALLING PROGRAM FOR THE ARRAYS IN C THE CALL LIST C DIMENSION Y(NEQN),YOUT(NEQN),YPOUT(NEQN),PHI(NEQN,16),P(NEQN), C ALPHA(12),G(13),W(12),GI(11),IV(10) C AND DEFINES C XOUT -- POINT AT WHICH SOLUTION IS DESIRED. C THE REMAINING PARAMETERS ARE DEFINED IN STEPS AND PASSED TO C SINTRP FROM THAT SUBROUTINE. C C OUTPUT FROM SINTRP -- C C YOUT(*) -- SOLUTION AT XOUT C YPOUT(*) -- DERIVATIVE OF SOLUTION AT XOUT C C THE REMAINING PARAMETERS ARE RETURNED UNALTERED FROM THEIR INPUT C VALUES. INTEGRATION WITH STEPS MAY BE CONTINUED. C C***REFERENCES SHAMPINE L.F., GORDON M.K., *SOLVING ORDINARY C DIFFERENTIAL EQUATIONS WITH ODE, STEP, AND INTRP*, C SLA-73-1060, SANDIA LABORATORIES, 1973. C WATTS H.A., SHAMPINE L.F., *A SMOOTHER INTERPOLANT FOR C DE/STEP,INTRP : II*, SAND84-0293, SANDIA LABORATORIES, C 1984. C***ROUTINES CALLED (NONE) C***END PROLOGUE SINTRP C DOUBLE PRECISION ALP,ALPHA,C,G,GAMMA,GDI,GDIF,GI,GTEMP, 1 H,HI,HMU,P,PHI,RMU,SIGMA,TEMP1,TEMP2,TEMP3,W,WTEMP, 2 X,XI,XIM1,XIQ,XOLD,XOUT,Y,YOUT,YPOUT INTEGER I,IQ,IV,IVC,IW,J,JQ,KGI,KOLD,KP1,KP2,L,M,NEQN C DIMENSION Y(NEQN),YOUT(NEQN),YPOUT(NEQN),PHI(NEQN,16),P(NEQN) DIMENSION GTEMP(13),C(13),WTEMP(13),G(13),W(12),ALPHA(12), 1 GI(11),IV(10) C C***FIRST EXECUTABLE STATEMENT KP1 = KOLD + 1 KP2 = KOLD + 2 C HI = XOUT - XOLD H = X - XOLD XI = HI/H XIM1 = XI - 1. C C INITIALIZE WTEMP(*) FOR COMPUTING GTEMP(*) C XIQ = XI DO 10 IQ = 1,KP1 XIQ = XI*XIQ TEMP1 = IQ*(IQ+1) 10 WTEMP(IQ) = XIQ/TEMP1 C C COMPUTE THE DOUBLE INTEGRAL TERM GDI C IF (KOLD .LE. KGI) GO TO 50 IF (IVC .GT. 0) GO TO 20 GDI = 1.0/TEMP1 M = 2 GO TO 30 20 IW = IV(IVC) GDI = W(IW) M = KOLD - IW + 3 30 IF (M .GT. KOLD) GO TO 60 DO 40 I = M,KOLD 40 GDI = W(KP2-I) - ALPHA(I)*GDI GO TO 60 50 GDI = GI(KOLD) C C COMPUTE GTEMP(*) AND C(*) C 60 GTEMP(1) = XI GTEMP(2) = 0.5*XI*XI C(1) = 1.0 C(2) = XI IF (KOLD .LT. 2) GO TO 90 DO 80 I = 2,KOLD ALP = ALPHA(I) GAMMA = 1.0 + XIM1*ALP L = KP2 - I DO 70 JQ = 1,L 70 WTEMP(JQ) = GAMMA*WTEMP(JQ) - ALP*WTEMP(JQ+1) GTEMP(I+1) = WTEMP(1) 80 C(I+1) = GAMMA*C(I) C C DEFINE INTERPOLATION PARAMETERS C 90 SIGMA = (WTEMP(2) - XIM1*WTEMP(1))/GDI RMU = XIM1*C(KP1)/GDI HMU = RMU/H C C INTERPOLATE FOR THE SOLUTION -- YOUT C AND FOR THE DERIVATIVE OF THE SOLUTION -- YPOUT C DO 100 L = 1,NEQN YOUT(L) = 0.0 100 YPOUT(L) = 0.0 DO 120 J = 1,KOLD I = KP2 - J GDIF = G(I) - G(I-1) TEMP2 = (GTEMP(I) - GTEMP(I-1)) - SIGMA*GDIF TEMP3 = (C(I) - C(I-1)) + RMU*GDIF DO 110 L = 1,NEQN YOUT(L) = YOUT(L) + TEMP2*PHI(L,I) 110 YPOUT(L) = YPOUT(L) + TEMP3*PHI(L,I) 120 CONTINUE DO 130 L = 1,NEQN YOUT(L) = ((1.0 - SIGMA)*P(L) + SIGMA*Y(L)) + 1 H*(YOUT(L) + (GTEMP(1) - SIGMA*G(1))*PHI(L,1)) 130 YPOUT(L) = HMU*(P(L) - Y(L)) + 1 (YPOUT(L) + (C(1) + RMU*G(1))*PHI(L,1)) C RETURN END SUBROUTINE SOLVDS(NN,A,NWK,MAXA,V) C C This subroutine solves a system of linear equations Bx=b, where C B is symmetric, and is represented by its LDU factorization. C C Input variables: C C NN -- dimension of B. C C A -- one dimensional real array containing the upper C triangular skyline portion of the LDU decomposition C of the symmetric matrix B. C C NWK -- number of elements in A. C C MAXA -- an integer array of length NN+1 which contains the C location in A of the diagonal elements of B. C By convention, MAXA(NN+1) = NWK+1 . C C V -- real array of length NN containing the vector b. C C C Output variables: C C V -- solution of the system of equations B x = b . C C C No working storage is required by this routine. C INTEGER K,KK,KL,KU,L,NN,MAXA(NN+1),N,NWK DOUBLE PRECISION A(NWK),C,V(NN) DO 180 N=1,NN KL=MAXA(N)+1 KU=MAXA(N+1)-1 IF(KU-KL)180,160,160 160 K=N C=0.0 DO 170 KK=KL,KU K=K-1 C=C+A(KK)*V(K) 170 CONTINUE V(N)=V(N)-C 180 CONTINUE 800 DO 480 N=1,NN K=MAXA(N) V(N)=V(N)/A(K) 480 CONTINUE IF (NN.EQ.1) RETURN N=NN DO 500 L=2,NN KL=MAXA(N) + 1 KU=MAXA(N+1) - 1 IF (KU-KL) 530,510,510 510 K=N DO 520 KK=KL,KU K=K - 1 V(K)=V(K) - A(KK)*V(N) 520 CONTINUE 530 N=N - 1 500 CONTINUE RETURN END SUBROUTINE STEPDS(F,NEQN,Y,X,H,EPS,WT,START,HOLD,K,KOLD, 1 CRASH,PHI,P,YP,ALPHA,W,G,KSTEPS,XOLD,IVC,IV,KGI,GI, 2 FPWA1,FPWA2,FPWA3,IFPC1,IFPWA1,FPWA4,FPWA5,IFPC2,IFPC3, 3 PAR,IPAR) C C C WRITTEN BY L. F. SHAMPINE AND M. K. GORDON C C ABSTRACT C C SUBROUTINE STEPS IS NORMALLY USED INDIRECTLY THROUGH SUBROUTINE C DEABM . BECAUSE DEABM SUFFICES FOR MOST PROBLEMS AND IS MUCH C EASIER TO USE, USING IT SHOULD BE CONSIDERED BEFORE USING STEPS C ALONE. C C SUBROUTINE STEPS INTEGRATES A SYSTEM OF NEQN FIRST ORDER ORDINARY C DIFFERENTIAL EQUATIONS ONE STEP, NORMALLY FROM X TO X+H, USING A C MODIFIED DIVIDED DIFFERENCE FORM OF THE ADAMS PECE FORMULAS. LOCAL C EXTRAPOLATION IS USED TO IMPROVE ABSOLUTE STABILITY AND ACCURACY. C THE CODE ADJUSTS ITS ORDER AND STEP SIZE TO CONTROL THE LOCAL ERROR C PER UNIT STEP IN A GENERALIZED SENSE. SPECIAL DEVICES ARE INCLUDED C TO CONTROL ROUNDOFF ERROR AND TO DETECT WHEN THE USER IS REQUESTING C TOO MUCH ACCURACY. C C THIS CODE IS COMPLETELY EXPLAINED AND DOCUMENTED IN THE TEXT, C COMPUTER SOLUTION OF ORDINARY DIFFERENTIAL EQUATIONS, THE INITIAL C VALUE PROBLEM BY L. F. SHAMPINE AND M. K. GORDON. C FURTHER DETAILS ON USE OF THIS CODE ARE AVAILABLE IN *SOLVING C ORDINARY DIFFERENTIAL EQUATIONS WITH ODE, STEP, AND INTRP*, C BY L. F. SHAMPINE AND M. K. GORDON, SLA-73-1060. C C C THE PARAMETERS REPRESENT -- C F -- SUBROUTINE TO EVALUATE DERIVATIVES C NEQN -- NUMBER OF EQUATIONS TO BE INTEGRATED C Y(*) -- SOLUTION VECTOR AT X C X -- INDEPENDENT VARIABLE C H -- APPROPRIATE STEP SIZE FOR NEXT STEP. NORMALLY DETERMINED BY C CODE C EPS -- LOCAL ERROR TOLERANCE C WT(*) -- VECTOR OF WEIGHTS FOR ERROR CRITERION C START -- LOGICAL VARIABLE SET .TRUE. FOR FIRST STEP, .FALSE. C OTHERWISE C HOLD -- STEP SIZE USED FOR LAST SUCCESSFUL STEP C K -- APPROPRIATE ORDER FOR NEXT STEP (DETERMINED BY CODE) C KOLD -- ORDER USED FOR LAST SUCCESSFUL STEP C CRASH -- LOGICAL VARIABLE SET .TRUE. WHEN NO STEP CAN BE TAKEN, C .FALSE. OTHERWISE. C YP(*) -- DERIVATIVE OF SOLUTION VECTOR AT X AFTER SUCCESSFUL C STEP C KSTEPS -- COUNTER ON ATTEMPTED STEPS C C THE VARIABLES X,XOLD,KOLD,KGI AND IVC AND THE ARRAYS Y,PHI,ALPHA,G, C W,P,IV AND GI ARE REQUIRED FOR THE INTERPOLATION SUBROUTINE SINTRP. C THE ARRAYS FPWA* AND IFPWA1 AND INTEGER CONSTANTS IFPC* ARE C WORKING STORAGE PASSED DIRECTLY THROUGH TO FODEDS. THE ARRAYS C PAR AND IPAR ARE USER PARAMETERS PASSED THROUGH TO RHOA AND RHOJS. C C INPUT TO STEPS C C FIRST CALL -- C C THE USER MUST PROVIDE STORAGE IN HIS CALLING PROGRAM FOR ALL ARRAYS C IN THE CALL LIST, NAMELY C C DIMENSION Y(NEQN),WT(NEQN),PHI(NEQN,16),P(NEQN),YP(NEQN), C 1 ALPHA(12),W(12),G(13),GI(11),IV(10), FPWA1(NEQN), C 2 FPWA2(NEQN-1),FPWA3(NEQN-1,NEQN),FPWA4(NEQN-1), C 3 FPWA5(NEQN),IFPWA1(NEQN) C -- -- **NOTE** C C THE USER MUST ALSO DECLARE START AND CRASH C LOGICAL VARIABLES AND F AN EXTERNAL SUBROUTINE, SUPPLY THE C SUBROUTINE F(X,Y,YP,FPWA1,FPWA2,FPWA3,IFPC1,IFPWA1,FPWA4,FPWA5, C IFPC2,NEQN-1,IFPC3,PAR,IPAR) TO EVALUATE C DY(I)/DX = YP(I) = F(X,Y(1),Y(2),...,Y(NEQN)) C AND INITIALIZE ONLY THE FOLLOWING PARAMETERS. C NEQN -- NUMBER OF EQUATIONS TO BE INTEGRATED C Y(*) -- VECTOR OF INITIAL VALUES OF DEPENDENT VARIABLES C X -- INITIAL VALUE OF THE INDEPENDENT VARIABLE C H -- NOMINAL STEP SIZE INDICATING DIRECTION OF INTEGRATION C AND MAXIMUM SIZE OF STEP. MUST BE VARIABLE C EPS -- LOCAL ERROR TOLERANCE PER STEP. MUST BE VARIABLE C WT(*) -- VECTOR OF NON-ZERO WEIGHTS FOR ERROR CRITERION C START -- .TRUE. C KSTEPS -- SET KSTEPS TO ZERO C DEFINE U TO BE THE MACHINE UNIT ROUNDOFF QUANTITY BY CALLING C THE FUNCTION ROUTINE D1MACH, U = D1MACH(3), OR BY C COMPUTING U SO THAT U IS THE SMALLEST POSITIVE NUMBER SUCH C THAT 1.0+U .GT. 1.0. C C STEPS REQUIRES THAT THE L2 NORM OF THE VECTOR WITH COMPONENTS C LOCAL ERROR(L)/WT(L) BE LESS THAN EPS FOR A SUCCESSFUL STEP. THE C ARRAY WT ALLOWS THE USER TO SPECIFY AN ERROR TEST APPROPRIATE C FOR HIS PROBLEM. FOR EXAMPLE, C WT(L) = 1.0 SPECIFIES ABSOLUTE ERROR, C = ABS(Y(L)) ERROR RELATIVE TO THE MOST RECENT VALUE OF THE C L-TH COMPONENT OF THE SOLUTION, C = ABS(YP(L)) ERROR RELATIVE TO THE MOST RECENT VALUE OF C THE L-TH COMPONENT OF THE DERIVATIVE, C = MAX(WT(L),ABS(Y(L))) ERROR RELATIVE TO THE LARGEST C MAGNITUDE OF L-TH COMPONENT OBTAINED SO FAR, C = ABS(Y(L))*RELERR/EPS + ABSERR/EPS SPECIFIES A MIXED C RELATIVE-ABSOLUTE TEST WHERE RELERR IS RELATIVE C ERROR, ABSERR IS ABSOLUTE ERROR AND EPS = C MAX(RELERR,ABSERR) . C C SUBSEQUENT CALLS -- C C SUBROUTINE STEPS IS DESIGNED SO THAT ALL INFORMATION NEEDED TO C CONTINUE THE INTEGRATION, INCLUDING THE STEP SIZE H AND THE ORDER C K , IS RETURNED WITH EACH STEP. WITH THE EXCEPTION OF THE STEP C SIZE, THE ERROR TOLERANCE, AND THE WEIGHTS, NONE OF THE PARAMETERS C SHOULD BE ALTERED. THE ARRAY WT MUST BE UPDATED AFTER EACH STEP C TO MAINTAIN RELATIVE ERROR TESTS LIKE THOSE ABOVE. NORMALLY THE C INTEGRATION IS CONTINUED JUST BEYOND THE DESIRED ENDPOINT AND THE C SOLUTION INTERPOLATED THERE WITH SUBROUTINE SINTRP . IF IT IS C IMPOSSIBLE TO INTEGRATE BEYOND THE ENDPOINT, THE STEP SIZE MAY BE C REDUCED TO HIT THE ENDPOINT SINCE THE CODE WILL NOT TAKE A STEP C LARGER THAN THE H INPUT. CHANGING THE DIRECTION OF INTEGRATION, C I.E., THE SIGN OF H , REQUIRES THE USER SET START = .TRUE. BEFORE C CALLING STEPS AGAIN. THIS IS THE ONLY SITUATION IN WHICH START C SHOULD BE ALTERED. C C OUTPUT FROM STEPS C C SUCCESSFUL STEP -- C C THE SUBROUTINE RETURNS AFTER EACH SUCCESSFUL STEP WITH START AND C CRASH SET .FALSE. . X REPRESENTS THE INDEPENDENT VARIABLE C ADVANCED ONE STEP OF LENGTH HOLD FROM ITS VALUE ON INPUT AND Y C THE SOLUTION VECTOR AT THE NEW VALUE OF X . ALL OTHER PARAMETERS C REPRESENT INFORMATION CORRESPONDING TO THE NEW X NEEDED TO C CONTINUE THE INTEGRATION. C C UNSUCCESSFUL STEP -- C C WHEN THE ERROR TOLERANCE IS TOO SMALL FOR THE MACHINE PRECISION, C THE SUBROUTINE RETURNS WITHOUT TAKING A STEP AND CRASH = .TRUE. . C AN APPROPRIATE STEP SIZE AND ERROR TOLERANCE FOR CONTINUING ARE C ESTIMATED AND ALL OTHER INFORMATION IS RESTORED AS UPON INPUT C BEFORE RETURNING. TO CONTINUE WITH THE LARGER TOLERANCE, THE USER C JUST CALLS THE CODE AGAIN. A RESTART IS NEITHER REQUIRED NOR C DESIRABLE. C***REFERENCES SHAMPINE L.F., GORDON M.K., *SOLVING ORDINARY C DIFFERENTIAL EQUATIONS WITH ODE, STEP, AND INTRP*, C SLA-73-1060, SANDIA LABORATORIES, 1973. C DOUBLE PRECISION ABSH,ALPHA,BETA,D1MACH,EPS,ERK,ERKM1,ERKM2, 1 ERKP1,ERR,FOURU,FPWA1,FPWA2,FPWA3,FPWA4,FPWA5,G,GI,GSTR,H, 2 HNEW,HOLD,P,PAR,P5EPS,PHI,PSI,R,REALI,REALNS,RHO,ROUND,SIG, 3 SUM,TAU,TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,TEMP6,TWO,TWOU,V, 4 W,WT,X,XOLD,Y,YP INTEGER I,IFAIL,IFPC1,IFPC2,IFPC3,IFPWA1,IM1,IPAR,IP1,IQ,IV, 1 IVC,J,JV,K,KGI,KM1,KM2,KNEW,KOLD,KP1,KP2,KPREV,KSTEPS, 2 L,LIMIT1,LIMIT2,NEQN,NS,NSM2,NSP1,NSP2 LOGICAL START,CRASH,PHASE1,NORND C DIMENSION Y(NEQN),WT(NEQN),PHI(NEQN,16),P(NEQN),YP(NEQN),PSI(12), 1 ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13),GI(11),IV(10), 2 FPWA1(NEQN),FPWA2(NEQN-1),FPWA3(IFPC1),FPWA4(NEQN-1), 3 FPWA5(6*NEQN+IFPC1),IFPWA1(NEQN+1),PAR(1),IPAR(1) DIMENSION TWO(13),GSTR(13) C C ALL LOCAL VARIABLES ARE SAVED, RATHER THAN PASSED, IN THIS C SPECIALIZED VERSION OF STEPS. C SAVE C EXTERNAL F C DATA TWO/2.0,4.0,8.0,16.0,32.0,64.0,128.0,256.0,512.0,1024.0, 1 2048.0,4096.0,8192.0/ DATA GSTR/0.500,0.0833,0.0417,0.0264,0.0188,0.0143,0.0114,0.00936, 1 0.00789,0.00679,0.00592,0.00524,0.00468/ C C C *** BEGIN BLOCK 0 *** C CHECK IF STEP SIZE OR ERROR TOLERANCE IS TOO SMALL FOR MACHINE C PRECISION. IF FIRST STEP, INITIALIZE PHI ARRAY AND ESTIMATE A C STARTING STEP SIZE. C *** C C IF STEP SIZE IS TOO SMALL, DETERMINE AN ACCEPTABLE ONE C C***FIRST EXECUTABLE STATEMENT TWOU = 2.0 * D1MACH(4) FOURU = TWOU + TWOU CRASH = .TRUE. IF(ABS(H) .GE. FOURU*ABS(X)) GO TO 5 H = SIGN(FOURU*ABS(X),H) RETURN 5 P5EPS = 0.5*EPS C C IF ERROR TOLERANCE IS TOO SMALL, INCREASE IT TO AN ACCEPTABLE VALUE C ROUND = 0.0 DO 10 L = 1,NEQN 10 ROUND = ROUND + (Y(L)/WT(L))**2 ROUND = TWOU*SQRT(ROUND) IF(P5EPS .GE. ROUND) GO TO 15 EPS = 2.0*ROUND*(1.0 + FOURU) RETURN 15 CRASH = .FALSE. G(1) = 1.0 G(2) = 0.5 SIG(1) = 1.0 IF(.NOT.START) GO TO 99 C C INITIALIZE. COMPUTE APPROPRIATE STEP SIZE FOR FIRST STEP C CALL F(X,Y,YP,FPWA1,FPWA2,FPWA3,IFPC1,IFPWA1,FPWA4,FPWA5, $ IFPC2,NEQN-1,IFPC3,PAR,IPAR) IF (IFPC3 .GT. 0) RETURN SUM = 0.0 DO 20 L = 1,NEQN PHI(L,1) = YP(L) PHI(L,2) = 0.0 20 SUM = SUM + (YP(L)/WT(L))**2 SUM = SQRT(SUM) ABSH = ABS(H) IF(EPS .LT. 16.0*SUM*H*H) ABSH = 0.25*SQRT(EPS/SUM) H = SIGN(MAX(ABSH,FOURU*ABS(X)),H) C C* U = D1MACH(3) C* BIG = SQRT(D1MACH(2)) C* CALL HSTART (F,NEQN,X,X+H,Y,YP,WT,1,U,BIG, C* 1 PHI(1,3),PHI(1,4),PHI(1,5),PHI(1,6),RPAR,IPAR,H) C HOLD = 0.0 K = 1 KOLD = 0 KPREV = 0 START = .FALSE. PHASE1 = .TRUE. NORND = .TRUE. IF(P5EPS .GT. 100.0*ROUND) GO TO 99 NORND = .FALSE. DO 25 L = 1,NEQN 25 PHI(L,15) = 0.0 99 IFAIL = 0 C *** END BLOCK 0 *** C C *** BEGIN BLOCK 1 *** C COMPUTE COEFFICIENTS OF FORMULAS FOR THIS STEP. AVOID COMPUTING C THOSE QUANTITIES NOT CHANGED WHEN STEP SIZE IS NOT CHANGED. C *** C 100 KP1 = K+1 KP2 = K+2 KM1 = K-1 KM2 = K-2 C C NS IS THE NUMBER OF STEPS TAKEN WITH SIZE H, INCLUDING THE CURRENT C ONE. WHEN K.LT.NS, NO COEFFICIENTS CHANGE C IF(H .NE. HOLD) NS = 0 IF (NS.LE.KOLD) NS = NS+1 NSP1 = NS+1 IF (K .LT. NS) GO TO 199 C C COMPUTE THOSE COMPONENTS OF ALPHA(*),BETA(*),PSI(*),SIG(*) WHICH C ARE CHANGED C BETA(NS) = 1.0 REALNS = NS ALPHA(NS) = 1.0/REALNS TEMP1 = H*REALNS SIG(NSP1) = 1.0 IF(K .LT. NSP1) GO TO 110 DO 105 I = NSP1,K IM1 = I-1 TEMP2 = PSI(IM1) PSI(IM1) = TEMP1 BETA(I) = BETA(IM1)*PSI(IM1)/TEMP2 TEMP1 = TEMP2 + H ALPHA(I) = H/TEMP1 REALI = I 105 SIG(I+1) = REALI*ALPHA(I)*SIG(I) 110 PSI(K) = TEMP1 C C COMPUTE COEFFICIENTS G(*) C C INITIALIZE V(*) AND SET W(*). C IF(NS .GT. 1) GO TO 120 DO 115 IQ = 1,K TEMP3 = IQ*(IQ+1) V(IQ) = 1.0/TEMP3 115 W(IQ) = V(IQ) IVC = 0 KGI = 0 IF (K .EQ. 1) GO TO 140 KGI = 1 GI(1) = W(2) GO TO 140 C C IF ORDER WAS RAISED, UPDATE DIAGONAL PART OF V(*) C 120 IF(K .LE. KPREV) GO TO 130 IF (IVC .EQ. 0) GO TO 122 JV = KP1 - IV(IVC) IVC = IVC - 1 GO TO 123 122 JV = 1 TEMP4 = K*KP1 V(K) = 1.0/TEMP4 W(K) = V(K) IF (K .NE. 2) GO TO 123 KGI = 1 GI(1) = W(2) 123 NSM2 = NS-2 IF(NSM2 .LT. JV) GO TO 130 DO 125 J = JV,NSM2 I = K-J V(I) = V(I) - ALPHA(J+1)*V(I+1) 125 W(I) = V(I) IF (I .NE. 2) GO TO 130 KGI = NS - 1 GI(KGI) = W(2) C C UPDATE V(*) AND SET W(*) C 130 LIMIT1 = KP1 - NS TEMP5 = ALPHA(NS) DO 135 IQ = 1,LIMIT1 V(IQ) = V(IQ) - TEMP5*V(IQ+1) 135 W(IQ) = V(IQ) G(NSP1) = W(1) IF (LIMIT1 .EQ. 1) GO TO 137 KGI = NS GI(KGI) = W(2) 137 W(LIMIT1+1) = V(LIMIT1+1) IF (K .GE. KOLD) GO TO 140 IVC = IVC + 1 IV(IVC) = LIMIT1 + 2 C C COMPUTE THE G(*) IN THE WORK VECTOR W(*) C 140 NSP2 = NS + 2 KPREV = K IF(KP1 .LT. NSP2) GO TO 199 DO 150 I = NSP2,KP1 LIMIT2 = KP2 - I TEMP6 = ALPHA(I-1) DO 145 IQ = 1,LIMIT2 145 W(IQ) = W(IQ) - TEMP6*W(IQ+1) 150 G(I) = W(1) 199 CONTINUE C *** END BLOCK 1 *** C C *** BEGIN BLOCK 2 *** C PREDICT A SOLUTION P(*), EVALUATE DERIVATIVES USING PREDICTED C SOLUTION, ESTIMATE LOCAL ERROR AT ORDER K AND ERRORS AT ORDERS K, C K-1, K-2 AS IF CONSTANT STEP SIZE WERE USED. C *** C C INCREMENT COUNTER ON ATTEMPTED STEPS C KSTEPS = KSTEPS + 1 C C CHANGE PHI TO PHI STAR C IF(K .LT. NSP1) GO TO 215 DO 210 I = NSP1,K TEMP1 = BETA(I) DO 205 L = 1,NEQN 205 PHI(L,I) = TEMP1*PHI(L,I) 210 CONTINUE C C PREDICT SOLUTION AND DIFFERENCES C 215 DO 220 L = 1,NEQN PHI(L,KP2) = PHI(L,KP1) PHI(L,KP1) = 0.0 220 P(L) = 0.0 DO 230 J = 1,K I = KP1 - J IP1 = I+1 TEMP2 = G(I) DO 225 L = 1,NEQN P(L) = P(L) + TEMP2*PHI(L,I) 225 PHI(L,I) = PHI(L,I) + PHI(L,IP1) 230 CONTINUE IF(NORND) GO TO 240 DO 235 L = 1,NEQN TAU = H*P(L) - PHI(L,15) P(L) = Y(L) + TAU 235 PHI(L,16) = (P(L) - Y(L)) - TAU GO TO 250 240 DO 245 L = 1,NEQN 245 P(L) = Y(L) + H*P(L) 250 XOLD = X X = X + H ABSH = ABS(H) CALL F(X,P,YP,FPWA1,FPWA2,FPWA3,IFPC1,IFPWA1,FPWA4,FPWA5, $ IFPC2,NEQN-1,IFPC3,PAR,IPAR) IF (IFPC3 .GT. 0) RETURN C C ESTIMATE ERRORS AT ORDERS K,K-1,K-2 C ERKM2 = 0.0 ERKM1 = 0.0 ERK = 0.0 DO 265 L = 1,NEQN TEMP3 = 1.0/WT(L) TEMP4 = YP(L) - PHI(L,1) IF(KM2)265,260,255 255 ERKM2 = ERKM2 + ((PHI(L,KM1)+TEMP4)*TEMP3)**2 260 ERKM1 = ERKM1 + ((PHI(L,K)+TEMP4)*TEMP3)**2 265 ERK = ERK + (TEMP4*TEMP3)**2 IF(KM2)280,275,270 270 ERKM2 = ABSH*SIG(KM1)*GSTR(KM2)*SQRT(ERKM2) 275 ERKM1 = ABSH*SIG(K)*GSTR(KM1)*SQRT(ERKM1) 280 TEMP5 = ABSH*SQRT(ERK) ERR = TEMP5*(G(K)-G(KP1)) ERK = TEMP5*SIG(KP1)*GSTR(K) KNEW = K C C TEST IF ORDER SHOULD BE LOWERED C IF(KM2)299,290,285 285 IF(MAX(ERKM1,ERKM2) .LE. ERK) KNEW = KM1 GO TO 299 290 IF(ERKM1 .LE. 0.5*ERK) KNEW = KM1 C C TEST IF STEP SUCCESSFUL C 299 IF(ERR .LE. EPS) GO TO 400 C *** END BLOCK 2 *** C C *** BEGIN BLOCK 3 *** C THE STEP IS UNSUCCESSFUL. RESTORE X, PHI(*,*), PSI(*) . C IF THIRD CONSECUTIVE FAILURE, SET ORDER TO ONE. IF STEP FAILS MORE C THAN THREE TIMES, CONSIDER AN OPTIMAL STEP SIZE. DOUBLE ERROR C TOLERANCE AND RETURN IF ESTIMATED STEP SIZE IS TOO SMALL FOR MACHINE C PRECISION. C *** C C RESTORE X, PHI(*,*) AND PSI(*) C PHASE1 = .FALSE. X = XOLD DO 310 I = 1,K TEMP1 = 1.0/BETA(I) IP1 = I+1 DO 305 L = 1,NEQN 305 PHI(L,I) = TEMP1*(PHI(L,I) - PHI(L,IP1)) 310 CONTINUE IF(K .LT. 2) GO TO 320 DO 315 I = 2,K 315 PSI(I-1) = PSI(I) - H C C ON THIRD FAILURE, SET ORDER TO ONE. THEREAFTER, USE OPTIMAL STEP C SIZE C 320 IFAIL = IFAIL + 1 TEMP2 = 0.5 IF(IFAIL - 3) 335,330,325 325 IF(P5EPS .LT. 0.25*ERK) TEMP2 = SQRT(P5EPS/ERK) 330 KNEW = 1 335 H = TEMP2*H K = KNEW NS = 0 IF(ABS(H) .GE. FOURU*ABS(X)) GO TO 340 CRASH = .TRUE. H = SIGN(FOURU*ABS(X),H) EPS = EPS + EPS RETURN 340 GO TO 100 C *** END BLOCK 3 *** C C *** BEGIN BLOCK 4 *** C THE STEP IS SUCCESSFUL. CORRECT THE PREDICTED SOLUTION, EVALUATE C THE DERIVATIVES USING THE CORRECTED SOLUTION AND UPDATE THE C DIFFERENCES. DETERMINE BEST ORDER AND STEP SIZE FOR NEXT STEP. C *** 400 KOLD = K HOLD = H C C CORRECT AND EVALUATE C TEMP1 = H*G(KP1) IF(NORND) GO TO 410 DO 405 L = 1,NEQN TEMP3 = Y(L) RHO = TEMP1*(YP(L) - PHI(L,1)) - PHI(L,16) Y(L) = P(L) + RHO PHI(L,15) = (Y(L) - P(L)) - RHO 405 P(L) = TEMP3 GO TO 420 410 DO 415 L = 1,NEQN TEMP3 = Y(L) Y(L) = P(L) + TEMP1*(YP(L) - PHI(L,1)) 415 P(L) = TEMP3 420 CALL F(X,Y,YP,FPWA1,FPWA2,FPWA3,IFPC1,IFPWA1,FPWA4,FPWA5, $ IFPC2,NEQN-1,IFPC3,PAR,IPAR) IF (IFPC3 .GT. 0) RETURN C C UPDATE DIFFERENCES FOR NEXT STEP C DO 425 L = 1,NEQN PHI(L,KP1) = YP(L) - PHI(L,1) 425 PHI(L,KP2) = PHI(L,KP1) - PHI(L,KP2) DO 435 I = 1,K DO 430 L = 1,NEQN 430 PHI(L,I) = PHI(L,I) + PHI(L,KP1) 435 CONTINUE C C ESTIMATE ERROR AT ORDER K+1 UNLESS: C IN FIRST PHASE WHEN ALWAYS RAISE ORDER, C ALREADY DECIDED TO LOWER ORDER, C STEP SIZE NOT CONSTANT SO ESTIMATE UNRELIABLE C ERKP1 = 0.0 IF(KNEW .EQ. KM1 .OR. K .EQ. 12) PHASE1 = .FALSE. IF(PHASE1) GO TO 450 IF(KNEW .EQ. KM1) GO TO 455 IF(KP1 .GT. NS) GO TO 460 DO 440 L = 1,NEQN 440 ERKP1 = ERKP1 + (PHI(L,KP2)/WT(L))**2 ERKP1 = ABSH*GSTR(KP1)*SQRT(ERKP1) C C USING ESTIMATED ERROR AT ORDER K+1, DETERMINE APPROPRIATE ORDER C FOR NEXT STEP C IF(K .GT. 1) GO TO 445 IF(ERKP1 .GE. 0.5*ERK) GO TO 460 GO TO 450 445 IF(ERKM1 .LE. MIN(ERK,ERKP1)) GO TO 455 IF(ERKP1 .GE. ERK .OR. K .EQ. 12) GO TO 460 C C HERE ERKP1 .LT. ERK .LT. MAX(ERKM1,ERKM2) ELSE ORDER WOULD HAVE C BEEN LOWERED IN BLOCK 2. THUS ORDER IS TO BE RAISED C C RAISE ORDER C 450 K = KP1 ERK = ERKP1 GO TO 460 C C LOWER ORDER C 455 K = KM1 ERK = ERKM1 C C WITH NEW ORDER DETERMINE APPROPRIATE STEP SIZE FOR NEXT STEP C 460 HNEW = H + H IF(PHASE1) GO TO 465 IF(P5EPS .GE. ERK*TWO(K+1)) GO TO 465 HNEW = H IF(P5EPS .GE. ERK) GO TO 465 TEMP2 = K+1 R = (P5EPS/ERK)**(1.0/TEMP2) HNEW = ABSH*MAX(0.5D0,MIN(0.9D0,R)) HNEW = SIGN(MAX(HNEW,FOURU*ABS(X)),H) 465 H = HNEW RETURN C *** END BLOCK 4 *** END SUBROUTINE STEPNF(N,NFE,IFLAG,START,CRASH,HOLD,H,RELERR, $ ABSERR,S,Y,YP,YOLD,YPOLD,A,QR,ALPHA,TZ,PIVOT,W,WP, $ Z0,Z1,SSPAR,PAR,IPAR) C C STEPNF TAKES ONE STEP ALONG THE ZERO CURVE OF THE HOMOTOPY MAP C USING A PREDICTOR-CORRECTOR ALGORITHM. THE PREDICTOR USES A HERMITE C CUBIC INTERPOLANT, AND THE CORRECTOR RETURNS TO THE ZERO CURVE ALONG C THE FLOW NORMAL TO THE DAVIDENKO FLOW. STEPNF ALSO ESTIMATES A C STEP SIZE H FOR THE NEXT STEP ALONG THE ZERO CURVE. NORMALLY C STEPNF IS USED INDIRECTLY THROUGH FIXPNF , AND SHOULD BE CALLED C DIRECTLY ONLY IF IT IS NECESSARY TO MODIFY THE STEPPING ALGORITHM'S C PARAMETERS. C C ON INPUT: C C N = DIMENSION OF X AND THE HOMOTOPY MAP. C C NFE = NUMBER OF JACOBIAN MATRIX EVALUATIONS. C C IFLAG = -2, -1, OR 0, INDICATING THE PROBLEM TYPE. C C START = .TRUE. ON FIRST CALL TO STEPNF , .FALSE. OTHERWISE. C C HOLD = ||Y - YOLD||; SHOULD NOT BE MODIFIED BY THE USER. C C H = UPPER LIMIT ON LENGTH OF STEP THAT WILL BE ATTEMPTED. H MUST BE C SET TO A POSITIVE NUMBER ON THE FIRST CALL TO STEPNF . C THEREAFTER STEPNF CALCULATES AN OPTIMAL VALUE FOR H , AND H C SHOULD NOT BE MODIFIED BY THE USER. C C RELERR, ABSERR = RELATIVE AND ABSOLUTE ERROR VALUES. THE ITERATION IS C CONSIDERED TO HAVE CONVERGED WHEN A POINT W=(LAMBDA,X) IS FOUND C SUCH THAT C C ||Z|| <= RELERR*||W|| + ABSERR , WHERE C C Z IS THE NEWTON STEP TO W=(LAMBDA,X). C C S = (APPROXIMATE) ARC LENGTH ALONG THE HOMOTOPY ZERO CURVE UP TO C Y(S) = (LAMBDA(S), X(S)). C C Y(1:N+1) = PREVIOUS POINT (LAMBDA(S), X(S)) FOUND ON THE ZERO CURVE OF C THE HOMOTOPY MAP. C C YP(1:N+1) = UNIT TANGENT VECTOR TO THE ZERO CURVE OF THE HOMOTOPY MAP C AT Y . C C YOLD(1:N+1) = A POINT BEFORE Y ON THE ZERO CURVE OF THE HOMOTOPY MAP C C YPOLD(1:N+1) = UNIT TANGENT VECTOR TO THE ZERO CURVE OF THE HOMOTOPY C MAP AT YOLD . C C A(1:*) = PARAMETER VECTOR IN THE HOMOTOPY MAP. C C QR(1:N,1:N+2), ALPHA(1:N), TZ(1:N+1), PIVOT(1:N+1), W(1:N+1), C WP(1:N+1) ARE WORK ARRAYS USED FOR THE QR FACTORIZATION (IN THE C NEWTON STEP CALCULATION) AND THE INTERPOLATION. C C Z0(1:N+1), Z1(1:N+1) ARE WORK ARRAYS USED FOR THE ESTIMATION OF THE C NEXT STEP SIZE H . C C SSPAR(1:8) = (LIDEAL, RIDEAL, DIDEAL, HMIN, HMAX, BMIN, BMAX, P) IS C A VECTOR OF PARAMETERS USED FOR THE OPTIMAL STEP SIZE ESTIMATION. C C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS, C WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES C RHO, RHOJAC. C C ON OUTPUT: C C N , A , SSPAR ARE UNCHANGED. C C NFE HAS BEEN UPDATED. C C IFLAG C = -2, -1, OR 0 (UNCHANGED) ON A NORMAL RETURN. C C = 4 IF A JACOBIAN MATRIX WITH RANK < N HAS OCCURRED. THE C ITERATION WAS NOT COMPLETED. C C = 6 IF THE ITERATION FAILED TO CONVERGE. W CONTAINS THE LAST C NEWTON ITERATE. C C START = .FALSE. ON A NORMAL RETURN. C C CRASH C = .FALSE. ON A NORMAL RETURN. C C = .TRUE. IF THE STEP SIZE H WAS TOO SMALL. H HAS BEEN C INCREASED TO AN ACCEPTABLE VALUE, WITH WHICH STEPNF MAY BE C CALLED AGAIN. C C = .TRUE. IF RELERR AND/OR ABSERR WERE TOO SMALL. THEY HAVE C BEEN INCREASED TO ACCEPTABLE VALUES, WITH WHICH STEPNF MAY C BE CALLED AGAIN. C C HOLD = ||Y - YOLD||. C C H = OPTIMAL VALUE FOR NEXT STEP TO BE ATTEMPTED. NORMALLY H SHOULD C NOT BE MODIFIED BY THE USER. C C RELERR, ABSERR ARE UNCHANGED ON A NORMAL RETURN. C C S = (APPROXIMATE) ARC LENGTH ALONG THE ZERO CURVE OF THE HOMOTOPY MAP C UP TO THE LATEST POINT FOUND, WHICH IS RETURNED IN Y . C C Y, YP, YOLD, YPOLD CONTAIN THE TWO MOST RECENT POINTS AND TANGENT C VECTORS FOUND ON THE ZERO CURVE OF THE HOMOTOPY MAP. C C C CALLS D1MACH , DNRM2 , TANGNF . C DOUBLE PRECISION ABSERR,D1MACH,DCALC,DD001,DD0011,DD01, $ DD011,DELS,DNRM2,F0,F1,FOURU,FP0,FP1,H,HFAIL,HOLD,HT, $ LCALC,QOFS,RCALC,RELERR,RHOLEN,S,TEMP,TWOU INTEGER IFLAG,ITNUM,J,JUDY,LITFH,N,NFE,NP1 LOGICAL CRASH,FAIL,START C C ***** ARRAY DECLARATIONS. ***** C DOUBLE PRECISION Y(N+1),YP(N+1),YOLD(N+1),YPOLD(N+1),A(N), $ QR(N,N+2),ALPHA(N),TZ(N+1),W(N+1),WP(N+1),Z0(N+1), $ Z1(N+1),SSPAR(8),PAR(1) INTEGER PIVOT(N+1),IPAR(1) C C ***** END OF DIMENSIONAL INFORMATION. ***** C C THE LIMIT ON THE NUMBER OF NEWTON ITERATIONS ALLOWED BEFORE REDUCING C THE STEP SIZE H MAY BE CHANGED BY CHANGING THE FOLLOWING PARAMETER C STATEMENT: PARAMETER (LITFH=4) C C DEFINITION OF HERMITE CUBIC INTERPOLANT VIA DIVIDED DIFFERENCES. C DD01(F0,F1,DELS)=(F1-F0)/DELS DD001(F0,FP0,F1,DELS)=(DD01(F0,F1,DELS)-FP0)/DELS DD011(F0,F1,FP1,DELS)=(FP1-DD01(F0,F1,DELS))/DELS DD0011(F0,FP0,F1,FP1,DELS)=(DD011(F0,F1,FP1,DELS) - $ DD001(F0,FP0,F1,DELS))/DELS QOFS(F0,FP0,F1,FP1,DELS,S)=((DD0011(F0,FP0,F1,FP1,DELS)*(S-DELS) + $ DD001(F0,FP0,F1,DELS))*S + FP0)*S + F0 C C TWOU=2.0*D1MACH(4) FOURU=TWOU+TWOU NP1=N+1 CRASH=.TRUE. C THE ARCLENGTH S MUST BE NONNEGATIVE. IF (S .LT. 0.0) RETURN C IF STEP SIZE IS TOO SMALL, DETERMINE AN ACCEPTABLE ONE. IF (H .LT. FOURU*(1.0+S)) THEN H=FOURU*(1.0+S) RETURN ENDIF C IF ERROR TOLERANCES ARE TOO SMALL, INCREASE THEM TO ACCEPTABLE VALUES. TEMP=DNRM2(NP1,Y,1) IF (.5*(RELERR*TEMP+ABSERR) .GE. TWOU*TEMP) GO TO 40 IF (RELERR .NE. 0.0) THEN RELERR=FOURU*(1.0+FOURU) ABSERR=MAX(ABSERR,0.0D0) ELSE ABSERR=FOURU*TEMP ENDIF RETURN 40 CRASH=.FALSE. IF (.NOT. START) GO TO 300 C C ***** STARTUP SECTION(FIRST STEP ALONG ZERO CURVE. ***** C FAIL=.FALSE. START=.FALSE. C DETERMINE SUITABLE INITIAL STEP SIZE. H=MIN(H, .10D0, SQRT(SQRT(RELERR*TEMP+ABSERR))) C USE LINEAR PREDICTOR ALONG TANGENT DIRECTION TO START NEWTON ITERATION YPOLD(1)=1.0 DO 50 J=2,NP1 YPOLD(J)=0.0 50 CONTINUE CALL TANGNF(S,Y,YP,YPOLD,A,QR,ALPHA,TZ,PIVOT,NFE,N,IFLAG, $ PAR,IPAR) IF (IFLAG .GT. 0) RETURN 70 DO 80 J=1,NP1 TEMP=Y(J) + H * YP(J) W(J)=TEMP Z0(J)=TEMP 80 CONTINUE DO 200 JUDY=1,LITFH RHOLEN=-1.0 C CALCULATE THE NEWTON STEP TZ AT THE CURRENT POINT W . CALL TANGNF(RHOLEN,W,WP,YPOLD,A,QR,ALPHA,TZ,PIVOT,NFE,N,IFLAG, $ PAR,IPAR) IF (IFLAG .GT. 0) RETURN C C TAKE NEWTON STEP AND CHECK CONVERGENCE. DO 90 J=1,NP1 W(J)=W(J) + TZ(J) 90 CONTINUE ITNUM=JUDY C COMPUTE QUANTITIES USED FOR OPTIMAL STEP SIZE ESTIMATION. IF (JUDY .EQ. 1) THEN LCALC=DNRM2(NP1,TZ,1) RCALC=RHOLEN DO 110 J=1,NP1 Z1(J)=W(J) 110 CONTINUE ELSE IF (JUDY .EQ. 2) THEN LCALC=DNRM2(NP1,TZ,1)/LCALC RCALC=RHOLEN/RCALC ENDIF C GO TO MOP-UP SECTION AFTER CONVERGENCE. IF (DNRM2(NP1,TZ,1) .LE. RELERR*DNRM2(NP1,W,1)+ABSERR) $ GO TO 600 C 200 CONTINUE C C NO CONVERGENCE IN LITFH ITERATIONS. REDUCE H AND TRY AGAIN. IF (H .LE. FOURU*(1.0 + S)) THEN IFLAG=6 RETURN ENDIF H=.5 * H GO TO 70 C C ***** END OF STARTUP SECTION. ***** C C ***** PREDICTOR SECTION. ***** C 300 FAIL=.FALSE. C COMPUTE POINT PREDICTED BY HERMITE INTERPOLANT. USE STEP SIZE H C COMPUTED ON LAST CALL TO STEPNF . 320 DO 330 J=1,NP1 TEMP=QOFS(YOLD(J),YPOLD(J),Y(J),YP(J),HOLD,HOLD+H) W(J)=TEMP Z0(J)=TEMP 330 CONTINUE C C ***** END OF PREDICTOR SECTION. ***** C C ***** CORRECTOR SECTION. ***** C DO 500 JUDY=1,LITFH RHOLEN=-1.0 C CALCULATE THE NEWTON STEP TZ AT THE CURRENT POINT W . CALL TANGNF(RHOLEN,W,WP,YP,A,QR,ALPHA,TZ,PIVOT,NFE,N,IFLAG, $ PAR,IPAR) IF (IFLAG .GT. 0) RETURN C C TAKE NEWTON STEP AND CHECK CONVERGENCE. DO 420 J=1,NP1 W(J)=W(J) + TZ(J) 420 CONTINUE ITNUM=JUDY C COMPUTE QUANTITIES USED FOR OPTIMAL STEP SIZE ESTIMATION. IF (JUDY .EQ. 1) THEN LCALC=DNRM2(NP1,TZ,1) RCALC=RHOLEN DO 440 J=1,NP1 Z1(J)=W(J) 440 CONTINUE ELSE IF (JUDY .EQ. 2) THEN LCALC=DNRM2(NP1,TZ,1)/LCALC RCALC=RHOLEN/RCALC ENDIF C GO TO MOP-UP SECTION AFTER CONVERGENCE. IF (DNRM2(NP1,TZ,1) .LE. RELERR*DNRM2(NP1,W,1)+ABSERR) $ GO TO 600 C 500 CONTINUE C C NO CONVERGENCE IN LITFH ITERATIONS. RECORD FAILURE AT CALCULATED H C SAVE THIS STEP SIZE, REDUCE H AND TRY AGAIN. FAIL=.TRUE. HFAIL=H IF (H .LE. FOURU*(1.0 + S)) THEN IFLAG=6 RETURN ENDIF H=.5 * H GO TO 320 C C ***** END OF CORRECTOR SECTION. ***** C C ***** MOP-UP SECTION. ***** C C YOLD AND Y ALWAYS CONTAIN THE LAST TWO POINTS FOUND ON THE ZERO C CURVE OF THE HOMOTOPY MAP. YPOLD AND YP CONTAIN THE TANGENT C VECTORS TO THE ZERO CURVE AT YOLD AND Y , RESPECTIVELY. C 600 DO 620 J=1,NP1 YOLD(J)=Y(J) YPOLD(J)=YP(J) Y(J)=W(J) YP(J)=WP(J) W(J)=Y(J) - YOLD(J) 620 CONTINUE C UPDATE ARC LENGTH. HOLD=DNRM2(NP1,W,1) S=S+HOLD C C ***** END OF MOP-UP SECTION. ***** C C ***** OPTIMAL STEP SIZE ESTIMATION SECTION. ***** C C CALCULATE THE DISTANCE FACTOR DCALC . 700 DO 710 J=1,NP1 TZ(J)=Z0(J) - Y(J) W(J)=Z1(J) - Y(J) 710 CONTINUE DCALC=DNRM2(NP1,TZ,1) IF (DCALC .NE. 0.0) DCALC=DNRM2(NP1,W,1)/DCALC C C THE OPTIMAL STEP SIZE HBAR IS DEFINED BY C C HT=HOLD * [MIN(LIDEAL/LCALC, RIDEAL/RCALC, DIDEAL/DCALC)]**(1/P) C C HBAR = MIN [ MAX(HT, BMIN*HOLD, HMIN), BMAX*HOLD, HMAX ] C C IF CONVERGENCE HAD OCCURRED AFTER 1 ITERATION, SET THE CONTRACTION C FACTOR LCALC TO ZERO. IF (ITNUM .EQ. 1) LCALC = 0.0 C FORMULA FOR OPTIMAL STEP SIZE. IF (LCALC+RCALC+DCALC .EQ. 0.0) THEN HT = SSPAR(7) * HOLD ELSE HT = (1.0/MAX(LCALC/SSPAR(1), RCALC/SSPAR(2), DCALC/SSPAR(3))) $ **(1.0/SSPAR(8)) * HOLD ENDIF C HT CONTAINS THE ESTIMATED OPTIMAL STEP SIZE. NOW PUT IT WITHIN C REASONABLE BOUNDS. H=MIN(MAX(HT,SSPAR(6)*HOLD,SSPAR(4)), SSPAR(7)*HOLD, SSPAR(5)) IF (ITNUM .EQ. 1) THEN C IF CONVERGENCE HAD OCCURRED AFTER 1 ITERATION, DON'T DECREASE H . H=MAX(H,HOLD) ELSE IF (ITNUM .EQ. LITFH) THEN C IF CONVERGENCE REQUIRED THE MAXIMUM LITFH ITERATIONS, DON'T C INCREASE H . H=MIN(H,HOLD) ENDIF C IF CONVERGENCE DID NOT OCCUR IN LITFH ITERATIONS FOR A PARTICULAR C H = HFAIL , DON'T CHOOSE THE NEW STEP SIZE LARGER THAN HFAIL . IF (FAIL) H=MIN(H,HFAIL) C C RETURN END * SUBROUTINE STEPNS(N,NFE,IFLAG,START,CRASH,HOLD,H,RELERR, $ ABSERR,S,Y,YP,YOLD,YPOLD,A,QR,LENQR,PIVOT,WORK,SSPAR, $ PAR,IPAR) C C STEPNS TAKES ONE STEP ALONG THE ZERO CURVE OF THE HOMOTOPY MAP C USING A PREDICTOR-CORRECTOR ALGORITHM. THE PREDICTOR USES A HERMITE C CUBIC INTERPOLANT, AND THE CORRECTOR RETURNS TO THE ZERO CURVE ALONG C THE FLOW NORMAL TO THE DAVIDENKO FLOW. STEPNS ALSO ESTIMATES A C STEP SIZE H FOR THE NEXT STEP ALONG THE ZERO CURVE. NORMALLY C STEPNS IS USED INDIRECTLY THROUGH FIXPNS , AND SHOULD BE CALLED C DIRECTLY ONLY IF IT IS NECESSARY TO MODIFY THE STEPPING ALGORITHM'S C PARAMETERS. C C ON INPUT: C C N = DIMENSION OF X AND THE HOMOTOPY MAP. C C NFE = NUMBER OF JACOBIAN MATRIX EVALUATIONS. C C IFLAG = -2, -1, OR 0, INDICATING THE PROBLEM TYPE. C C START = .TRUE. ON FIRST CALL TO STEPNS , .FALSE. OTHERWISE. C C HOLD = ||Y - YOLD||; SHOULD NOT BE MODIFIED BY THE USER. C C H = UPPER LIMIT ON LENGTH OF STEP THAT WILL BE ATTEMPTED. H MUST BE C SET TO A POSITIVE NUMBER ON THE FIRST CALL TO STEPNS . C THEREAFTER STEPNS CALCULATES AN OPTIMAL VALUE FOR H , AND H C SHOULD NOT BE MODIFIED BY THE USER. C C RELERR, ABSERR = RELATIVE AND ABSOLUTE ERROR VALUES. THE ITERATION IS C CONSIDERED TO HAVE CONVERGED WHEN A POINT W=(X,LAMBDA) IS FOUND C SUCH THAT C C ||Z|| <= RELERR*||W|| + ABSERR , WHERE C C Z IS THE NEWTON STEP TO W=(X,LAMBDA). C C S = (APPROXIMATE) ARC LENGTH ALONG THE HOMOTOPY ZERO CURVE UP TO C Y(S) = (X(S), LAMBDA(S)). C C Y(1:N+1) = PREVIOUS POINT (X(S), LAMBDA(S)) FOUND ON THE ZERO CURVE OF C THE HOMOTOPY MAP. C C YP(1:N+1) = UNIT TANGENT VECTOR TO THE ZERO CURVE OF THE HOMOTOPY MAP C AT Y . C C YOLD(1:N+1) = A POINT BEFORE Y ON THE ZERO CURVE OF THE HOMOTOPY MAP C C YPOLD(1:N+1) = UNIT TANGENT VECTOR TO THE ZERO CURVE OF THE HOMOTOPY C MAP AT YOLD . C C A(1:*) = PARAMETER VECTOR IN THE HOMOTOPY MAP. C C QR(1:LENQR) = THE N X N SYMMETRIC JACOBIAN MATRIX WITH RESPECT TO X C STORED IN PACKED SKYLINE STORAGE FORMAT. LENQR AND PIVOT C DESCRIBE THE DATA STRUCTURE IN QR . C C LENQR = LENGTH OF THE ONE-DIMENSIONAL ARRAY QR USED TO CONTAIN THE C N X N SYMMETRIC JACOBIAN MATRIX WITH RESPECT TO X IN PACKED C SKYLINE STORAGE FORMAT. C C PIVOT(1:N+2) = INDICES OF THE DIAGONAL ELEMENTS OF THE N X N SYMMETRIC C JACOBIAN MATRIX (WITH RESPECT TO X) WITHIN QR . C C WORK(1:13*(N+1)+2*N+LENQR) = WORK ARRAY SPLIT UP AND USED FOR THE C CALCULATION OF THE JACOBIAN MATRIX KERNEL, THE NEWTON STEP, C INTERPOLATION, AND THE ESTIMATION OF THE NEXT STEP SIZE H . C C SSPAR(1:8) = (LIDEAL, RIDEAL, DIDEAL, HMIN, HMAX, BMIN, BMAX, P) IS C A VECTOR OF PARAMETERS USED FOR THE OPTIMAL STEP SIZE ESTIMATION. C C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS, C WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES C RHO, RHOJS. C C ON OUTPUT: C C N , A , SSPAR ARE UNCHANGED. C C NFE HAS BEEN UPDATED. C C IFLAG C = -2, -1, OR 0 (UNCHANGED) ON A NORMAL RETURN. C C = 4 IF THE CONJUGATE GRADIENT ITERATION FAILED TO CONVERGE C (MOST LIKELY DUE TO A JACOBIAN MATRIX WITH RANK < N). THE C ITERATION WAS NOT COMPLETED. C C = 6 IF THE NEWTON ITERATION FAILED TO CONVERGE. W CONTAINS C THE LAST NEWTON ITERATE. C C START = .FALSE. ON A NORMAL RETURN. C C CRASH C = .FALSE. ON A NORMAL RETURN. C C = .TRUE. IF THE STEP SIZE H WAS TOO SMALL. H HAS BEEN C INCREASED TO AN ACCEPTABLE VALUE, WITH WHICH STEPNS MAY BE C CALLED AGAIN. C C = .TRUE. IF RELERR AND/OR ABSERR WERE TOO SMALL. THEY HAVE C BEEN INCREASED TO ACCEPTABLE VALUES, WITH WHICH STEPNS MAY C BE CALLED AGAIN. C C HOLD = ||Y - YOLD||. C C H = OPTIMAL VALUE FOR NEXT STEP TO BE ATTEMPTED. NORMALLY H SHOULD C NOT BE MODIFIED BY THE USER. C C RELERR, ABSERR ARE UNCHANGED ON A NORMAL RETURN. C C S = (APPROXIMATE) ARC LENGTH ALONG THE ZERO CURVE OF THE HOMOTOPY MAP C UP TO THE LATEST POINT FOUND, WHICH IS RETURNED IN Y . C C Y, YP, YOLD, YPOLD CONTAIN THE TWO MOST RECENT POINTS AND TANGENT C VECTORS FOUND ON THE ZERO CURVE OF THE HOMOTOPY MAP. C C C CALLS D1MACH , DAXPY , DCOPY , DNRM2 , TANGNS . C DOUBLE PRECISION ABSERR,D1MACH,DCALC,DD001,DD0011,DD01, $ DD011,DELS,DNRM2,F0,F1,FOURU,FP0,FP1,H,HFAIL,HOLD,HT, $ LCALC,QOFS,RCALC,RELERR,RHOLEN,S,TEMP,TWOU INTEGER IFLAG,IPP,IRHO,ITANGW,ITNUM,ITZ,IW,IWP,IZ0,IZ1, $ J,JUDY,LENQR,LITFH,N,NFE,NP1 LOGICAL CRASH,FAIL,START C C ***** ARRAY DECLARATIONS. ***** C DOUBLE PRECISION Y(N+1),YP(N+1),YOLD(N+1),YPOLD(N+1),A(N), $ QR(LENQR),WORK(13*(N+1)+2*N+LENQR),SSPAR(8),PAR(1) INTEGER PIVOT(N+2),IPAR(1) C C ***** END OF DIMENSIONAL INFORMATION. ***** C C THE LIMIT ON THE NUMBER OF NEWTON ITERATIONS ALLOWED BEFORE REDUCING C THE STEP SIZE H MAY BE CHANGED BY CHANGING THE FOLLOWING PARAMETER C STATEMENT: PARAMETER (LITFH=4) C C DEFINITION OF HERMITE CUBIC INTERPOLANT VIA DIVIDED DIFFERENCES. C DD01(F0,F1,DELS)=(F1-F0)/DELS DD001(F0,FP0,F1,DELS)=(DD01(F0,F1,DELS)-FP0)/DELS DD011(F0,F1,FP1,DELS)=(FP1-DD01(F0,F1,DELS))/DELS DD0011(F0,FP0,F1,FP1,DELS)=(DD011(F0,F1,FP1,DELS) - $ DD001(F0,FP0,F1,DELS))/DELS QOFS(F0,FP0,F1,FP1,DELS,S)=((DD0011(F0,FP0,F1,FP1,DELS)*(S-DELS) + $ DD001(F0,FP0,F1,DELS))*S + FP0)*S + F0 C C TWOU=2.0*D1MACH(4) FOURU=TWOU+TWOU NP1=N+1 IPP=1 IRHO=N+1 IW=IRHO+N IWP=IW+NP1 ITZ=IWP+NP1 IZ0=ITZ+NP1 IZ1=IZ0+NP1 ITANGW=IZ1+NP1 CRASH=.TRUE. C THE ARCLENGTH S MUST BE NONNEGATIVE. IF (S .LT. 0.0) RETURN C IF STEP SIZE IS TOO SMALL, DETERMINE AN ACCEPTABLE ONE. IF (H .LT. FOURU*(1.0+S)) THEN H=FOURU*(1.0+S) RETURN ENDIF C IF ERROR TOLERANCES ARE TOO SMALL, INCREASE THEM TO ACCEPTABLE VALUES. TEMP=DNRM2(NP1,Y,1) IF (.5*(RELERR*TEMP+ABSERR) .GE. TWOU*TEMP) GO TO 40 IF (RELERR .NE. 0.0) THEN RELERR=FOURU*(1.0+FOURU) ABSERR=MAX(ABSERR,0.0D0) ELSE ABSERR=FOURU*TEMP ENDIF RETURN 40 CRASH=.FALSE. IF (.NOT. START) GO TO 300 C C ***** STARTUP SECTION(FIRST STEP ALONG ZERO CURVE. ***** C FAIL=.FALSE. START=.FALSE. C DETERMINE SUITABLE INITIAL STEP SIZE. H=MIN(H, .10D0, SQRT(SQRT(RELERR*TEMP+ABSERR))) C USE LINEAR PREDICTOR ALONG TANGENT DIRECTION TO START NEWTON ITERATION YPOLD(NP1)=1.0 DO 50 J=1,N YPOLD(J)=0.0 50 CONTINUE CALL TANGNS(S,Y,YP,WORK(ITZ),YPOLD,A,QR,LENQR,PIVOT, $ WORK(IPP),WORK(IRHO),WORK(ITANGW),NFE,N,IFLAG,PAR,IPAR) IF (IFLAG .GT. 0) RETURN 70 DO 80 J=1,NP1 TEMP=Y(J) + H * YP(J) WORK(IW+J-1)=TEMP WORK(IZ0+J-1)=TEMP 80 CONTINUE DO 200 JUDY=1,LITFH RHOLEN=-1.0 C CALCULATE THE NEWTON STEP TZ AT THE CURRENT POINT W . CALL TANGNS(RHOLEN,WORK(IW),WORK(IWP),WORK(ITZ),YPOLD,A, $ QR,LENQR,PIVOT,WORK(IPP),WORK(IRHO),WORK(ITANGW), $ NFE,N,IFLAG,PAR,IPAR) IF (IFLAG .GT. 0) RETURN C C TAKE NEWTON STEP AND CHECK CONVERGENCE. CALL DAXPY(NP1,1.0D0,WORK(ITZ),1,WORK(IW),1) ITNUM=JUDY C COMPUTE QUANTITIES USED FOR OPTIMAL STEP SIZE ESTIMATION. IF (JUDY .EQ. 1) THEN LCALC=DNRM2(NP1,WORK(ITZ),1) RCALC=RHOLEN CALL DCOPY(NP1,WORK(IW),1,WORK(IZ1),1) ELSE IF (JUDY .EQ. 2) THEN LCALC=DNRM2(NP1,WORK(ITZ),1)/LCALC RCALC=RHOLEN/RCALC ENDIF C GO TO MOP-UP SECTION AFTER CONVERGENCE. IF ( DNRM2(NP1,WORK(ITZ),1) .LE. $ RELERR*DNRM2(NP1,WORK(IW),1)+ABSERR ) GO TO 600 C 200 CONTINUE C C NO CONVERGENCE IN LITFH ITERATIONS. REDUCE H AND TRY AGAIN. IF (H .LE. FOURU*(1.0 + S)) THEN IFLAG=6 RETURN ENDIF H=.5 * H GO TO 70 C C ***** END OF STARTUP SECTION. ***** C C ***** PREDICTOR SECTION. ***** C 300 FAIL=.FALSE. C COMPUTE POINT PREDICTED BY HERMITE INTERPOLANT. USE STEP SIZE H C COMPUTED ON LAST CALL TO STEPNS . 320 DO 330 J=1,NP1 TEMP=QOFS(YOLD(J),YPOLD(J),Y(J),YP(J),HOLD,HOLD+H) WORK(IW+J-1)=TEMP WORK(IZ0+J-1)=TEMP 330 CONTINUE C C ***** END OF PREDICTOR SECTION. ***** C C ***** CORRECTOR SECTION. ***** C DO 500 JUDY=1,LITFH RHOLEN=-1.0 C CALCULATE THE NEWTON STEP TZ AT THE CURRENT POINT W . CALL TANGNS(RHOLEN,WORK(IW),WORK(IWP),WORK(ITZ),YP,A, $ QR,LENQR,PIVOT,WORK(IPP),WORK(IRHO),WORK(ITANGW), $ NFE,N,IFLAG,PAR,IPAR) IF (IFLAG .GT. 0) RETURN C C TAKE NEWTON STEP AND CHECK CONVERGENCE. CALL DAXPY(NP1,1.0D0,WORK(ITZ),1,WORK(IW),1) ITNUM=JUDY C COMPUTE QUANTITIES USED FOR OPTIMAL STEP SIZE ESTIMATION. IF (JUDY .EQ. 1) THEN LCALC=DNRM2(NP1,WORK(ITZ),1) RCALC=RHOLEN CALL DCOPY(NP1,WORK(IW),1,WORK(IZ1),1) ELSE IF (JUDY .EQ. 2) THEN LCALC=DNRM2(NP1,WORK(ITZ),1)/LCALC RCALC=RHOLEN/RCALC ENDIF C GO TO MOP-UP SECTION AFTER CONVERGENCE. IF ( DNRM2(NP1,WORK(ITZ),1) .LE. $ RELERR*DNRM2(NP1,WORK(IW),1)+ABSERR ) GO TO 600 C 500 CONTINUE C C NO CONVERGENCE IN LITFH ITERATIONS. RECORD FAILURE AT CALCULATED H C SAVE THIS STEP SIZE, REDUCE H AND TRY AGAIN. FAIL=.TRUE. HFAIL=H IF (H .LE. FOURU*(1.0 + S)) THEN IFLAG=6 RETURN ENDIF H=.5 * H GO TO 320 C C ***** END OF CORRECTOR SECTION. ***** C C ***** MOP-UP SECTION. ***** C C YOLD AND Y ALWAYS CONTAIN THE LAST TWO POINTS FOUND ON THE ZERO C CURVE OF THE HOMOTOPY MAP. YPOLD AND YP CONTAIN THE TANGENT C VECTORS TO THE ZERO CURVE AT YOLD AND Y , RESPECTIVELY. C 600 CALL DCOPY(NP1,Y,1,YOLD,1) CALL DCOPY(NP1,YP,1,YPOLD,1) CALL DCOPY(NP1,WORK(IW),1,Y,1) CALL DCOPY(NP1,WORK(IWP),1,YP,1) CALL DAXPY(NP1,-1.0D0,YOLD,1,WORK(IW),1) C UPDATE ARC LENGTH. HOLD=DNRM2(NP1,WORK(IW),1) S=S+HOLD C C ***** END OF MOP-UP SECTION. ***** C C ***** OPTIMAL STEP SIZE ESTIMATION SECTION. ***** C C CALCULATE THE DISTANCE FACTOR DCALC . 700 CALL DAXPY(NP1,-1.0D0,Y,1,WORK(IZ0),1) CALL DAXPY(NP1,-1.0D0,Y,1,WORK(IZ1),1) DCALC=DNRM2(NP1,WORK(IZ0),1) IF (DCALC .NE. 0.0) DCALC=DNRM2(NP1,WORK(IZ1),1)/DCALC C C THE OPTIMAL STEP SIZE HBAR IS DEFINED BY C C HT=HOLD * [MIN(LIDEAL/LCALC, RIDEAL/RCALC, DIDEAL/DCALC)]**(1/P) C C HBAR = MIN [ MAX(HT, BMIN*HOLD, HMIN), BMAX*HOLD, HMAX ] C C IF CONVERGENCE HAD OCCURRED AFTER 1 ITERATION, SET THE CONTRACTION C FACTOR LCALC TO ZERO. IF (ITNUM .EQ. 1) LCALC = 0.0 C FORMULA FOR OPTIMAL STEP SIZE. IF (LCALC+RCALC+DCALC .EQ. 0.0) THEN HT = SSPAR(7) * HOLD ELSE HT = (1.0/MAX(LCALC/SSPAR(1), RCALC/SSPAR(2), DCALC/SSPAR(3))) $ **(1.0/SSPAR(8)) * HOLD ENDIF C HT CONTAINS THE ESTIMATED OPTIMAL STEP SIZE. NOW PUT IT WITHIN C REASONABLE BOUNDS. H=MIN(MAX(HT,SSPAR(6)*HOLD,SSPAR(4)), SSPAR(7)*HOLD, SSPAR(5)) IF (ITNUM .EQ. 1) THEN C IF CONVERGENCE HAD OCCURRED AFTER 1 ITERATION, DON'T DECREASE H . H=MAX(H,HOLD) ELSE IF (ITNUM .EQ. LITFH) THEN C IF CONVERGENCE REQUIRED THE MAXIMUM LITFH ITERATIONS, DON'T C INCREASE H . H=MIN(H,HOLD) ENDIF C IF CONVERGENCE DID NOT OCCUR IN LITFH ITERATIONS FOR A PARTICULAR C H = HFAIL , DON'T CHOOSE THE NEW STEP SIZE LARGER THAN HFAIL . IF (FAIL) H=MIN(H,HFAIL) C C RETURN END * SUBROUTINE STEPQF(N,NFE,IFLAG,START,CRASH,HOLD,H, $ WK,RELERR,ABSERR,S,Y,YP,YOLD,YPOLD,A,QT,R, $ F0,F1,Z0,DZ,W,T,SSPAR,PAR,IPAR) C C SUBROUTINE STEPQF TAKES ONE STEP ALONG THE ZERO CURVE OF THE C HOMOTOPY MAP RHO(LAMBDA,X) USING A PREDICTOR-CORRECTOR ALGORITHM. C THE PREDICTOR USES A HERMITE CUBIC INTERPOLANT, AND THE CORRECTOR C RETURNS TO THE ZERO CURVE USING A QUASI-NEWTON ALGORITHM, REMAINING C IN A HYPERPLANE PERPENDICULAR TO THE MOST RECENT TANGENT VECTOR. C STEPQF ALSO ESTIMATES A STEP SIZE H FOR THE NEXT STEP ALONG THE C ZERO CURVE. C C C ON INPUT: C C N = DIMENSION OF X. C C NFE = NUMBER OF JACOBIAN MATRIX EVALUATIONS. C C IFLAG = -2, -1, OR 0, INDICATING THE PROBLEM TYPE. C C START = .TRUE. ON FIRST CALL TO STEPQF, .FALSE. OTHERWISE. C SHOULD NOT BE MODIFIED BY THE USER AFTER THE FIRST CALL. C C HOLD = ||Y - YOLD|| ; SHOULD NOT BE MODIFIED BY THE USER. C C H = UPPER LIMIT ON LENGTH OF STEP THAT WILL BE ATTEMPTED. H MUST C BE SET TO A POSITIVE NUMBER ON THE FIRST CALL TO STEPQF. C THEREAFTER, STEPQF CALCULATES AN OPTIMAL VALUE FOR H, AND H C SHOULD NOT BE MODIFIED BY THE USER. C C WK = APPROXIMATE CURVATURE FOR THE LAST STEP (COMPUTED BY PREVIOUS C CALL TO STEPQF). UNDEFINED ON FIRST CALL. SHOULD NOT BE C MODIFIED BY THE USER. C C RELERR, ABSERR = RELATIVE AND ABSOLUTE ERROR VALUES. THE ITERATION C IS CONSIDERED TO HAVE CONVERGED WHEN A POINT Z=(LAMBDA,X) IS C FOUND SUCH THAT C ||DZ|| .LE. RELERR*||Z|| + ABSERR, C WHERE DZ IS THE LAST QUASI-NEWTON STEP. C C S = (APPROXIMATE) ARC LENGTH ALONG THE HOMOTOPY ZERO CURVE UP TO C Y(S) = (LAMBDA(S), X(S)). C C Y(1:N+1) = PREVIOUS POINT (LAMBDA(S),X(S)) FOUND ON THE ZERO CURVE C OF THE HOMOTOPY MAP. C C YP(1:N+1) = UNIT TANGENT VECTOR TO THE ZERO CURVE OF THE HOMOTOPY C MAP AT Y. INPUT IN THIS VECTOR IS NOT USED ON THE FIRST CALL C TO STEPQF. C C YOLD(1:N+1) = A POINT BEFORE Y ON THE ZERO CURVE OF THE HOMOTOPY C MAP. INPUT IN THIS VECTOR IS NOT USED ON THE FIRST CALL TO C STEPQF. C C YPOLD(1:N+1) = UNIT TANGENT VECTOR TO THE ZERO CURVE OF THE C HOMOTOPY MAP AT YOLD. C C A(1:N) = PARAMETER VECTOR IN THE HOMOTOPY MAP. C C QT(1:N+1,1:N+1) = HOLDS Q TRANSPOSE OF THE QR FACTORIZATION OF C THE AUGMENTED JACOBIAN MATRIX AT Y. C C R((N+1)*(N+2)/2) = HOLDS THE UPPER TRIANGLE OF R OF THE QR C FACTORIZATION, STORED BY ROWS. C C F0(1:N+1), F1(1:N+1), Z0(1:N+1), DZ(1:N+1), W(1:N+1), T(1:N+1) ARE C WORK ARRAYS. C C SSPAR(1:4) = PARAMETERS USED FOR COMPUTATION OF THE OPTIMAL STEP SIZE. C SSPAR(1) = HMIN, SSPAR(2) = HMAX, SSPAR(3) = BMIN, SSPAR(4) = BMAX. C THE OPTIMAL STEP H IS RESTRICTED SUCH THAT C HMIN .LE. H .LE. HMAX, AND BMIN*HOLD .LE. H .LE. BMAX*HOLD. C C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS, C WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES C RHO, RHOJAC. C C C ON OUTPUT: C C NFE HAS BEEN UPDATED. C C IFLAG C C = -2, -1, OR 0 (UNCHANGED) ON A NORMAL RETURN. C C = 4 IF A JACOBIAN MATRIX WITH RANK < N HAS OCCURRED. THE C ITERATION WAS NOT COMPLETED. C C = 6 IF THE ITERATION FAILED TO CONVERGE. C C START = .FALSE. ON A NORMAL RETURN. C C CRASH C C = .FALSE. ON A NORMAL RETURN. C C = .TRUE. IF THE STEP SIZE H WAS TOO SMALL. H HAS BEEN C INCREASED TO AN ACCEPTABLE VALUE, WITH WHICH STEPQF MAY BE C CALLED AGAIN. C C = .TRUE. IF RELERR AND/OR ABSERR WERE TOO SMALL. THEY HAVE C BEEN INCREASED TO ACCEPTABLE VALUES, WITH WHICH STEPQF MAY C BE CALLED AGAIN. C C HOLD = ||Y-YOLD||. C C H = OPTIMAL VALUE FOR NEXT STEP TO BE ATTEMPTED. NORMALLY H SHOULD C NOT BE MODIFIED BY THE USER. C C WK = APPROXIMATE CURVATURE FOR THE STEP TAKEN BY STEPQF. C C S = (APPROXIMATE) ARC LENGTH ALONG THE ZERO CURVE OF THE HOMOTOPY C MAP UP TO THE LATEST POINT FOUND, WHICH IS RETURNED IN Y. C C RELERR, ABSERR ARE UNCHANGED ON A NORMAL RETURN. THEY ARE POSSIBLY C CHANGED IF CRASH = .TRUE. (SEE DESCRIPTION OF CRASH ABOVE). C C Y, YP, YOLD, YPOLD CONTAIN THE TWO MOST RECENT POINTS AND TANGENT C VECTORS FOUND ON THE ZERO CURVE OF THE HOMOTOPY MAP. C C QT, R STORE THE QR FACTORIZATION OF THE AUGMENTED JACOBIAN MATRIX C EVALUATED AT Y. C C C CALLS D1MACH, DAXPY, DCOPY, DDOT, DNRM2, DSCAL, F (OR RHO), FJAC C (OR RHOJAC), QRFAQF, QRSLQF, TANGQF, UPQRQF. C C ***** DECLARATIONS ***** C C FUNCTION DECLARATIONS C DOUBLE PRECISION D1MACH, DDOT, DNRM2, QOFS C C LOCAL VARIABLES C DOUBLE PRECISION ALPHA, DD001, DD0011, DD01, DD011, DELS, ETA, $ FOURU, GAMMA, HFAIL, HTEMP, IDLERR, ONE, P0, P1, PP0, PP1, $ TEMP, TWOU, WKOLD INTEGER I, ITCNT, LITFH, J, JP1, NP1 LOGICAL FAILED C C SCALAR ARGUMENTS C INTEGER N, NFE, IFLAG LOGICAL START, CRASH DOUBLE PRECISION HOLD, H, WK, RELERR, ABSERR, S C C ARRAY DECLARATIONS C DOUBLE PRECISION Y(N+1), YP(N+1), YOLD(N+1), YPOLD(N+1), $ A(N), QT(N+1,N+1), R((N+1)*(N+2)/2), F0(N+1), F1(N+1), $ Z0(N+1), DZ(N+1), W(N+1), T(N+1), SSPAR(4), PAR(1) INTEGER IPAR(1) C SAVE C C ***** END OF DECLARATIONS ***** C C DEFINITION OF HERMITE CUBIC INTERPOLANT VIA DIVIDED DIFFERENCES. C DD01(P0,P1,DELS) = (P1-P0)/DELS DD001(P0,PP0,P1,DELS) = (DD01(P0,P1,DELS)-PP0)/DELS DD011(P0,P1,PP1,DELS) = (PP1-DD01(P0,P1,DELS))/DELS DD0011(P0,PP0,P1,PP1,DELS) = (DD011(P0,P1,PP1,DELS) - $ DD001(P0,PP0,P1,DELS))/DELS QOFS(P0,PP0,P1,PP1,DELS,S) = ((DD0011(P0,PP0,P1,PP1,DELS)* $ (S-DELS) + DD001(P0,PP0,P1,DELS))*S + PP0)*S + P0 C C ***** FIRST EXECUTABLE STATEMENT ***** C C C ***** INITIALIZATION ***** C C ETA = PARAMETER FOR BROYDEN'S UPDATE. C LITFH = MAXIMUM NUMBER OF QUASI-NEWTON ITERATIONS ALLOWED. C ONE = 1.0 TWOU = 2.0*D1MACH(4) FOURU = TWOU + TWOU NP1 = N+1 FAILED = .FALSE. CRASH = .TRUE. ETA = 50.0*TWOU LITFH = 2*(INT(-LOG10(ABSERR+RELERR*DNRM2(NP1,Y,1)))+1) C C CHECK THAT ALL INPUT PARAMETERS ARE CORRECT. C C THE ARCLENGTH S MUST BE NONNEGATIVE. C IF (S .LT. 0.0) RETURN C C IF STEP SIZE IS TOO SMALL, DETERMINE AN ACCEPTABLE ONE. C IF (H .LT. FOURU*(1.0+S)) THEN H=FOURU*(1.0 + S) RETURN END IF C C IF ERROR TOLERANCES ARE TOO SMALL, INCREASE THEM TO ACCEPTABLE C VALUES. C TEMP=DNRM2(NP1,Y,1) + 1.0 IF (.5*(RELERR*TEMP+ABSERR) .LT. TWOU*TEMP) THEN IF (RELERR .NE. 0.0) THEN RELERR = FOURU*(1.0+FOURU) TEMP = 0.0 ABSERR = MAX(ABSERR,TEMP) ELSE ABSERR=FOURU*TEMP END IF RETURN END IF C C INPUT PARAMETERS WERE ALL ACCEPTABLE. C CRASH = .FALSE. C C COMPUTE YP ON FIRST CALL. C NOTE: DZ IS USED SIMPLY AS A WORK ARRAY HERE. C IF (START) THEN CALL TANGQF(Y,YP,YPOLD,A,QT,R,W,DZ,T,N,IFLAG,NFE,PAR,IPAR) IF (IFLAG .GT. 0) RETURN END IF C C F0 = (RHO(Y), YP*Y) TRANSPOSE (DIFFERENT FOR EACH PROBLEM TYPE). C IF (IFLAG .EQ. -2) THEN C C CURVE TRACKING PROBLEM. C CALL RHO(A,Y(1),Y(2),F0,PAR,IPAR) ELSE IF (IFLAG .EQ. -1) THEN C C ZERO FINDING PROBLEM. C CALL F(Y(2),F0) DO 5 I=1,N F0(I) = Y(1)*F0(I) + (1.0-Y(1))*(Y(I+1)-A(I)) 5 CONTINUE ELSE C C FIXED POINT PROBLEM. C CALL F(Y(2),F0) DO 10 I=1,N F0(I) = Y(1)*(A(I)-F0(I))+Y(I+1)-A(I) 10 CONTINUE END IF C C DEFINE LAST ROW OF F0 = YP*Y. C F0(NP1) = DDOT(NP1,YP,1,Y,1) C C ***** END OF INITIALIZATION ***** C C ***** COMPUTE PREDICTOR POINT Z0 ***** C 20 IF (START) THEN C C COMPUTE Z0 WITH LINEAR PREDICTOR USING Y, YP -- C Z0 = Y+H*YP. C CALL DCOPY(NP1,Y,1,Z0,1) CALL DAXPY(NP1,H,YP,1,Z0,1) C ELSE C C COMPUTE Z0 WITH CUBIC PREDICTOR. C DO 30 I=1,NP1 Z0(I) = QOFS(YOLD(I),YPOLD(I),Y(I),YP(I),HOLD,HOLD+H) 30 CONTINUE C END IF C C F1 = (RHO(Z0), YP*Z0) TRANSPOSE. C IF (IFLAG .EQ. -2) THEN CALL RHO(A,Z0(1),Z0(2),F1,PAR,IPAR) ELSE IF (IFLAG .EQ. -1) THEN CALL F(Z0(2),F1) DO 40 I=1,N F1(I) = Z0(1)*F1(I) + (1.0-Z0(1))*(Z0(I+1)-A(I)) 40 CONTINUE ELSE CALL F(Z0(2),F1) DO 50 I=1,N F1(I) = Z0(1)*(A(I)-F1(I))+Z0(I+1)-A(I) 50 CONTINUE END IF F1(NP1) = DDOT(NP1,YP,1,Z0,1) C C ***** END OF PREDICTOR SECTION ***** C C ***** SET-UP FOR QUASI-NEWTON ITERATION ***** C IF (FAILED) THEN C C GENERATE QT = AUGMENTED JACOBIAN MATRIX FOR POINT Z0=(LAMBDA,X). C IF (IFLAG .EQ. -2) THEN C C CURVE TRACKING PROBLEM: C D(RHO) = (D RHO(A,LAMBDA,X)/D LAMBDA, D RHO(A,LAMBDA,X)/DX). C DO 60 J = 1,NP1 CALL RHOJAC(A,Z0(1),Z0(2),QT(1,J),J,PAR,IPAR) 60 CONTINUE ELSE IF (IFLAG .EQ. -1) THEN C C ZERO FINDING PROBLEM: C D(RHO) = (F(X) - X + A, LAMBDA*DF(X) + (1-LAMBDA)*I). C CALL F(Z0(2),QT(1,1)) DO 70 I=1,N QT(I,1) = A(I) - Z0(I+1) + QT(I,1) 70 CONTINUE DO 80 J= 1,N JP1 = J+1 CALL FJAC(Z0(2),QT(1,JP1),J) CALL DSCAL(N, Z0(1), QT(1,JP1), 1) QT(J,JP1) = 1.0 - Z0(1) + QT(J,JP1) 80 CONTINUE ELSE C C FIXED POINT PROBLEM: C D(RHO) = (A - F(X), I - LAMBDA*DF(X)). C CALL F(Z0(2),QT(1,1)) CALL DSCAL(N,-ONE,QT(1,1),1) CALL DAXPY(N,ONE,A,1,QT(1,1),1) DO 90 J=1,N JP1 = J+1 CALL FJAC(Z0(2),QT(1,JP1),J) CALL DSCAL(N, -Z0(1), QT(1,JP1), 1) QT(J,JP1) = 1.0 + QT(J,JP1) 90 CONTINUE END IF C C DEFINE LAST ROW OF QT = YP. C CALL DCOPY(NP1, YP, 1, QT(NP1,1), NP1) C C COUNT JACOBIAN EVALUATION. C NFE = NFE+1 C C DO FIRST QUASI NEWTON STEP. C C FACTOR AUG. C CALL QRFAQF(QT,R,NP1,IFLAG) IF (IFLAG .GT. 0) RETURN C C COMPUTE NEWTON STEP. C CALL DCOPY(N,F1,1,DZ,1) CALL DSCAL(N,-ONE,DZ,1) DZ(NP1) = 0.0 CALL QRSLQF(QT,R,DZ,W,NP1) C C TAKE STEP AND SET F0 = F1. C CALL DAXPY(NP1, ONE, DZ, 1, Z0, 1) CALL DCOPY(NP1, F1, 1, F0, 1) C C F1 = (RHO(Z0), YP*Z0) TRANSPOSE. C IF (IFLAG .EQ. -2) THEN CALL RHO(A,Z0(1),Z0(2),F1,PAR,IPAR) ELSE IF (IFLAG .EQ. -1) THEN CALL F(Z0(2),F1) DO 100 I=1,N F1(I) = Z0(1)*F1(I) + (1.0-Z0(1))*(Z0(I+1)-A(I)) 100 CONTINUE ELSE CALL F(Z0(2),F1) DO 110 I=1,N F1(I) = Z0(1)*(A(I)-F1(I))+Z0(I+1)-A(I) 110 CONTINUE END IF F1(NP1) = DDOT(NP1,YP,1,Z0,1) C ELSE C C IF NOT FAILED THEN DEFINE DZ=Z0-Y PRIOR TO MAIN LOOP. C CALL DCOPY(NP1,Z0,1,DZ,1) CALL DAXPY(NP1,-ONE,Y,1,DZ,1) END IF C C ***** END OF PREPARATION FOR QUASI-NEWTON ITERATION ***** C C ***** QUASI-NEWTON ITERATION ***** C DO 140 ITCNT = 1,LITFH C C PERFORM UPDATE FOR NEWTON STEP JUST TAKEN. C CALL UPQRQF(NP1,ETA,DZ,F0,F1,QT,R,W,T) C C COMPUTE NEXT NEWTON STEP. C CALL DCOPY(N,F1,1,DZ,1) CALL DSCAL(N,-ONE,DZ,1) DZ(NP1) = 0.0 CALL QRSLQF(QT,R,DZ,W,NP1) C C TAKE STEP. C CALL DAXPY(NP1, ONE, DZ, 1, Z0, 1) C C CHECK FOR CONVERGENCE. C IF (DNRM2(NP1,DZ,1) .LE. RELERR*DNRM2(NP1,Z0,1)+ABSERR) THEN GO TO 160 END IF C C IF NOT CONVERGED, PREPARE FOR NEXT ITERATION. C C F0 = F1. C CALL DCOPY(NP1, F1, 1, F0, 1) C C F1 = (RHO(Z0), YP*Z0) TRANSPOSE. C IF (IFLAG .EQ. -2) THEN CALL RHO(A,Z0(1),Z0(2),F1,PAR,IPAR) ELSE IF (IFLAG .EQ. -1) THEN CALL F(Z0(2),F1) DO 120 I=1,N F1(I) = Z0(1)*F1(I) + (1.0-Z0(1))*(Z0(I+1)-A(I)) 120 CONTINUE ELSE CALL F(Z0(2),F1) DO 130 I=1,N F1(I) = Z0(1)*(A(I)-F1(I))+Z0(I+1)-A(I) 130 CONTINUE END IF F1(NP1) = DDOT(NP1,YP,1,Z0,1) C 140 CONTINUE C C ***** END OF QUASI-NEWTON LOOP ***** C C ***** DIDN'T CONVERGE OR TANGENT AT NEW POINT DID NOT MAKE C AN ACUTE ANGLE WITH YPOLD -- TRY AGAIN WITH A SMALLER H ***** C 150 FAILED = .TRUE. HFAIL = H IF (H .LE. FOURU*(1.0 + S)) THEN IFLAG = 6 RETURN ELSE H = .5 * H END IF GO TO 20 C C ***** END OF CONVERGENCE FAILURE SECTION ***** C C ***** CONVERGED -- MOP UP AND RETURN ***** C C COMPUTE TANGENT & AUGMENTED JACOBIAN AT Z0. C NOTE: DZ AND F1 ARE USED SIMPLY AS WORK ARRAYS HERE. C 160 CALL TANGQF(Z0,T,YP,A,QT,R,W,DZ,F1,N,IFLAG,NFE,PAR,IPAR) IF (IFLAG .GT. 0) RETURN C C CHECK THAT COMPUTED TANGENT T MAKES AN ANGLE NO LARGER THAN C 60 DEGREES WITH CURRENT TANGENT YP. (I.E. COS OF ANGLE < .5) C IF NOT, STEP SIZE WAS TOO LARGE, SO THROW AWAY Z0, AND TRY C AGAIN WITH A SMALLER STEP. C ALPHA = DDOT(NP1,T,1,YP,1) IF (ALPHA .LT. 0.5) GOTO 150 ALPHA = ACOS(ALPHA) C C SET UP VARIABLES FOR NEXT CALL. C CALL DCOPY(NP1,Y,1,YOLD,1) CALL DCOPY(NP1,Z0,1,Y,1) CALL DCOPY(NP1,YP,1,YPOLD,1) CALL DCOPY(NP1,T,1,YP,1) C C UPDATE ARCLENGTH S = S + ||Y-YOLD||. C HTEMP = HOLD CALL DAXPY(NP1,-ONE,YOLD,1,Z0,1) HOLD = DNRM2(NP1,Z0,1) S = S+HOLD C C COMPUTE OPTIMAL STEP SIZE. C IDLERR = DESIRED ERROR FOR NEXT PREDICTOR STEP. C WK = APPROXIMATE CURVATURE = 2*SIN(ALPHA/2)/HOLD WHERE C ALPHA = ARCCOS(YP*YPOLD). C GAMMA = EXPECTED CURVATURE FOR NEXT STEP, COMPUTED BY C EXTRAPOLATING FROM CURRENT CURVATURE WK, AND LAST C CURVATURE WKOLD. GAMMA IS FURTHER REQUIRED TO BE C POSITIVE. C WKOLD = WK IDLERR = SQRT(SQRT(ABSERR + RELERR*DNRM2(NP1,Y,1))) C C IDLERR SHOULD BE NO BIGGER THAN 1/2 PREVIOUS STEP. C IDLERR = MIN(.5*HOLD,IDLERR) WK = 2.0*ABS(SIN(.5*ALPHA))/HOLD IF (START) THEN GAMMA = WK ELSE GAMMA = WK + HOLD/(HOLD+HTEMP)*(WK-WKOLD) END IF GAMMA = MAX(GAMMA, 0.01*ONE) H = SQRT(2.0*IDLERR/GAMMA) C C ENFORCE RESTRICTIONS ON STEP SIZE SO AS TO ENSURE STABILITY. C HMIN <= H <= HMAX, BMIN*HOLD <= H <= BMAX*HOLD. C H = MIN(MAX(SSPAR(1),SSPAR(3)*HOLD,H),SSPAR(4)*HOLD,SSPAR(2)) IF (FAILED) H = MIN(HFAIL,H) START = .FALSE. C C ***** END OF MOP UP SECTION ***** C RETURN C C ***** END OF SUBROUTINE STEPQF ***** END SUBROUTINE STEPQS(N,NFE,IFLAG,LENQR,START,CRASH,HOLD,H, $ WK,RELERR,ABSERR,S,Y,YP,YOLD,YPOLD,A,QR,PIVOT,PP, $ RHOVEC,Z0,DZ,T,WORK,SSPAR,PAR,IPAR) C C SUBROUTINE STEPQS TAKES ONE STEP ALONG THE ZERO CURVE OF THE C HOMOTOPY MAP RHO(X,LAMBDA) USING A PREDICTOR-CORRECTOR ALGORITHM. C THE PREDICTOR USES A HERMITE CUBIC INTERPOLANT, AND THE CORRECTOR C RETURNS TO THE ZERO CURVE USING A NEWTON ITERATION, REMAINING C IN A HYPERPLANE PERPENDICULAR TO THE MOST RECENT TANGENT VECTOR. C STEPQS ALSO ESTIMATES A STEP SIZE H FOR THE NEXT STEP ALONG THE C ZERO CURVE. C C C ON INPUT: C C N = DIMENSION OF X. C C NFE = NUMBER OF JACOBIAN MATRIX EVALUATIONS. C C IFLAG = -2, -1, OR 0, INDICATING THE PROBLEM TYPE. C C LENQR = THE LENGTH OF THE ONE DIMENSIONAL ARRAY QR. C C START = .TRUE. ON FIRST CALL TO STEPQS, .FALSE. OTHERWISE. C SHOULD NOT BE MODIFIED BY THE USER AFTER THE FIRST CALL. C C HOLD = ||Y - YOLD|| ; SHOULD NOT BE MODIFIED BY THE USER. C C H = UPPER LIMIT ON LENGTH OF STEP THAT WILL BE ATTEMPTED. H MUST C BE SET TO A POSITIVE NUMBER ON THE FIRST CALL TO STEPQS. C THEREAFTER, STEPQS CALCULATES AN OPTIMAL VALUE FOR H, AND H C SHOULD NOT BE MODIFIED BY THE USER. C C WK = APPROXIMATE CURVATURE FOR THE LAST STEP (COMPUTED BY PREVIOUS C CALL TO STEPQS). UNDEFINED ON FIRST CALL. SHOULD NOT BE C MODIFIED BY THE USER. C C RELERR, ABSERR = RELATIVE AND ABSOLUTE ERROR VALUES. THE ITERATION C IS CONSIDERED TO HAVE CONVERGED WHEN A POINT Z=(X,LAMBDA) IS C FOUND SUCH THAT C ||DZ|| .LE. RELERR*||Z|| + ABSERR, C WHERE DZ IS THE LAST NEWTON STEP. C C S = (APPROXIMATE) ARC LENGTH ALONG THE HOMOTOPY ZERO CURVE UP TO C Y(S) = (X(S),LAMBDA(S)). C C Y(1:N+1) = PREVIOUS POINT (X(S),LAMBDA(S)) FOUND ON THE ZERO CURVE C OF THE HOMOTOPY MAP. C C YP(1:N+1) = UNIT TANGENT VECTOR TO THE ZERO CURVE OF THE HOMOTOPY C MAP AT Y. INPUT IN THIS VECTOR IS NOT USED ON THE FIRST CALL C TO STEPQS. C C YOLD(1:N+1) = A POINT BEFORE Y ON THE ZERO CURVE OF THE HOMOTOPY C MAP. INPUT IN THIS VECTOR IS NOT USED ON THE FIRST CALL TO C STEPQS. C C YPOLD(1:N+1) = UNIT TANGENT VECTOR TO THE ZERO CURVE OF THE C HOMOTOPY MAP AT YOLD. C C A(1:N) = PARAMETER VECTOR IN THE HOMOTOPY MAP. C C QR(1:LENQR) IS A WORK ARRAY CONTAINING THE N X N SYMMETRIC C JACOBIAN MATRIX WITH RESPECT TO X STORED IN PACKED SKYLINE C STORAGE FORMAT. LENQR AND PIVOT DESCRIBE THE DATA C STRUCTURE IN QR. (SEE SUBROUTINE PCGQS FOR A DESCRIPTION C OF THIS DATA STRUCTURE). C C PIVOT(1:N+2) IS A WORK ARRAY WHOSE FIRST N+1 COMPONENTS CONTAIN C THE INDICES OF THE DIAGONAL ELEMENTS OF THE N X N SYMMETRIC C JACOBIAN MATRIX (WITH RESPECT TO X) WITHIN QR. C C PP(1:N) IS A WORK ARRAY CONTAINING THE NEGATIVE OF THE LAST COLUMN C OF THE JACOBIAN MATRIX -[D RHO/D LAMBDA]. C C RHOVEC(1:N+1), Z0(1:N+1), DZ(1:N+1), T(1:N+1) ARE ALL WORK ARRAYS C USED BY STEPQS, TANGQS, AND ROOTQS TO CALCULATE THE TANGENT C VECTORS AND NEWTON STEPS. C C WORK(1:8*(N+1)+LENQR) IS A WORK ARRAY USED BY THE CONJUGATE GRADIENT C ALGORITHM TO SOLVE LINEAR SYSTEMS. C C SSPAR(1:4) = PARAMETERS USED FOR COMPUTATION OF THE OPTIMAL STEP SIZE. C SSPAR(1) = HMIN, SSPAR(2) = HMAX, SSPAR(3) = BMIN, SSPAR(4) = BMAX. C THE OPTIMAL STEP H IS RESTRICTED SUCH THAT C HMIN .LE. H .LE. HMAX, AND BMIN*HOLD .LE. H .LE. BMAX*HOLD. C C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS, C WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES C RHO, RHOJS. C C C ON OUTPUT: C C N, LENQR, A ARE UNCHANGED. C C NFE HAS BEEN UPDATED. C C IFLAG C C = -2, -1, OR 0 (UNCHANGED) ON A NORMAL RETURN. C C = 4 IF A JACOBIAN MATRIX WITH RANK < N HAS OCCURRED. THE C ITERATION WAS NOT COMPLETED. C C = 6 IF THE ITERATION FAILED TO CONVERGE. C C START = .FALSE. ON A NORMAL RETURN. C C CRASH C C = .FALSE. ON A NORMAL RETURN. C C = .TRUE. IF THE STEP SIZE H WAS TOO SMALL. H HAS BEEN C INCREASED TO AN ACCEPTABLE VALUE, WITH WHICH STEPQS MAY BE C CALLED AGAIN. C C = .TRUE. IF RELERR AND/OR ABSERR WERE TOO SMALL. THEY HAVE C BEEN INCREASED TO ACCEPTABLE VALUES, WITH WHICH STEPQS MAY C BE CALLED AGAIN. C C HOLD = ||Y-YOLD||. C C H = OPTIMAL VALUE FOR NEXT STEP TO BE ATTEMPTED. NORMALLY H SHOULD C NOT BE MODIFIED BY THE USER. C C WK = APPROXIMATE CURVATURE FOR THE STEP TAKEN BY STEPQS. C C S = (APPROXIMATE) ARC LENGTH ALONG THE ZERO CURVE OF THE HOMOTOPY C MAP UP TO THE LATEST POINT FOUND, WHICH IS RETURNED IN Y. C C RELERR, ABSERR ARE UNCHANGED ON A NORMAL RETURN. THEY ARE POSSIBLY C CHANGED IF CRASH = .TRUE. (SEE DESCRIPTION OF CRASH ABOVE). C C Y, YP, YOLD, YPOLD CONTAIN THE TWO MOST RECENT POINTS AND TANGENT C VECTORS FOUND ON THE ZERO CURVE OF THE HOMOTOPY MAP. C C C CALLS D1MACH, DAXPY, DCOPY, DDOT, DNRM2, DSCAL, F (OR RHO), FJACS C (OR RHOJS), PCGQS, TANGQS. C C ***** DECLARATIONS ***** C C FUNCTION DECLARATIONS C DOUBLE PRECISION D1MACH, DDOT, DNRM2, QOFS C C LOCAL VARIABLES C DOUBLE PRECISION ALPHA, CORDIS, DD001, DD0011,DD01,DD011,DELS, $ FOURU, GAMMA, HFAIL, HTEMP, IDLERR, LAMBDA, OMEGA, ONE, P0, $ P1, PP0, PP1, SIGMA, TEMP, THETA, TWOU, WKOLD, XSTEP INTEGER I, ITCNT, LITFH, J, LK, LST, NP1, PCGWK, ZU LOGICAL FAILED C C SCALAR ARGUMENTS C INTEGER N, NFE, IFLAG, LENQR LOGICAL START, CRASH DOUBLE PRECISION HOLD, H, WK, RELERR, ABSERR, S C C ARRAY DECLARATIONS C DOUBLE PRECISION Y(N+1), YP(N+1), YOLD(N+1), YPOLD(N+1), $ A(N), QR(LENQR), PP(N), RHOVEC(N+1), Z0(N+1), DZ(N+1), $ T(N+1), WORK(8*(N+1)+LENQR), SSPAR(4), PAR(1) INTEGER PIVOT(N+2), IPAR(1) REAL WRGE(8),ACOF(12) C SAVE C DATA WRGE / $ .8735115E+00, .1531947E+00, .3191815E-01, .3339946E-10, $ .4677788E+00, .6970123E-03, .1980863E-05, .1122789E-08/ DATA ACOF / $ .9043128E+00,-.7075675E+00,-.4667383E+01,-.3677482E+01, $ .8516099E+00,-.1953119E+00,-.4830636E+01,-.9770528E+00, $ .1040061E+01, .3793395E-01, .1042177E+01, .4450706E-01/ C C ***** END OF DECLARATIONS ***** C C DEFINITION OF HERMITE CUBIC INTERPOLANT VIA DIVIDED DIFFERENCES. C DD01(P0,P1,DELS) = (P1-P0)/DELS DD001(P0,PP0,P1,DELS) = (DD01(P0,P1,DELS)-PP0)/DELS DD011(P0,P1,PP1,DELS) = (PP1-DD01(P0,P1,DELS))/DELS DD0011(P0,PP0,P1,PP1,DELS) = (DD011(P0,P1,PP1,DELS) - $ DD001(P0,PP0,P1,DELS))/DELS QOFS(P0,PP0,P1,PP1,DELS,S) = ((DD0011(P0,PP0,P1,PP1,DELS)* $ (S-DELS) + DD001(P0,PP0,P1,DELS))*S + PP0)*S + P0 C C ***** FIRST EXECUTABLE STATEMENT ***** C C C ***** INITIALIZATION ***** C C LITFH = MAXIMUM NUMBER OF NEWTON ITERATIONS ALLOWED. C ONE = 1.0 TWOU = 2.0*D1MACH(4) FOURU = TWOU + TWOU NP1 = N+1 FAILED = .FALSE. CRASH = .TRUE. LITFH = 10 PCGWK = 2*N+3 ZU = 3*N+4 C C CHECK THAT ALL INPUT PARAMETERS ARE CORRECT. C C THE ARCLENGTH S MUST BE NONNEGATIVE. C IF (S .LT. 0.0) RETURN C C IF STEP SIZE IS TOO SMALL, DETERMINE AN ACCEPTABLE ONE. C IF (H .LT. FOURU*(1.0+S)) THEN H=FOURU*(1.0 + S) RETURN END IF C C IF ERROR TOLERANCES ARE TOO SMALL, INCREASE THEM TO ACCEPTABLE C VALUES. C TEMP=DNRM2(NP1,Y,1) + 1.0 IF (.5*(RELERR*TEMP+ABSERR) .LT. TWOU*TEMP) THEN IF (RELERR .NE. 0.0) THEN RELERR = FOURU*(1.0+FOURU) TEMP = 0.0 ABSERR = MAX(ABSERR,TEMP) ELSE ABSERR=FOURU*TEMP END IF RETURN END IF C C INPUT PARAMETERS WERE ALL ACCEPTABLE. C CRASH = .FALSE. C C COMPUTE YP ON FIRST CALL. C IF (START) THEN C C INITIALIZE THE IDEAL ERROR USED FOR STEP SIZE ESTIMATION. C IDLERR=SQRT(SQRT(ABSERR)) C C INITIALIZE STARTING POINTS FOR THE CONJUGATE GRADIENT C ALGORITHM TO ZERO. C DO 10 J=1,2*N+2 WORK(J)=0.0 10 CONTINUE CALL TANGQS(Y,YP,YPOLD,A,QR,PIVOT,PP,RHOVEC,WORK, $ N,LENQR,IFLAG,NFE,PAR,IPAR) IF (IFLAG .GT. 0) RETURN END IF C C ***** COMPUTE PREDICTOR POINT Z0 ***** C 20 IF (START) THEN C C COMPUTE Z0 WITH LINEAR PREDICTOR USING Y, YP -- C Z0 = Y+H*YP. C CALL DCOPY(NP1,Y,1,Z0,1) CALL DAXPY(NP1,H,YP,1,Z0,1) C ELSE C C COMPUTE Z0 WITH CUBIC PREDICTOR. C DO 30 I=1,NP1 Z0(I) = QOFS(YOLD(I),YPOLD(I),Y(I),YP(I),HOLD,HOLD+H) 30 CONTINUE C END IF C C ***** END OF PREDICTOR SECTION ***** C C ***** NEWTON ITERATION ***** C DO 140 ITCNT = 1,LITFH C C SET STARTING POINTS FOR CONJUGATE GRADIENT ALGORITHM. C DO 40 J=ZU,ZU+2*N+1 WORK(J) = 0.0 40 CONTINUE C C COMPUTE QR = [D RHO/DX], RHOVEC=RHO, -PP= (D RHO/D LAMBDA). C LAMBDA = Z0(NP1) IF (IFLAG .EQ. -2) THEN C C CURVE TRACKING PROBLEM. C CALL RHOJS(A,LAMBDA,Z0,QR,LENQR,PIVOT,PP,PAR,IPAR) CALL RHO(A,LAMBDA,Z0,RHOVEC,PAR,IPAR) ELSE IF (IFLAG .EQ. -1) THEN C C ZERO FINDING PROBLEM. C CALL FJACS(Z0,QR,LENQR,PIVOT) CALL DSCAL(LENQR,LAMBDA,QR,1) SIGMA=1.0-LAMBDA DO 50 J=1,N QR(PIVOT(J))=QR(PIVOT(J))+SIGMA 50 CONTINUE CALL DCOPY(N,Z0,1,RHOVEC,1) CALL DAXPY(N,-ONE,A,1,RHOVEC,1) CALL F(Z0,PP) CALL DSCAL(N,-ONE,PP,1) CALL DAXPY(N,ONE,RHOVEC,1,PP,1) CALL DAXPY(N,-LAMBDA,PP,1,RHOVEC,1) ELSE C C FIXED POINT PROBLEM. C CALL FJACS(Z0,QR,LENQR,PIVOT) CALL DSCAL(LENQR,-LAMBDA,QR,1) DO 60 J=1,N QR(PIVOT(J)) = QR(PIVOT(J))+1.0 60 CONTINUE CALL DCOPY(N,Z0,1,RHOVEC,1) CALL DAXPY(N,-ONE,A,1,RHOVEC,1) CALL F(Z0,PP) CALL DAXPY(N,-ONE,A,1,PP,1) CALL DAXPY(N,-LAMBDA,PP,1,RHOVEC,1) END IF RHOVEC(NP1) = 0.0 NFE = NFE+1 C C SOLVE SYSTEM TO FIND NEWTON STEP DZ. C CALL PCGQS(N,QR,LENQR,PIVOT,PP,YP,RHOVEC,DZ, $ WORK(PCGWK),IFLAG) IF (IFLAG .GT. 0) RETURN C C TAKE STEP. C CALL DAXPY(NP1, ONE, DZ, 1, Z0, 1) C C CHECK FOR CONVERGENCE. C XSTEP=DNRM2(NP1,DZ,1) IF (XSTEP .LE. RELERR*DNRM2(NP1,Z0,1)+ABSERR) THEN GO TO 160 END IF C 140 CONTINUE C C ***** END OF NEWTON LOOP ***** C C ***** DIDN'T CONVERGE OR TANGENT AT NEW POINT DID NOT MAKE ***** C AN ANGLE SMALLER THAN 60 DEGREES WITH YPOLD -- C TRY AGAIN WITH A SMALLER H C 150 FAILED = .TRUE. HFAIL = H IF (H .LE. FOURU*(1.0 + S)) THEN IFLAG = 6 RETURN ELSE H = .5 * H END IF GO TO 20 C C ***** END OF CONVERGENCE FAILURE SECTION ***** C C ***** CONVERGED -- MOP UP AND RETURN ***** C C COMPUTE TANGENT AT Z0. C 160 CALL TANGQS(Z0,T,YP,A,QR,PIVOT,PP,RHOVEC,WORK,N, $ LENQR,IFLAG,NFE,PAR,IPAR) IF (IFLAG .GT. 0) RETURN C C CHECK THAT COMPUTED TANGENT T MAKES AN ANGLE NO LARGER THAN C 60 DEGREES WITH CURRENT TANGENT YP. (I.E., COS OF ANGLE < .5) C IF NOT, STEP SIZE WAS TOO LARGE, SO THROW AWAY Z0, AND TRY C AGAIN WITH A SMALLER STEP. C ALPHA = DDOT(NP1,T,1,YP,1) IF (ALPHA .LT. 0.5) GOTO 150 ALPHA = ACOS(ALPHA) C C COMPUTE CORRECTOR DISTANCE. C IF (START) THEN CALL DCOPY(NP1,Y,1,WORK(PCGWK),1) CALL DAXPY(NP1,H,YP,1,WORK(PCGWK),1) ELSE DO 170 I=1,NP1 WORK(PCGWK+I-1)=QOFS(YOLD(I),YPOLD(I),Y(I),YP(I),HOLD,HOLD+H) 170 CONTINUE ENDIF CALL DAXPY(NP1,-ONE,Z0,1,WORK(PCGWK),1) CORDIS=DNRM2(NP1,WORK(PCGWK),1) C C SET UP VARIABLES FOR NEXT CALL. C CALL DCOPY(NP1,Y,1,YOLD,1) CALL DCOPY(NP1,Z0,1,Y,1) CALL DCOPY(NP1,YP,1,YPOLD,1) CALL DCOPY(NP1,T,1,YP,1) C C UPDATE ARCLENGTH S = S + ||Y-YOLD||. C HTEMP = HOLD CALL DAXPY(NP1,-ONE,YOLD,1,Z0,1) HOLD = DNRM2(NP1,Z0,1) S = S+HOLD C C COMPUTE IDEAL ERROR FOR STEP SIZE ESTIMATION. C IF (ITCNT .LE. 1) THEN THETA = 8.0 ELSE IF (ITCNT .EQ. 4) THEN THETA = 1.0 ELSE OMEGA=XSTEP/CORDIS IF (ITCNT .LT. 4) THEN LK = 4*ITCNT-7 IF (OMEGA .GE. WRGE(LK)) THEN THETA = 1.0 ELSE IF (OMEGA .GE. WRGE(LK+1)) THEN THETA = ACOF(LK) + ACOF(LK+1)*LOG(OMEGA) ELSE IF (OMEGA .GE. WRGE(LK+2)) THEN THETA = ACOF(LK+2) + ACOF(LK+3)*LOG(OMEGA) ELSE THETA = 8.0 END IF ELSE IF (ITCNT .GE. 7) THEN THETA = 0.125 ELSE LK = 4*ITCNT - 16 IF (OMEGA .GT. WRGE(LK)) THEN LST = 2*ITCNT - 1 THETA = ACOF(LST) + ACOF(LST+1)*LOG(OMEGA) ELSE THETA = 0.125 END IF END IF END IF IDLERR=THETA*IDLERR C C IDLERR SHOULD BE NO BIGGER THAN 1/2 PREVIOUS STEP. C IDLERR = MIN(.5*HOLD,IDLERR) C C COMPUTE OPTIMAL STEP SIZE. C WK = APPROXIMATE CURVATURE = 2*SIN(ALPHA/2)/HOLD WHERE C ALPHA = ARCCOS(YP*YPOLD). C GAMMA = EXPECTED CURVATURE FOR NEXT STEP, COMPUTED BY C EXTRAPOLATING FROM CURRENT CURVATURE WK, AND LAST C CURVATURE WKOLD. GAMMA IS FURTHER REQUIRED TO BE C POSITIVE. C WKOLD = WK WK = 2.0*ABS(SIN(.5*ALPHA))/HOLD IF (START) THEN GAMMA = WK ELSE GAMMA = WK + HOLD/(HOLD+HTEMP)*(WK-WKOLD) END IF GAMMA = MAX(GAMMA, 0.01*ONE) H = SQRT(2.0*IDLERR/GAMMA) C C ENFORCE RESTRICTIONS ON STEP SIZE SO AS TO ENSURE STABILITY. C HMIN <= H <= HMAX, BMIN*HOLD <= H <= BMAX*HOLD. C H = MIN(MAX(SSPAR(1),SSPAR(3)*HOLD,H),SSPAR(4)*HOLD,SSPAR(2)) IF (FAILED) H = MIN(HFAIL,H) START = .FALSE. C C ***** END OF MOP UP SECTION ***** C RETURN C C ***** END OF SUBROUTINE STEPQS ***** END SUBROUTINE STEPS(F,NEQN,Y,X,H,EPS,WT,START,HOLD,K,KOLD,CRASH,PHI, 1 P,YP,ALPHA,W,G,KSTEPS,XOLD,IVC,IV,KGI,GI, FPWA1,FPWA2,FPWA3, 2 FPWA4,FPWA5,IFPWA1,IFPC1,IFPC2,PAR,IPAR) C C C C WRITTEN BY L. F. SHAMPINE AND M. K. GORDON C C ABSTRACT C C SUBROUTINE STEPS IS NORMALLY USED INDIRECTLY THROUGH SUBROUTINE C DEABM . BECAUSE DEABM SUFFICES FOR MOST PROBLEMS AND IS MUCH C EASIER TO USE, USING IT SHOULD BE CONSIDERED BEFORE USING STEPS C ALONE. C C SUBROUTINE STEPS INTEGRATES A SYSTEM OF NEQN FIRST ORDER ORDINARY C DIFFERENTIAL EQUATIONS ONE STEP, NORMALLY FROM X TO X+H, USING A C MODIFIED DIVIDED DIFFERENCE FORM OF THE ADAMS PECE FORMULAS. LOCAL C EXTRAPOLATION IS USED TO IMPROVE ABSOLUTE STABILITY AND ACCURACY. C THE CODE ADJUSTS ITS ORDER AND STEP SIZE TO CONTROL THE LOCAL ERROR C PER UNIT STEP IN A GENERALIZED SENSE. SPECIAL DEVICES ARE INCLUDED C TO CONTROL ROUNDOFF ERROR AND TO DETECT WHEN THE USER IS REQUESTING C TOO MUCH ACCURACY. C C THIS CODE IS COMPLETELY EXPLAINED AND DOCUMENTED IN THE TEXT, C COMPUTER SOLUTION OF ORDINARY DIFFERENTIAL EQUATIONS, THE INITIAL C VALUE PROBLEM BY L. F. SHAMPINE AND M. K. GORDON. C FURTHER DETAILS ON USE OF THIS CODE ARE AVAILABLE IN *SOLVING C ORDINARY DIFFERENTIAL EQUATIONS WITH ODE, STEP, AND INTRP*, C BY L. F. SHAMPINE AND M. K. GORDON, SLA-73-1060. C C C THE PARAMETERS REPRESENT -- C F -- SUBROUTINE TO EVALUATE DERIVATIVES C NEQN -- NUMBER OF EQUATIONS TO BE INTEGRATED C Y(*) -- SOLUTION VECTOR AT X C X -- INDEPENDENT VARIABLE C H -- APPROPRIATE STEP SIZE FOR NEXT STEP. NORMALLY DETERMINED BY C CODE C EPS -- LOCAL ERROR TOLERANCE C WT(*) -- VECTOR OF WEIGHTS FOR ERROR CRITERION C START -- LOGICAL VARIABLE SET .TRUE. FOR FIRST STEP, .FALSE. C OTHERWISE C HOLD -- STEP SIZE USED FOR LAST SUCCESSFUL STEP C K -- APPROPRIATE ORDER FOR NEXT STEP (DETERMINED BY CODE) C KOLD -- ORDER USED FOR LAST SUCCESSFUL STEP C CRASH -- LOGICAL VARIABLE SET .TRUE. WHEN NO STEP CAN BE TAKEN, C .FALSE. OTHERWISE. C YP(*) -- DERIVATIVE OF SOLUTION VECTOR AT X AFTER SUCCESSFUL C STEP C KSTEPS -- COUNTER ON ATTEMPTED STEPS C C THE VARIABLES X,XOLD,KOLD,KGI AND IVC AND THE ARRAYS Y,PHI,ALPHA,G, C W,P,IV AND GI ARE REQUIRED FOR THE INTERPOLATION SUBROUTINE SINTRP. C THE ARRAYS FPWA* AND IFPWA1 AND INTEGER CONSTANTS IFPC* ARE C WORKING STORAGE PASSED DIRECTLY THROUGH TO FODE. THE ARRAYS C PAR AND IPAR ARE USER PARAMETERS PASSED THROUGH TO RHOA AND RHOJAC. C C INPUT TO STEPS C C FIRST CALL -- C C THE USER MUST PROVIDE STORAGE IN HIS CALLING PROGRAM FOR ALL ARRAYS C IN THE CALL LIST, NAMELY C C DIMENSION Y(NEQN),WT(NEQN),PHI(NEQN,16),P(NEQN),YP(NEQN), C 1 ALPHA(12),W(12),G(13),GI(11),IV(10), FPWA1(NEQN), C 2 FPWA2(NEQN-1),FPWA3(NEQN-1,NEQN),FPWA4(NEQN-1), C 3 FPWA5(NEQN),IFPWA1(NEQN) C -- -- **NOTE** C C THE USER MUST ALSO DECLARE START AND CRASH C LOGICAL VARIABLES AND F AN EXTERNAL SUBROUTINE, SUPPLY THE C SUBROUTINE F(X,Y,YP,FPWA1,FPWA2,FPWA3,FPWA4,FPWA5,IFPWA1,IFPC1, C NEQN-1,IFPC2,PAR,IPAR) TO EVALUATE C DY(I)/DX = YP(I) = F(X,Y(1),Y(2),...,Y(NEQN)) C AND INITIALIZE ONLY THE FOLLOWING PARAMETERS. C NEQN -- NUMBER OF EQUATIONS TO BE INTEGRATED C Y(*) -- VECTOR OF INITIAL VALUES OF DEPENDENT VARIABLES C X -- INITIAL VALUE OF THE INDEPENDENT VARIABLE C H -- NOMINAL STEP SIZE INDICATING DIRECTION OF INTEGRATION C AND MAXIMUM SIZE OF STEP. MUST BE VARIABLE C EPS -- LOCAL ERROR TOLERANCE PER STEP. MUST BE VARIABLE C WT(*) -- VECTOR OF NON-ZERO WEIGHTS FOR ERROR CRITERION C START -- .TRUE. C KSTEPS -- SET KSTEPS TO ZERO C DEFINE U TO BE THE MACHINE UNIT ROUNDOFF QUANTITY BY CALLING C THE FUNCTION ROUTINE D1MACH, U = D1MACH(3), OR BY C COMPUTING U SO THAT U IS THE SMALLEST POSITIVE NUMBER SUCH C THAT 1.0+U .GT. 1.0. C C STEPS REQUIRES THAT THE L2 NORM OF THE VECTOR WITH COMPONENTS C LOCAL ERROR(L)/WT(L) BE LESS THAN EPS FOR A SUCCESSFUL STEP. THE C ARRAY WT ALLOWS THE USER TO SPECIFY AN ERROR TEST APPROPRIATE C FOR HIS PROBLEM. FOR EXAMPLE, C WT(L) = 1.0 SPECIFIES ABSOLUTE ERROR, C = ABS(Y(L)) ERROR RELATIVE TO THE MOST RECENT VALUE OF THE C L-TH COMPONENT OF THE SOLUTION, C = ABS(YP(L)) ERROR RELATIVE TO THE MOST RECENT VALUE OF C THE L-TH COMPONENT OF THE DERIVATIVE, C = MAX(WT(L),ABS(Y(L))) ERROR RELATIVE TO THE LARGEST C MAGNITUDE OF L-TH COMPONENT OBTAINED SO FAR, C = ABS(Y(L))*RELERR/EPS + ABSERR/EPS SPECIFIES A MIXED C RELATIVE-ABSOLUTE TEST WHERE RELERR IS RELATIVE C ERROR, ABSERR IS ABSOLUTE ERROR AND EPS = C MAX(RELERR,ABSERR) . C C SUBSEQUENT CALLS -- C C SUBROUTINE STEPS IS DESIGNED SO THAT ALL INFORMATION NEEDED TO C CONTINUE THE INTEGRATION, INCLUDING THE STEP SIZE H AND THE ORDER C K , IS RETURNED WITH EACH STEP. WITH THE EXCEPTION OF THE STEP C SIZE, THE ERROR TOLERANCE, AND THE WEIGHTS, NONE OF THE PARAMETERS C SHOULD BE ALTERED. THE ARRAY WT MUST BE UPDATED AFTER EACH STEP C TO MAINTAIN RELATIVE ERROR TESTS LIKE THOSE ABOVE. NORMALLY THE C INTEGRATION IS CONTINUED JUST BEYOND THE DESIRED ENDPOINT AND THE C SOLUTION INTERPOLATED THERE WITH SUBROUTINE SINTRP . IF IT IS C IMPOSSIBLE TO INTEGRATE BEYOND THE ENDPOINT, THE STEP SIZE MAY BE C REDUCED TO HIT THE ENDPOINT SINCE THE CODE WILL NOT TAKE A STEP C LARGER THAN THE H INPUT. CHANGING THE DIRECTION OF INTEGRATION, C I.E., THE SIGN OF H , REQUIRES THE USER SET START = .TRUE. BEFORE C CALLING STEPS AGAIN. THIS IS THE ONLY SITUATION IN WHICH START C SHOULD BE ALTERED. C C OUTPUT FROM STEPS C C SUCCESSFUL STEP -- C C THE SUBROUTINE RETURNS AFTER EACH SUCCESSFUL STEP WITH START AND C CRASH SET .FALSE. . X REPRESENTS THE INDEPENDENT VARIABLE C ADVANCED ONE STEP OF LENGTH HOLD FROM ITS VALUE ON INPUT AND Y C THE SOLUTION VECTOR AT THE NEW VALUE OF X . ALL OTHER PARAMETERS C REPRESENT INFORMATION CORRESPONDING TO THE NEW X NEEDED TO C CONTINUE THE INTEGRATION. C C UNSUCCESSFUL STEP -- C C WHEN THE ERROR TOLERANCE IS TOO SMALL FOR THE MACHINE PRECISION, C THE SUBROUTINE RETURNS WITHOUT TAKING A STEP AND CRASH = .TRUE. . C AN APPROPRIATE STEP SIZE AND ERROR TOLERANCE FOR CONTINUING ARE C ESTIMATED AND ALL OTHER INFORMATION IS RESTORED AS UPON INPUT C BEFORE RETURNING. TO CONTINUE WITH THE LARGER TOLERANCE, THE USER C JUST CALLS THE CODE AGAIN. A RESTART IS NEITHER REQUIRED NOR C DESIRABLE. C***REFERENCES SHAMPINE L.F., GORDON M.K., *SOLVING ORDINARY C DIFFERENTIAL EQUATIONS WITH ODE, STEP, AND INTRP*, C SLA-73-1060, SANDIA LABORATORIES, 1973. C DOUBLE PRECISION ABSH,ALPHA,BETA,D1MACH,EPS,ERK,ERKM1,ERKM2, 1 ERKP1,ERR,FOURU,FPWA1,FPWA2,FPWA3,FPWA4,FPWA5,G,GI,GSTR,H, 2 HNEW,HOLD,P,PAR,P5EPS,PHI,PSI,R,REALI,REALNS,RHO,ROUND,SIG, 3 SUM,TAU,TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,TEMP6,TWO,TWOU,V, 4 W,WT,X,XOLD,Y,YP INTEGER I,IFAIL,IFPC1,IFPC2,IFPWA1,IM1,IPAR,IP1,IQ,IV,IVC, 1 J,JV,K,KGI,KM1,KM2,KNEW,KOLD,KP1,KP2,KPREV,KSTEPS, 2 L,LIMIT1,LIMIT2,NEQN,NS,NSM2,NSP1,NSP2 LOGICAL START,CRASH,PHASE1,NORND C DIMENSION Y(NEQN),WT(NEQN),PHI(NEQN,16),P(NEQN),YP(NEQN),PSI(12), 1 ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13),GI(11),IV(10), 2 FPWA1(NEQN),FPWA2(NEQN-1),FPWA3(NEQN-1,NEQN),FPWA4(NEQN-1), 3 FPWA5(NEQN),IFPWA1(NEQN),PAR(1),IPAR(1) DIMENSION TWO(13),GSTR(13) C C ALL LOCAL VARIABLES ARE SAVED, RATHER THAN PASSED, IN THIS C SPECIALIZED VERSION OF STEPS. C SAVE C EXTERNAL F C DATA TWO/2.0,4.0,8.0,16.0,32.0,64.0,128.0,256.0,512.0,1024.0, 1 2048.0,4096.0,8192.0/ DATA GSTR/0.500,0.0833,0.0417,0.0264,0.0188,0.0143,0.0114,0.00936, 1 0.00789,0.00679,0.00592,0.00524,0.00468/ C C C *** BEGIN BLOCK 0 *** C CHECK IF STEP SIZE OR ERROR TOLERANCE IS TOO SMALL FOR MACHINE C PRECISION. IF FIRST STEP, INITIALIZE PHI ARRAY AND ESTIMATE A C STARTING STEP SIZE. C *** C C IF STEP SIZE IS TOO SMALL, DETERMINE AN ACCEPTABLE ONE C C***FIRST EXECUTABLE STATEMENT TWOU = 2.0 * D1MACH(4) FOURU = TWOU + TWOU CRASH = .TRUE. IF(ABS(H) .GE. FOURU*ABS(X)) GO TO 5 H = SIGN(FOURU*ABS(X),H) RETURN 5 P5EPS = 0.5*EPS C C IF ERROR TOLERANCE IS TOO SMALL, INCREASE IT TO AN ACCEPTABLE VALUE C ROUND = 0.0 DO 10 L = 1,NEQN 10 ROUND = ROUND + (Y(L)/WT(L))**2 ROUND = TWOU*SQRT(ROUND) IF(P5EPS .GE. ROUND) GO TO 15 EPS = 2.0*ROUND*(1.0 + FOURU) RETURN 15 CRASH = .FALSE. G(1) = 1.0 G(2) = 0.5 SIG(1) = 1.0 IF(.NOT.START) GO TO 99 C C INITIALIZE. COMPUTE APPROPRIATE STEP SIZE FOR FIRST STEP C CALL F(X,Y,YP,FPWA1,FPWA2,FPWA3,FPWA4,FPWA5,IFPWA1, $ IFPC1,NEQN-1,IFPC2,PAR,IPAR) IF (IFPC2 .GT. 0) RETURN SUM = 0.0 DO 20 L = 1,NEQN PHI(L,1) = YP(L) PHI(L,2) = 0.0 20 SUM = SUM + (YP(L)/WT(L))**2 SUM = SQRT(SUM) ABSH = ABS(H) IF(EPS .LT. 16.0*SUM*H*H) ABSH = 0.25*SQRT(EPS/SUM) H = SIGN(MAX(ABSH,FOURU*ABS(X)),H) C C* U = D1MACH(3) C* BIG = SQRT(D1MACH(2)) C* CALL HSTART (F,NEQN,X,X+H,Y,YP,WT,1,U,BIG, C* 1 PHI(1,3),PHI(1,4),PHI(1,5),PHI(1,6),RPAR,IPAR,H) C HOLD = 0.0 K = 1 KOLD = 0 KPREV = 0 START = .FALSE. PHASE1 = .TRUE. NORND = .TRUE. IF(P5EPS .GT. 100.0*ROUND) GO TO 99 NORND = .FALSE. DO 25 L = 1,NEQN 25 PHI(L,15) = 0.0 99 IFAIL = 0 C *** END BLOCK 0 *** C C *** BEGIN BLOCK 1 *** C COMPUTE COEFFICIENTS OF FORMULAS FOR THIS STEP. AVOID COMPUTING C THOSE QUANTITIES NOT CHANGED WHEN STEP SIZE IS NOT CHANGED. C *** C 100 KP1 = K+1 KP2 = K+2 KM1 = K-1 KM2 = K-2 C C NS IS THE NUMBER OF STEPS TAKEN WITH SIZE H, INCLUDING THE CURRENT C ONE. WHEN K.LT.NS, NO COEFFICIENTS CHANGE C IF(H .NE. HOLD) NS = 0 IF (NS.LE.KOLD) NS = NS+1 NSP1 = NS+1 IF (K .LT. NS) GO TO 199 C C COMPUTE THOSE COMPONENTS OF ALPHA(*),BETA(*),PSI(*),SIG(*) WHICH C ARE CHANGED C BETA(NS) = 1.0 REALNS = NS ALPHA(NS) = 1.0/REALNS TEMP1 = H*REALNS SIG(NSP1) = 1.0 IF(K .LT. NSP1) GO TO 110 DO 105 I = NSP1,K IM1 = I-1 TEMP2 = PSI(IM1) PSI(IM1) = TEMP1 BETA(I) = BETA(IM1)*PSI(IM1)/TEMP2 TEMP1 = TEMP2 + H ALPHA(I) = H/TEMP1 REALI = I 105 SIG(I+1) = REALI*ALPHA(I)*SIG(I) 110 PSI(K) = TEMP1 C C COMPUTE COEFFICIENTS G(*) C C INITIALIZE V(*) AND SET W(*). C IF(NS .GT. 1) GO TO 120 DO 115 IQ = 1,K TEMP3 = IQ*(IQ+1) V(IQ) = 1.0/TEMP3 115 W(IQ) = V(IQ) IVC = 0 KGI = 0 IF (K .EQ. 1) GO TO 140 KGI = 1 GI(1) = W(2) GO TO 140 C C IF ORDER WAS RAISED, UPDATE DIAGONAL PART OF V(*) C 120 IF(K .LE. KPREV) GO TO 130 IF (IVC .EQ. 0) GO TO 122 JV = KP1 - IV(IVC) IVC = IVC - 1 GO TO 123 122 JV = 1 TEMP4 = K*KP1 V(K) = 1.0/TEMP4 W(K) = V(K) IF (K .NE. 2) GO TO 123 KGI = 1 GI(1) = W(2) 123 NSM2 = NS-2 IF(NSM2 .LT. JV) GO TO 130 DO 125 J = JV,NSM2 I = K-J V(I) = V(I) - ALPHA(J+1)*V(I+1) 125 W(I) = V(I) IF (I .NE. 2) GO TO 130 KGI = NS - 1 GI(KGI) = W(2) C C UPDATE V(*) AND SET W(*) C 130 LIMIT1 = KP1 - NS TEMP5 = ALPHA(NS) DO 135 IQ = 1,LIMIT1 V(IQ) = V(IQ) - TEMP5*V(IQ+1) 135 W(IQ) = V(IQ) G(NSP1) = W(1) IF (LIMIT1 .EQ. 1) GO TO 137 KGI = NS GI(KGI) = W(2) 137 W(LIMIT1+1) = V(LIMIT1+1) IF (K .GE. KOLD) GO TO 140 IVC = IVC + 1 IV(IVC) = LIMIT1 + 2 C C COMPUTE THE G(*) IN THE WORK VECTOR W(*) C 140 NSP2 = NS + 2 KPREV = K IF(KP1 .LT. NSP2) GO TO 199 DO 150 I = NSP2,KP1 LIMIT2 = KP2 - I TEMP6 = ALPHA(I-1) DO 145 IQ = 1,LIMIT2 145 W(IQ) = W(IQ) - TEMP6*W(IQ+1) 150 G(I) = W(1) 199 CONTINUE C *** END BLOCK 1 *** C C *** BEGIN BLOCK 2 *** C PREDICT A SOLUTION P(*), EVALUATE DERIVATIVES USING PREDICTED C SOLUTION, ESTIMATE LOCAL ERROR AT ORDER K AND ERRORS AT ORDERS K, C K-1, K-2 AS IF CONSTANT STEP SIZE WERE USED. C *** C C INCREMENT COUNTER ON ATTEMPTED STEPS C KSTEPS = KSTEPS + 1 C C CHANGE PHI TO PHI STAR C IF(K .LT. NSP1) GO TO 215 DO 210 I = NSP1,K TEMP1 = BETA(I) DO 205 L = 1,NEQN 205 PHI(L,I) = TEMP1*PHI(L,I) 210 CONTINUE C C PREDICT SOLUTION AND DIFFERENCES C 215 DO 220 L = 1,NEQN PHI(L,KP2) = PHI(L,KP1) PHI(L,KP1) = 0.0 220 P(L) = 0.0 DO 230 J = 1,K I = KP1 - J IP1 = I+1 TEMP2 = G(I) DO 225 L = 1,NEQN P(L) = P(L) + TEMP2*PHI(L,I) 225 PHI(L,I) = PHI(L,I) + PHI(L,IP1) 230 CONTINUE IF(NORND) GO TO 240 DO 235 L = 1,NEQN TAU = H*P(L) - PHI(L,15) P(L) = Y(L) + TAU 235 PHI(L,16) = (P(L) - Y(L)) - TAU GO TO 250 240 DO 245 L = 1,NEQN 245 P(L) = Y(L) + H*P(L) 250 XOLD = X X = X + H ABSH = ABS(H) CALL F(X,P,YP,FPWA1,FPWA2,FPWA3,FPWA4,FPWA5,IFPWA1, $ IFPC1,NEQN-1,IFPC2,PAR,IPAR) IF (IFPC2 .GT. 0) RETURN C C ESTIMATE ERRORS AT ORDERS K,K-1,K-2 C ERKM2 = 0.0 ERKM1 = 0.0 ERK = 0.0 DO 265 L = 1,NEQN TEMP3 = 1.0/WT(L) TEMP4 = YP(L) - PHI(L,1) IF(KM2)265,260,255 255 ERKM2 = ERKM2 + ((PHI(L,KM1)+TEMP4)*TEMP3)**2 260 ERKM1 = ERKM1 + ((PHI(L,K)+TEMP4)*TEMP3)**2 265 ERK = ERK + (TEMP4*TEMP3)**2 IF(KM2)280,275,270 270 ERKM2 = ABSH*SIG(KM1)*GSTR(KM2)*SQRT(ERKM2) 275 ERKM1 = ABSH*SIG(K)*GSTR(KM1)*SQRT(ERKM1) 280 TEMP5 = ABSH*SQRT(ERK) ERR = TEMP5*(G(K)-G(KP1)) ERK = TEMP5*SIG(KP1)*GSTR(K) KNEW = K C C TEST IF ORDER SHOULD BE LOWERED C IF(KM2)299,290,285 285 IF(MAX(ERKM1,ERKM2) .LE. ERK) KNEW = KM1 GO TO 299 290 IF(ERKM1 .LE. 0.5*ERK) KNEW = KM1 C C TEST IF STEP SUCCESSFUL C 299 IF(ERR .LE. EPS) GO TO 400 C *** END BLOCK 2 *** C C *** BEGIN BLOCK 3 *** C THE STEP IS UNSUCCESSFUL. RESTORE X, PHI(*,*), PSI(*) . C IF THIRD CONSECUTIVE FAILURE, SET ORDER TO ONE. IF STEP FAILS MORE C THAN THREE TIMES, CONSIDER AN OPTIMAL STEP SIZE. DOUBLE ERROR C TOLERANCE AND RETURN IF ESTIMATED STEP SIZE IS TOO SMALL FOR MACHINE C PRECISION. C *** C C RESTORE X, PHI(*,*) AND PSI(*) C PHASE1 = .FALSE. X = XOLD DO 310 I = 1,K TEMP1 = 1.0/BETA(I) IP1 = I+1 DO 305 L = 1,NEQN 305 PHI(L,I) = TEMP1*(PHI(L,I) - PHI(L,IP1)) 310 CONTINUE IF(K .LT. 2) GO TO 320 DO 315 I = 2,K 315 PSI(I-1) = PSI(I) - H C C ON THIRD FAILURE, SET ORDER TO ONE. THEREAFTER, USE OPTIMAL STEP C SIZE C 320 IFAIL = IFAIL + 1 TEMP2 = 0.5 IF(IFAIL - 3) 335,330,325 325 IF(P5EPS .LT. 0.25*ERK) TEMP2 = SQRT(P5EPS/ERK) 330 KNEW = 1 335 H = TEMP2*H K = KNEW NS = 0 IF(ABS(H) .GE. FOURU*ABS(X)) GO TO 340 CRASH = .TRUE. H = SIGN(FOURU*ABS(X),H) EPS = EPS + EPS RETURN 340 GO TO 100 C *** END BLOCK 3 *** C C *** BEGIN BLOCK 4 *** C THE STEP IS SUCCESSFUL. CORRECT THE PREDICTED SOLUTION, EVALUATE C THE DERIVATIVES USING THE CORRECTED SOLUTION AND UPDATE THE C DIFFERENCES. DETERMINE BEST ORDER AND STEP SIZE FOR NEXT STEP. C *** 400 KOLD = K HOLD = H C C CORRECT AND EVALUATE C TEMP1 = H*G(KP1) IF(NORND) GO TO 410 DO 405 L = 1,NEQN TEMP3 = Y(L) RHO = TEMP1*(YP(L) - PHI(L,1)) - PHI(L,16) Y(L) = P(L) + RHO PHI(L,15) = (Y(L) - P(L)) - RHO 405 P(L) = TEMP3 GO TO 420 410 DO 415 L = 1,NEQN TEMP3 = Y(L) Y(L) = P(L) + TEMP1*(YP(L) - PHI(L,1)) 415 P(L) = TEMP3 420 CALL F(X,Y,YP,FPWA1,FPWA2,FPWA3,FPWA4,FPWA5,IFPWA1, $ IFPC1,NEQN-1,IFPC2,PAR,IPAR) IF (IFPC2 .GT. 0) RETURN C C UPDATE DIFFERENCES FOR NEXT STEP C DO 425 L = 1,NEQN PHI(L,KP1) = YP(L) - PHI(L,1) 425 PHI(L,KP2) = PHI(L,KP1) - PHI(L,KP2) DO 435 I = 1,K DO 430 L = 1,NEQN 430 PHI(L,I) = PHI(L,I) + PHI(L,KP1) 435 CONTINUE C C ESTIMATE ERROR AT ORDER K+1 UNLESS: C IN FIRST PHASE WHEN ALWAYS RAISE ORDER, C ALREADY DECIDED TO LOWER ORDER, C STEP SIZE NOT CONSTANT SO ESTIMATE UNRELIABLE C ERKP1 = 0.0 IF(KNEW .EQ. KM1 .OR. K .EQ. 12) PHASE1 = .FALSE. IF(PHASE1) GO TO 450 IF(KNEW .EQ. KM1) GO TO 455 IF(KP1 .GT. NS) GO TO 460 DO 440 L = 1,NEQN 440 ERKP1 = ERKP1 + (PHI(L,KP2)/WT(L))**2 ERKP1 = ABSH*GSTR(KP1)*SQRT(ERKP1) C C USING ESTIMATED ERROR AT ORDER K+1, DETERMINE APPROPRIATE ORDER C FOR NEXT STEP C IF(K .GT. 1) GO TO 445 IF(ERKP1 .GE. 0.5*ERK) GO TO 460 GO TO 450 445 IF(ERKM1 .LE. MIN(ERK,ERKP1)) GO TO 455 IF(ERKP1 .GE. ERK .OR. K .EQ. 12) GO TO 460 C C HERE ERKP1 .LT. ERK .LT. MAX(ERKM1,ERKM2) ELSE ORDER WOULD HAVE C BEEN LOWERED IN BLOCK 2. THUS ORDER IS TO BE RAISED C C RAISE ORDER C 450 K = KP1 ERK = ERKP1 GO TO 460 C C LOWER ORDER C 455 K = KM1 ERK = ERKM1 C C WITH NEW ORDER DETERMINE APPROPRIATE STEP SIZE FOR NEXT STEP C 460 HNEW = H + H IF(PHASE1) GO TO 465 IF(P5EPS .GE. ERK*TWO(K+1)) GO TO 465 HNEW = H IF(P5EPS .GE. ERK) GO TO 465 TEMP2 = K+1 R = (P5EPS/ERK)**(1.0/TEMP2) HNEW = ABSH*MAX(0.5D0,MIN(0.9D0,R)) HNEW = SIGN(MAX(HNEW,FOURU*ABS(X)),H) 465 H = HNEW RETURN C *** END BLOCK 4 *** END SUBROUTINE STRPTP(N,ICOUNT,IDEG,R ,X) C C COMPUTES INITIAL POINTS FOR PATHS. C C ON INPUT: C C N IS THE NUMBER OF (COMPLEX) VARIABLES. C C ICOUNT IS A COUNTER USED TO INCREMENT EACH C VARIABLE AROUND THE UNIT CIRCLE SO THAT EVERY C COMBINATION OF START VALUES IS CHOSEN. ICOUNT IS C INITIALIZED IN POLYP. C C IDEG(J) IS THE DEGREE OF THE J-TH EQUATION. C C R(I,J) IS A (COMPLEX) ARRAY GENERATED BY SUBROUTINE INITP. C R(1,J), AND R(2,J) ARE THE REAL AND IMAGINARY PARTS, RESPECTIVELY. C C ON OUTPUT: C C X(I,J) IS INITIALIZED TO THE START VALUES FOR THE CURRENT PATH, C WITH X(1,J) AND X(2,J) THE REAL AND IMAGINARY PARTS OF THE C J-TH VARIABLE, RESPECTIVELY. C C SUBROUTINES: ATAN, COS, MULP, SIN. C C DECLARATION OF INPUT AND OUTPUT: INTEGER N,ICOUNT,IDEG DOUBLE PRECISION R ,X DIMENSION ICOUNT(N),IDEG(N) DIMENSION R(2,N),X(2,N) C C DECLARATION OF VARIABLES: INTEGER J DOUBLE PRECISION TWOPI,ANGLE,XXXX DIMENSION XXXX(2) C DO 10 J=1,N IF(ICOUNT(J) .GE. IDEG(J) ) THEN ICOUNT(J)=1 ELSE ICOUNT(J)=ICOUNT(J)+1 GOTO 20 END IF 10 CONTINUE 20 CONTINUE TWOPI = 8.0*ATAN(1.0) DO 30 J=1,N ANGLE = ( TWOPI/IDEG(J) )*ICOUNT(J) XXXX(1) = COS(ANGLE) XXXX(2) = SIN(ANGLE) CALL MULP(XXXX,R(1,J),X(1,J)) 30 CONTINUE RETURN END SUBROUTINE TANGNF(RHOLEN,Y,YP,YPOLD,A,QR,ALPHA,TZ,PIVOT, $ NFE,N,IFLAG,PAR,IPAR) C C THIS SUBROUTINE BUILDS THE JACOBIAN MATRIX OF THE HOMOTOPY MAP, C COMPUTES A QR DECOMPOSITION OF THAT MATRIX, AND THEN CALCULATES THE C (UNIT) TANGENT VECTOR AND THE NEWTON STEP. C C ON INPUT: C C RHOLEN < 0 IF THE NORM OF THE HOMOTOPY MAP EVALUATED AT C (A, LAMBDA, X) IS TO BE COMPUTED. IF RHOLEN >= 0 THE NORM IS NOT C COMPUTED AND RHOLEN IS NOT CHANGED. C C Y(1:N+1) = CURRENT POINT (LAMBDA(S), X(S)). C C YPOLD(1:N+1) = UNIT TANGENT VECTOR AT PREVIOUS POINT ON THE ZERO C CURVE OF THE HOMOTOPY MAP. C C A(1:*) = PARAMETER VECTOR IN THE HOMOTOPY MAP. C C QR(1:N,1:N+2), ALPHA(1:N), TZ(1:N+1), PIVOT(1:N+1) ARE WORK ARRAYS C USED FOR THE QR FACTORIZATION. C C NFE = NUMBER OF JACOBIAN MATRIX EVALUATIONS = NUMBER OF HOMOTOPY C FUNCTION EVALUATIONS. C C N = DIMENSION OF X. C C IFLAG = -2, -1, OR 0, INDICATING THE PROBLEM TYPE. C C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS, C WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES C RHO, RHOJAC. C C ON OUTPUT: C C RHOLEN = ||RHO(A, LAMBDA(S), X(S)|| IF RHOLEN < 0 ON INPUT. C OTHERWISE RHOLEN IS UNCHANGED. C C Y, YPOLD, A, N ARE UNCHANGED. C C YP(1:N+1) = DY/DS = UNIT TANGENT VECTOR TO INTEGRAL CURVE OF C D(HOMOTOPY MAP)/DS = 0 AT Y(S) = (LAMBDA(S), X(S)) . C C TZ = THE NEWTON STEP = -(PSEUDO INVERSE OF (D RHO(A,Y(S))/D LAMBDA , C D RHO(A,Y(S))/DX)) * RHO(A,Y(S)) . C C NFE HAS BEEN INCRMENTED BY 1. C C IFLAG IS UNCHANGED, UNLESS THE QR FACTORIZATION DETECTS A RANK < N, C IN WHICH CASE THE TANGENT AND NEWTON STEP VECTORS ARE NOT COMPUTED C AND TANGNF RETURNS WITH IFLAG = 4 . C C C CALLS DDOT , DNRM2 , F (OR RHO ), FJAC (OR RHOJAC ). C DOUBLE PRECISION ALPHAK,BETA,DDOT,DNRM2,LAMBDA,QRKK,RHOLEN, $ SIGMA,SUM,YPNORM INTEGER I,IFLAG,J,JBAR,K,KP1,N,NFE,NP1,NP2 C C ***** ARRAY DECLARATIONS. ***** C DOUBLE PRECISION Y(N+1),YP(N+1),YPOLD(N+1),A(N),PAR(1) INTEGER IPAR(1) C C ARRAYS FOR COMPUTING THE JACOBIAN MATRIX AND ITS KERNEL. DOUBLE PRECISION QR(N,N+2),ALPHA(N),TZ(N+1) INTEGER PIVOT(N+1) C C ***** END OF DIMENSIONAL INFORMATION. ***** C C LAMBDA=Y(1) NP1=N+1 NP2=N+2 NFE=NFE+1 C NFE CONTAINS THE NUMBER OF JACOBIAN EVALUATIONS. C * * * * * * * * * * * * * * * * * C C COMPUTE THE JACOBIAN MATRIX, STORE IT AND HOMOTOPY MAP IN QR. C IF (IFLAG .EQ. -2) THEN C C QR = ( D RHO(A,LAMBDA,X)/D LAMBDA , D RHO(A,LAMBDA,X)/DX , C RHO(A,LAMBDA,X) ) . C DO 30 K=1,NP1 CALL RHOJAC(A,LAMBDA,Y(2),QR(1,K),K,PAR,IPAR) 30 CONTINUE CALL RHO(A,LAMBDA,Y(2),QR(1,NP2),PAR,IPAR) ELSE CALL F(Y(2),TZ) IF (IFLAG .EQ. 0) THEN C C QR = ( A - F(X), I - LAMBDA*DF(X) , C X - A + LAMBDA*(A - F(X)) ) . C DO 100 J=1,N SIGMA=A(J) BETA=SIGMA-TZ(J) QR(J,1)=BETA 100 QR(J,NP2)=Y(J+1)-SIGMA+LAMBDA*BETA DO 120 K=1,N CALL FJAC(Y(2),TZ,K) KP1=K+1 DO 110 J=1,N 110 QR(J,KP1)=-LAMBDA*TZ(J) 120 QR(K,KP1)=1.0+QR(K,KP1) ELSE C C QR = ( F(X) - X + A, LAMBDA*DF(X) + (1 - LAMBDA)*I , C X - A + LAMBDA*(F(X) - X + A) ) . C 140 DO 150 J=1,N SIGMA=Y(J+1)-A(J) BETA=TZ(J)-SIGMA QR(J,1)=BETA 150 QR(J,NP2)=SIGMA+LAMBDA*BETA DO 170 K=1,N CALL FJAC(Y(2),TZ,K) KP1=K+1 DO 160 J=1,N 160 QR(J,KP1)=LAMBDA*TZ(J) 170 QR(K,KP1)=1.0-LAMBDA+QR(K,KP1) ENDIF ENDIF C C * * * * * * * * * * * * * * * * * C COMPUTE THE NORM OF THE HOMOTOPY MAP IF IT WAS REQUESTED. IF (RHOLEN .LT. 0.0) RHOLEN=DNRM2(N,QR(1,NP2),1) C C REDUCE THE JACOBIAN MATRIX TO UPPER TRIANGULAR FORM. C C THE FOLLOWING CODE IS A MODIFICATION OF THE ALGOL PROCEDURE C DECOMPOSE IN P. BUSINGER AND G. H. GOLUB, LINEAR LEAST C SQUARES SOLUTIONS BY HOUSEHOLDER TRANSFORMATIONS, C NUMER. MATH. 7 (1965) 269-276. C DO 220 J=1,NP1 YP(J)=DDOT(N,QR(1,J),1,QR(1,J),1) 220 PIVOT(J)=J DO 300 K=1,N SIGMA=YP(K) JBAR=K KP1=K+1 DO 240 J=KP1,NP1 IF (SIGMA .GE. YP(J)) GO TO 240 SIGMA=YP(J) JBAR=J 240 CONTINUE IF (JBAR .EQ. K) GO TO 260 I=PIVOT(K) PIVOT(K)=PIVOT(JBAR) PIVOT(JBAR)=I YP(JBAR)=YP(K) YP(K)=SIGMA DO 250 I=1,N SIGMA=QR(I,K) QR(I,K)=QR(I,JBAR) QR(I,JBAR)=SIGMA 250 CONTINUE C END OF COLUMN INTERCHANGE. 260 SIGMA=DDOT(N-K+1,QR(K,K),1,QR(K,K),1) IF (SIGMA .EQ. 0.0) THEN IFLAG=4 RETURN ENDIF 270 IF (K .EQ. N) GO TO 300 QRKK=QR(K,K) ALPHAK=-SQRT(SIGMA) IF (QRKK .LT. 0.0) ALPHAK=-ALPHAK ALPHA(K)=ALPHAK BETA=1.0/(SIGMA-QRKK*ALPHAK) QR(K,K)=QRKK-ALPHAK DO 290 J=KP1,NP2 SIGMA=BETA*DDOT(N-K+1,QR(K,K),1,QR(K,J),1) DO 280 I=K,N QR(I,J)=QR(I,J)-QR(I,K)*SIGMA 280 CONTINUE IF (J .LT. NP2) YP(J)=YP(J)-QR(K,J)**2 290 CONTINUE 300 CONTINUE ALPHA(N)=QR(N,N) C C C COMPUTE KERNEL OF JACOBIAN, WHICH SPECIFIES YP=DY/DS. TZ(NP1)=1.0 DO 340 I=N,1,-1 SUM=0.0 DO 330 J=I+1,NP1 330 SUM=SUM+QR(I,J)*TZ(J) 340 TZ(I)=-SUM/ALPHA(I) YPNORM=DNRM2(NP1,TZ,1) DO 360 K=1,NP1 360 YP(PIVOT(K))=TZ(K)/YPNORM IF (DDOT(NP1,YP,1,YPOLD,1) .GE. 0.0) GO TO 380 DO 370 I=1,NP1 370 YP(I)=-YP(I) C YP IS THE UNIT TANGENT VECTOR IN THE CORRECT DIRECTION. C C COMPUTE THE MINIMUM NORM SOLUTION OF [D RHO(Y(S))] V = -RHO(Y(S)). C V IS GIVEN BY P - (P,Q)Q , WHERE P IS ANY SOLUTION OF C [D RHO] V = -RHO AND Q IS A UNIT VECTOR IN THE KERNEL OF [D RHO]. C 380 DO 440 I=N,1,-1 SUM=QR(I,NP1)+QR(I,NP2) DO 430 J=I+1,N 430 SUM=SUM+QR(I,J)*ALPHA(J) 440 ALPHA(I)=-SUM/ALPHA(I) DO 450 K=1,N 450 TZ(PIVOT(K))=ALPHA(K) TZ(PIVOT(NP1))=1.0 C TZ NOW CONTAINS A PARTICULAR SOLUTION P, AND YP CONTAINS A VECTOR Q C IN THE KERNEL(THE TANGENT). SIGMA=DDOT(NP1,TZ,1,YP,1) DO 470 J=1,NP1 TZ(J)=TZ(J)-SIGMA*YP(J) 470 CONTINUE C TZ IS THE NEWTON STEP FROM THE CURRENT POINT Y(S) = (LAMBDA(S), X(S)). RETURN END SUBROUTINE TANGNS(RHOLEN,Y,YP,TZ,YPOLD,A,QR,LENQR,PIVOT, $ PP,RHOVEC,WORK,NFE,N,IFLAG,PAR,IPAR) C C THIS SUBROUTINE BUILDS THE JACOBIAN MATRIX OF THE HOMOTOPY MAP, C AND THEN CALCULATES THE (UNIT) TANGENT VECTOR AND THE NEWTON STEP C USING A PRECONDITIONED CONJUGATE GRADIENT ALGORITHM. C C ON INPUT: C C RHOLEN < 0 IF THE NORM OF THE HOMOTOPY MAP EVALUATED AT C (A, X, LAMBDA) IS TO BE COMPUTED. IF RHOLEN >= 0 THE NORM IS NOT C COMPUTED AND RHOLEN IS NOT CHANGED. C C Y(1:N+1) = CURRENT POINT (X(S), LAMBDA(S)). C C YPOLD(1:N+1) = UNIT TANGENT VECTOR AT PREVIOUS POINT ON THE ZERO C CURVE OF THE HOMOTOPY MAP. C C A(1:*) = PARAMETER VECTOR IN THE HOMOTOPY MAP. C C QR(1:LENQR), PIVOT(1:N+2), PP(1:N), RHOVEC(1:N), WORK(1:8*(N+1)+LENQR) C ARE WORK ARRAYS USED FOR THE JACOBIAN MATRIX AND CONJUGATE GRADIENT C ITERATION. C C LENQR = LENGTH OF THE ONE-DIMENSIONAL ARRAY QR USED TO CONTAIN THE C N X N SYMMETRIC JACOBIAN MATRIX WITH RESPECT TO X IN PACKED SKYLINE C STORAGE FORMAT. C C NFE = NUMBER OF JACOBIAN MATRIX EVALUATIONS = NUMBER OF HOMOTOPY C FUNCTION EVALUATIONS. C C N = DIMENSION OF X. C C IFLAG = -2, -1, OR 0, INDICATING THE PROBLEM TYPE. C C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS, C WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES C RHO, RHOJS. C C ON OUTPUT: C C RHOLEN = ||RHO(A, X(S), LAMBDA(S)|| IF RHOLEN < 0 ON INPUT. C OTHERWISE RHOLEN IS UNCHANGED. C C Y, YPOLD, A, N ARE UNCHANGED. C C YP(1:N+1) = DY/DS = UNIT TANGENT VECTOR TO INTEGRAL CURVE OF C D(HOMOTOPY MAP)/DS = 0 AT Y(S) = (X(S), LAMBDA(S)) . C C TZ(1:N+1) = THE NEWTON STEP = -(PSEUDO INVERSE OF (D RHO(A,Y(S))/DX , C D RHO(A,Y(S))/D LAMBDA)) * RHO(A,Y(S)) . C C NFE HAS BEEN INCRMENTED BY 1. C C IFLAG IS UNCHANGED, UNLESS THE PRECONDITIONED CONJUGATE GRADIENT C ITERATION FAILS TO CONVERGE, IN WHICH CASE THE TANGENT AND NEWTON C STEP VECTORS ARE NOT COMPUTED AND TANGNS RETURNS WITH IFLAG = 4 C C C CALLS F (OR RHO ), FJACS (OR RHOJS ), PCGDS , PCGNS , AND THE BLAS C ROUTINES DAXPY , DCOPY , DDOT , DNRM2 , DSCAL . C DOUBLE PRECISION DDOT,DNRM2,LAMBDA,RHOLEN,SIGMA,YPNORM INTEGER IFLAG,J,LENQR,N,NFE,NP1,NP2,N2P3,N3P4,N4P5 C C ***** ARRAY DECLARATIONS. ***** C DOUBLE PRECISION Y(N+1),YP(N+1),TZ(N+1),YPOLD(N+1),A(N),PAR(1) INTEGER IPAR(1) C C ARRAYS FOR COMPUTING THE JACOBIAN MATRIX AND ITS KERNEL. DOUBLE PRECISION QR(LENQR),PP(N),RHOVEC(N), $ WORK(8*(N+1)+LENQR) INTEGER PIVOT(N+2) C C ***** END OF DIMENSIONAL INFORMATION. ***** C C NP1=N+1 NP2=N+2 N2P3=2*N+3 N3P4=3*N+4 N4P5=4*N+5 NFE=NFE+1 C NFE CONTAINS THE NUMBER OF JACOBIAN EVALUATIONS. C * * * * * * * * * * * * * * * * * C C COMPUTE THE JACOBIAN MATRIX, STORE IT IN [QR | -PP] . C LAMBDA=Y(NP1) IF (IFLAG .EQ. -2) THEN C C [QR | -PP] = ( D RHO(A,X,LAMBDA)/DX , D RHO(A,X,LAMBDA)/D LAMBDA ) , C RHOVEC = RHO(A,X,LAMBDA) . C CALL RHOJS(A,LAMBDA,Y,QR,LENQR,PIVOT,PP,PAR,IPAR) CALL RHO(A,LAMBDA,Y,RHOVEC,PAR,IPAR) ELSE CALL F(Y,PP) CALL DCOPY(N,Y,1,RHOVEC,1) CALL DAXPY(N,-1.0D0,A,1,RHOVEC,1) IF (IFLAG .EQ. 0) THEN C C [QR | -PP] = ( I - LAMBDA*DF(X) , A - F(X) ) , C RHOVEC = X - A + LAMBDA*(A - F(X)) . C CALL DAXPY(N,-1.0D0,A,1,PP,1) CALL FJACS(Y,QR,LENQR,PIVOT) CALL DSCAL(LENQR,-LAMBDA,QR,1) DO 120 J=1,N QR(PIVOT(J))=QR(PIVOT(J)) + 1.0 120 CONTINUE CALL DAXPY(N,-LAMBDA,PP,1,RHOVEC,1) ELSE C C [QR | -PP] = ( LAMBDA*DF(X) + (1 - LAMBDA)*I , F(X) - X + A ) , C RHOVEC = X - A + LAMBDA*(F(X) - X + A) . C CALL DSCAL(N,-1.0D0,PP,1) CALL DAXPY(N,1.0D0,RHOVEC,1,PP,1) CALL FJACS(Y,QR,LENQR,PIVOT) CALL DSCAL(LENQR,LAMBDA,QR,1) SIGMA=1.0 - LAMBDA DO 170 J=1,N QR(PIVOT(J))=QR(PIVOT(J)) + SIGMA 170 CONTINUE CALL DAXPY(N,-LAMBDA,PP,1,RHOVEC,1) ENDIF ENDIF C C * * * * * * * * * * * * * * * * * C COMPUTE THE NORM OF THE HOMOTOPY MAP IF IT WAS REQUESTED. IF (RHOLEN .LT. 0.0) RHOLEN=DNRM2(N,RHOVEC,1) C C COMPUTE KERNEL OF JACOBIAN, WHICH SPECIFIES YP=DY/DS, BY A C PRECONDITIONED CONJUGATE GRADIENT ALGORITHM. THIS IS DONE BY SOLVING C SEVERAL AUXILLARY SYSTEMS, WHOSE PREVIOUS SOLUTIONS HAVE BEEN LEFT IN C WORK(1:N+1) AND WORK(N+2:2*N+2). CALL DCOPY(2*NP1,WORK,1,WORK(N3P4),1) CALL DCOPY(NP1,YPOLD,1,YP,1) CALL PCGDS(N,QR,LENQR,PIVOT,PP,YP,WORK(N2P3),IFLAG) IF (IFLAG .GT. 0) RETURN CALL DCOPY(2*NP1,WORK(N3P4),1,WORK,1) YPNORM=DNRM2(NP1,YP,1) CALL DSCAL(NP1,1.0/YPNORM,YP,1) IF (DDOT(NP1,YP,1,YPOLD,1) .LT. 0.0) $ CALL DSCAL(NP1,-1.0D0,YP,1) C YP IS THE UNIT TANGENT VECTOR IN THE CORRECT DIRECTION. C C COMPUTE THE MINIMUM NORM SOLUTION OF [D RHO(Y(S))] V = -RHO(Y(S)). C V IS GIVEN BY P - (P,Q)Q , WHERE P IS ANY SOLUTION OF C [D RHO] V = -RHO AND Q IS A UNIT VECTOR IN THE KERNEL OF [D RHO]. C CALL DSCAL(2*NP1,0.0D0,WORK(N3P4),1) CALL DCOPY(NP1,YPOLD,1,TZ,1) CALL PCGNS(N,QR,LENQR,PIVOT,PP,RHOVEC,TZ,WORK(N2P3),IFLAG) IF (IFLAG .GT. 0) RETURN C TZ NOW CONTAINS A PARTICULAR SOLUTION P, AND YP CONTAINS A VECTOR Q C IN THE KERNEL(THE TANGENT). SIGMA=DDOT(NP1,TZ,1,YP,1) CALL DAXPY(NP1,-SIGMA,YP,1,TZ,1) C C TZ IS THE NEWTON STEP FROM THE CURRENT POINT Y(S) = (X(S), LAMBDA(S)). C RETURN END SUBROUTINE TANGQF(Y,YP,YPOLD,A,QT,R,W,S,T,N,IFLAG,NFE,PAR,IPAR) C C SUBROUTINE TANGQF COMPUTES THE UNIT TANGENT VECTOR YP TO THE C ZERO CURVE OF THE HOMOTOPY MAP AT Y BY GENERATING THE AUGMENTED C JACOBIAN MATRIX C C -- -- C | D(RHO(Y)) | C AUG = | T |, WHERE RHO IS THE HOMOTOPY MAP, C | YPOLD | C -- -- C C SOLVING THE SYSTEM C T C AUG*YPT = (0,0,...,0,1) FOR YPT, C C AND FINALLY COMPUTING YP = YPT/||YPT||. C C IN ADDITION, THE MATRIX AUG IS UPDATED SO THAT THE LAST ROW IS C YP INSTEAD OF YPOLD ON RETURN. C C C ON INPUT: C C Y(1:N+1) = CURRENT POINT (LAMBDA(S), X(S)). C C YP(1:N+1) IS UNDEFINED ON INPUT. C C YPOLD(1:N+1) = UNIT TANGENT VECTOR AT THE PREVIOUS POINT ON THE C ZERO CURVE OF THE HOMOTOPY MAP. C C A(1:N) IS THE PARAMETER VECTOR IN THE HOMOTOPY MAP. C C W(1:N+1), S(1:N+1), T(1:N+1) ARE WORK ARRAYS. C C N IS THE DIMENSION OF X, WHERE Y=(LAMBDA(S),X(S)). C C IFLAG IS -2, -1, OR 0, INDICATING THE PROBLEM TYPE. C C NFE IS THE NUMBER OF JACOBIAN EVALUATIONS. C C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS, C WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES C RHO, RHOJAC. C C C ON OUTPUT: C C Y, YPOLD, A, N ARE UNCHANGED. C C YP(1:N+1) CONTAINS THE NEW UNIT TANGENT VECTOR TO THE ZERO C CURVE OF THE HOMOTOPY MAP AT Y(S) = (LAMBDA(S), X(S)). C C QT(1:N+1,1:N+1) CONTAINS Q TRANSPOSE OF THE QR FACTORIZATION OF C THE JACOBIAN MATRIX OF RHO EVALUATED AT Y AUGMENTED BY C YP TRANSPOSE. C C R(1:(N+1)*(N+2)/2) CONTAINS THE UPPER TRIANGLE (STORED BY ROWS) C OF THE R PART OF THE QR FACTORIZATION OF THE AUGMENTED JACOBIAN C MATRIX. C C IFLAG = -2, -1, OR 0, (UNCHANGED) ON A NORMAL RETURN. C = 4 IF THE AUGMENTED JACOBIAN MATRIX HAS RANK LESS THAN N+1. C C NFE HAS BEEN INCREMENTED BY 1. C C C CALLS DCOPY, DNRM2, DSCAL, F (OR RHO IF IFLAG = -2), FJAC C (OR RHOJAC, IF IFLAG = -2), R1UPQF (WHICH IS AN ENTRY POINT OF C UPQRQF), QRFAQF, QRSLQF. C C ***** DECLARATIONS ***** C C FUNCTION DECLARATIONS C DOUBLE PRECISION DNRM2 C C LOCAL VARIABLES C DOUBLE PRECISION LAMBDA, ONE, YPNRM INTEGER I, J, JP1, NP1 C C SCALAR ARGUMENTS C INTEGER N, IFLAG, NFE C C ARRAY DECLARATIONS C DOUBLE PRECISION Y(N+1), YP(N+1), YPOLD(N+1), A(N), $ QT(N+1,N+1), R((N+1)*(N+2)/2), W(N+1), S(N+1), T(N+1),PAR(1) INTEGER IPAR(1) C C ***** END OF DECLARATIONS ***** C C ***** FIRST EXECUTABLE STATEMENT ***** C ONE = 1.0 NFE = NFE + 1 NP1 = N + 1 LAMBDA = Y(1) C C ***** DEFINE THE AUGMENTED JACOBIAN MATRIX ***** C C QT = AUG. C IF (IFLAG .EQ. -2) THEN C C CURVE TRACKING PROBLEM: C D(RHO) = (D RHO(A,LAMBDA,X)/D LAMBDA, D RHO(A,LAMBDA,X)/DX). C DO 10 J = 1,NP1 CALL RHOJAC(A,LAMBDA,Y(2),QT(1,J),J,PAR,IPAR) 10 CONTINUE ELSE IF (IFLAG .EQ. -1) THEN C C ZERO FINDING PROBLEM: C D(RHO) = (F(X) - X + A, LAMBDA*DF(X) + (1-LAMBDA)*I) C CALL F(Y(2),QT(1,1)) DO 20 I=1,N QT(I,1) = A(I) - Y(I+1) + QT(I,1) 20 CONTINUE DO 30 J= 1,N JP1 = J+1 CALL FJAC(Y(2),QT(1,JP1),J) CALL DSCAL(N,LAMBDA,QT(1,JP1),1) QT(J,JP1) = 1.0 - LAMBDA + QT(J,JP1) 30 CONTINUE ELSE C C FIXED POINT PROBLEM: C D(RHO) = (A - F(X), I - LAMBDA*DF(X)). C CALL F(Y(2),QT(1,1)) CALL DSCAL(N,-ONE,QT(1,1),1) CALL DAXPY(N,ONE,A,1,QT(1,1),1) DO 50 J=1,N JP1 = J+1 CALL FJAC(Y(2),QT(1,JP1),J) CALL DSCAL(N,-LAMBDA,QT(1,JP1),1) QT(J,JP1) = 1.0 + QT(J,JP1) 50 CONTINUE END IF C C DEFINE LAST ROW OF QT = YPOLD. C CALL DCOPY(NP1,YPOLD,1,QT(NP1,1),NP1) C C ***** END OF DEFINITION OF AUGMENTED JACOBIAN MATRIX ***** C C T C ***** SOLVE SYSTEM AUG*YPT = (0,...,0,1) ***** C C FACTOR MATRIX. C CALL QRFAQF(QT,R,NP1,IFLAG) C C IF MATRIX IS SINGULAR, THEN QUIT. C C IF (IFLAG .EQ. 4) RETURN C C ELSE SOLVE SYSTEM R*YP = QT*(0,...,0,1) FOR YP. C DO 70 J=1,N YP(J) = 0.0 70 CONTINUE YP(NP1) = 1.0 CALL QRSLQF(QT,R,YP,W,NP1) C C COMPUTE UNIT VECTOR. C YPNRM = 1.0/DNRM2(NP1,YP,1) CALL DSCAL(NP1,YPNRM,YP,1) C C ***** SYSTEM SOLVED ***** C C ***** UPDATE AUGMENTED SYSTEM SO THAT LAST ROW IS YP ***** C C S=YP-YPOLD, T = QT*E(NP1). C CALL DCOPY(NP1,YP,1,S,1) CALL DAXPY(NP1,-ONE,YPOLD,1,S,1) CALL DCOPY(NP1,QT(1,NP1),1,T,1) CALL R1UPQF(NP1,S,T,QT,R,W) C RETURN C C ***** END OF SUBROUTINE TANGQF ***** END SUBROUTINE TANGQS(Y,YP,YPOLD,A,QR,PIVOT,PP,RHOVEC,WORK,N,LENQR, $ IFLAG,NFE,PAR,IPAR) C C SUBROUTINE TANGQS COMPUTES THE UNIT TANGENT VECTOR YP TO THE C ZERO CURVE OF THE HOMOTOPY MAP AT Y BY GENERATING THE AUGMENTED C JACOBIAN MATRIX C C -- -- C | D(RHO(Y)) | C AUG = | T |, WHERE RHO IS THE HOMOTOPY MAP C | YPOLD | C -- -- C C SOLVING THE SYSTEM C T C AUG*YPT = (0,0,...,0,1) FOR YPT. C C AND FINALLY COMPUTING YP = YPT/||YPT||. C C C ON INPUT: C C Y(1:N+1) = CURRENT POINT (X(S), LAMBDA(S)). C C YP(1:N+1) IS UNDEFINED ON INPUT. C C YPOLD(1:N+1) = UNIT TANGENT VECTOR AT THE PREVIOUS POINT ON THE C ZERO CURVE OF THE HOMOTOPY MAP. C C A(1:N) IS THE PARAMETER VECTOR IN THE HOMOTOPY MAP. C C QR(1:LENQR) IS A WORK ARRAY CONTAINING THE N X N SYMMETRIC C JACOBIAN MATRIX WITH RESPECT TO X STORED IN PACKED SKYLINE C STORAGE FORMAT. LENQR AND PIVOT DESCRIBE THE DATA C STRUCTURE IN QR. (SEE SUBROUTINE PCGQS FOR A DESCRIPTION C OF THIS DATA STRUCTURE). C C PIVOT(1:N+2) IS A WORK ARRAY WHOSE FIRST N+1 COMPONENTS CONTAINI C THE INDICES OF THE DIAGONAL ELEMENTS OF THE N X N SYMMETRIC C JACOBIAN MATRIX (WITH RESPECT TO X) WITHIN QR. C C PP(1:N) IS A WORK ARRAY CONTAINING THE NEGATIVE OF THE LAST COLUMN C OF THE JACOBIAN MATRIX -[D RHO/D LAMBDA]. C C RHOVEC(1:N+1), IS A WORK ARRAY USED TO CALCULATE THE TANGENT C VECTOR. C C WORK(1:8*(N+1)+LENQR) IS A WORK ARRAY USED BY THE CONJUGATE GRADIENT C ALGORITHM TO SOLVE LINEAR SYSTEMS. C C N IS THE DIMENSION OF X, WHERE Y=(X(S),LAMBDA(S)). C C LENQR IS THE LENGTH OF THE ONE-DIMENSIONAL ARRAY QR. C C IFLAG IS -2, -1, OR 0, INDICATING THE PROBLEM TYPE. C C NFE IS THE NUMBER OF JACOBIAN EVALUATIONS. C C PAR(1:*) AND IPAR(1:*) ARE ARRAYS FOR (OPTIONAL) USER PARAMETERS, C WHICH ARE SIMPLY PASSED THROUGH TO THE USER WRITTEN SUBROUTINES C RHO, RHOJS. C C C ON OUTPUT: C C Y, YPOLD, A, N, LENQR ARE UNCHANGED. C C YP(1:N+1) CONTAINS THE NEW UNIT TANGENT VECTOR TO THE ZERO C CURVE OF THE HOMOTOPY MAP AT Y(S) = (X(S),LAMBDA(S)). C C IFLAG = -2, -1, OR 0, (UNCHANGED) ON A NORMAL RETURN. C = 4 IF THE AUGMENTED JACOBIAN MATRIX HAS RANK LESS THAN N+1. C C NFE HAS BEEN INCREMENTED BY 1. C C C CALLS DCOPY, DNRM2, DSCAL, F (OR RHO IF IFLAG = -2), FJACS C (OR RHOJS, IF IFLAG = -2), PCGQS. C C ***** DECLARATIONS ***** C C FUNCTION DECLARATIONS C DOUBLE PRECISION DNRM2 C C LOCAL VARIABLES C DOUBLE PRECISION LAMBDA, ONE, SIGMA, YPNRM INTEGER J, NP1, PCGWK, ZU C C SCALAR ARGUMENTS C INTEGER N, LENQR, IFLAG, NFE C C ARRAY DECLARATIONS C DOUBLE PRECISION Y(N+1), YP(N+1), YPOLD(N+1), A(N), $ QR(LENQR), PP(N), RHOVEC(N+1), WORK(8*(N+1)+LENQR),PAR(1) INTEGER PIVOT(N+2), IPAR(1) C C ***** END OF DECLARATIONS ***** C C ***** FIRST EXECUTABLE STATEMENT ***** C ONE = 1.0 NFE = NFE + 1 NP1 = N + 1 LAMBDA = Y(NP1) PCGWK = 2*N+3 ZU = 3*N+4 C C ***** DEFINE THE AUGMENTED JACOBIAN MATRIX ***** C C COMPUTE JACOBIAN MATRIX, STORE IT IN [QR|-PP]. C IF (IFLAG .EQ. -2) THEN C C CURVE TRACKING PROBLEM. C CALL RHOJS(A,LAMBDA,Y,QR,LENQR,PIVOT,PP,PAR,IPAR) ELSE IF (IFLAG .EQ. -1) THEN C C ZERO FINDING PROBLEM. C CALL F(Y,PP) CALL DSCAL(N,-ONE,PP,1) CALL DAXPY(N,ONE,Y,1,PP,1) CALL DAXPY(N,-ONE,A,1,PP,1) CALL FJACS(Y,QR,LENQR,PIVOT) CALL DSCAL(LENQR,LAMBDA,QR,1) SIGMA = 1.0-LAMBDA DO 10 J=1,N QR(PIVOT(J))=QR(PIVOT(J))+SIGMA 10 CONTINUE ELSE C C FIXED POINT PROBLEM C CALL F(Y,PP) CALL DAXPY(N,-ONE,A,1,PP,1) CALL FJACS(Y,QR,LENQR,PIVOT) CALL DSCAL(LENQR,-LAMBDA,QR,1) DO 20 J=1,N QR(PIVOT(J))=QR(PIVOT(J)) + 1.0 20 CONTINUE ENDIF C C ***** END OF DEFINITION OF AUGMENTED JACOBIAN MATRIX ***** C C T C ***** SOLVE SYSTEM AUG*YPT = (0,...,0,1) ***** C C INITIALIZE STARTING POINT FOR THE CONJUGATE GRADIENT ALGORITHM C TO BE THE SOLUTIONS FROM THE PREVIOUS CALL TO TANGQS. C CALL DCOPY(2*NP1,WORK,1,WORK(ZU),1) C C RHOVEC = -(0,...,0,1)**T C DO 30 J=1,N RHOVEC(J)=0.0 30 CONTINUE RHOVEC(NP1) = -1.0 C C SOLVE SYSTEM. C CALL PCGQS(N,QR,LENQR,PIVOT,PP,YPOLD,RHOVEC,YP,WORK(PCGWK), $ IFLAG) IF (IFLAG .GT. 0) RETURN C C NORMALIZE THE TANGENT. C YPNRM = 1.0/DNRM2(NP1,YP,1) CALL DSCAL(NP1,YPNRM,YP,1) C C SAVE SOLUTIONS FROM CONJUGATE GRADIENT ALGORITHM FOR NEXT CALL C TO TANGQS. C CALL DCOPY(2*NP1,WORK(ZU),1,WORK,1) C RETURN C C ***** END OF SUBROUTINE TANGQS ***** END SUBROUTINE UPQRQF(N,ETA,S,F0,F1,QT,R,W,T) C C SUBROUTINE UPQRQF PERFORMS A BROYDEN UPDATE ON THE Q R C FACTORIZATION OF A MATRIX A, (AN APPROXIMATION TO J(X0)), C RESULTING IN THE FACTORIZATION Q+ R+ OF C C A+ = A + (Y - A*S) (ST)/(ST * S), C C (AN APPROXIMATION TO J(X1)) C WHERE S = X1 - X0, ST = S TRANSPOSE, Y = F(X1) - F(X0). C C THE ENTRY POINT R1UPQF PERFORMS THE RANK ONE UPDATE ON THE QR C FACTORIZATION OF C C A+ = A + Q*(T*ST). C C C ON INPUT: C C N IS THE DIMENSION OF X AND F(X). C C ETA IS A NOISE PARAMETER. IF (Y-A*S)(I) .LE. ETA*(|F1(I)|+|F0(I)|) C FOR 1 .LE. I .LE. N, THEN NO UPDATE IS PERFORMED. C C S(1:N) = X1 - X0 (OR S FOR THE ENTRY POINT R1UPQF). C C F0(1:N) = F(X0). C C F1(1:N) = F(X1). C C QT(1:N,1:N) CONTAINS THE OLD Q TRANSPOSE, WHERE A = Q*R . C C R(1:N*(N+1)/2) CONTAINS THE OLD R, STORED BY ROWS. C C W(1:N), T(1:N) ARE WORK ARRAYS ( T CONTAINS THE VECTOR T FOR THE C ENTRY POINT R1UPQF ). C C C ON OUTPUT: C C N AND ETA ARE UNCHANGED. C C QT CONTAINS Q+ TRANSPOSE. C C R CONTAINS R+, STORED BY ROWS. C C S, F0, F1, W, AND T HAVE ALL BEEN CHANGED. C C C CALLS DAXPY, DDOT, AND DNRM2. C C ***** DECLARATIONS ***** C C FUNCTION DECLARATIONS C DOUBLE PRECISION DDOT, DNRM2 C C LOCAL VARIABLES C DOUBLE PRECISION C, DEN, ONE, SS, WW, YY INTEGER I, INDEXR, INDXR2, J, K LOGICAL SKIPUP C C SCALAR ARGUMENTS C DOUBLE PRECISION ETA INTEGER N C C ARRAY DECLARATIONS C DOUBLE PRECISION S(N), F0(N), F1(N), QT(N,N), R(N*(N+1)/2), $ W(N), T(N), TT(2) C C ***** END OF DECLARATIONS ***** C C ***** FIRST EXECUTABLE STATEMENT ***** C ONE = 1.0 SKIPUP = .TRUE. C C ***** DEFINE T AND S SUCH THAT ***** C C A+ = Q*(R + T*ST). C C T = R*S. C INDEXR = 1 DO 10 I=1,N T(I) = DDOT(N-I+1,R(INDEXR),1,S(I),1) INDEXR = INDEXR + N - I + 1 10 CONTINUE C C W = Y - Q*T = Y - A*S. C DO 20 I=1,N W(I) = F1(I) - F0(I) - DDOT(N,QT(1,I),1,T,1) C C IF W(I) IS NOT SMALL, THEN UPDATE MUST BE PERFORMED, C OTHERWISE SET W(I) TO 0. C IF (ABS(W(I)) .GT. ETA*(ABS(F1(I)) + ABS(F0(I)))) THEN SKIPUP = .FALSE. ELSE W(I) = 0.0 END IF 20 CONTINUE C C IF NO UPDATE IS NECESSARY, THEN RETURN. C IF (SKIPUP) RETURN C C T = QT*W = QT*Y - R*S. C DO 30 I=1,N T(I) = DDOT(N,QT(I,1),N,W,1) 30 CONTINUE C C S = S/(ST*S). C DEN = 1.0/DDOT(N,S,1,S,1) CALL DSCAL(N,DEN,S,1) C C ***** END OF COMPUTATION OF T & S ***** C AT THIS POINT, A+ = Q*(R + T*ST). C ENTRY R1UPQF(N,S,T,QT,R,W) C C ***** COMPUTE THE QR FACTORIZATION Q- R- OF (R + T*S). THEN, ***** C Q+ = Q*Q-, AND R+ = R-. C C FIND THE LARGEST K SUCH THAT T(K) .NE. 0. C K = N 50 IF (T(K) .NE. 0.0 .OR. K .LE. 1) GOTO 60 K=K-1 GOTO 50 60 CONTINUE C C COMPUTE THE INDEX OF R(K-1,K-1). C INDEXR = (N + N - K + 3)*(K - 2) / 2 + 1 C C ***** TRANSFORM R+T*ST INTO AN UPPER HESSENBERG MATRIX ***** C C DETERMINE JACOBI ROTATIONS WHICH WILL ZERO OUT ROWS C N, N-1,...,2 OF THE MATRIX T*ST, AND APPLY THESE C ROTATIONS TO R. (THIS IS EQUIVALENT TO APPLYING THE C SAME ROTATIONS TO R+T*ST, EXCEPT FOR THE FIRST ROW. C THUS, AFTER AN ADJUSTMENT FOR THE FIRST ROW, THE C RESULT IS AN UPPER HESSENBERG MATRIX. THE C SUBDIAGONAL ELEMENTS OF WHICH WILL BE STORED IN W. C C NOTE: ROWS N,N-1,...,K+1 ARE ALREADY ALL ZERO. C DO 90 I=K-1,1,-1 C C DETERMINE THE JACOBI ROTATION WHICH WILL ZERO OUT C ROW I+1 OF THE T*ST MATRIX. C IF (T(I) .EQ. 0.0) THEN C = 0.0 C SS = SIGN(-T(I+1))= -T(I+1)/|T(I+1)| SS = -SIGN(ONE,T(I+1)) ELSE DEN = DNRM2(2,T(I),1) C = T(I) / DEN SS = -T(I+1)/DEN END IF C C PREMULTIPLY R BY THE JACOBI ROTATION. C YY = R(INDEXR) WW = 0.0 R(INDEXR) = C*YY - SS*WW W(I+1) = SS*YY + C*WW INDEXR = INDEXR + 1 INDXR2 = INDEXR + N - I DO 70 J= I+1,N C YY = R(I,J) C WW = R(I+1,J) YY = R(INDEXR) WW = R(INDXR2) C R(I,J) = C*YY - SS*WW C R(I+1,J) = SS*YY + C*WW R(INDEXR) = C*YY - SS*WW R(INDXR2) = SS*YY + C*WW INDEXR = INDEXR + 1 INDXR2 = INDXR2 + 1 70 CONTINUE C C PREMULTIPLY QT BY THE JACOBI ROTATION. C DO 80 J=1,N YY = QT(I,J) WW = QT(I+1,J) QT(I,J) = C*YY - SS*WW QT(I+1,J) = SS*YY + C*WW 80 CONTINUE C C UPDATE T(I) SO THAT T(I)*ST(J) IS THE (I,J)TH COMPONENT C OF T*ST, PREMULTIPLIED BY ALL OF THE JACOBI ROTATIONS SO C FAR. C IF (T(I) .EQ. 0.0) THEN T(I) = ABS(T(I+1)) ELSE T(I) = DNRM2(2,T(I),1) END IF C C LET INDEXR = THE INDEX OF R(I-1,I-1). C INDEXR = INDEXR - 2*(N - I) - 3 C 90 CONTINUE C C UPDATE THE FIRST ROW OF R SO THAT R HOLDS (R+T*ST) C PREMULTIPLIED BY ALL OF THE ABOVE JACOBI ROTATIONS. C CALL DAXPY(N,T(1),S,1,R,1) C C ***** END OF TRANSFORMATION TO UPPER HESSENBERG ***** C C C ***** TRANSFORM UPPER HESSENBERG MATRIX INTO UPPER ***** C TRIANGULAR MATRIX. C C INDEXR = INDEX OF R(1,1). C INDEXR = 1 DO 120 I=1,K-1 C C DETERMINE APPROPRIATE JACOBI ROTATION TO ZERO OUT C R(I+1,I). C IF (R(INDEXR) .EQ. 0.0) THEN C = 0.0 SS = -SIGN(ONE,W(I+1)) ELSE TT(1) = R(INDEXR) TT(2) = W(I+1) DEN = DNRM2(2,TT,1) C = R(INDEXR) / DEN SS = -W(I+1)/DEN END IF C C PREMULTIPLY R BY JACOBI ROTATION. C YY = R(INDEXR) WW = W(I+1) R(INDEXR) = C*YY - SS*WW W(I+1) = 0.0 INDEXR = INDEXR + 1 INDXR2 = INDEXR + N - I DO 100 J= I+1,N C YY = R(I,J) C WW = R(I+1,J) YY = R(INDEXR) WW = R(INDXR2) C R(I,J) = C*YY -SS*WW C R(I+1,J) = SS*YY + C*WW R(INDEXR) = C*YY - SS*WW R(INDXR2) = SS*YY + C*WW INDEXR = INDEXR + 1 INDXR2 = INDXR2 + 1 100 CONTINUE C C PREMULTIPLY QT BY JACOBI ROTATION. C DO 110 J=1,N YY = QT(I,J) WW = QT(I+1,J) QT(I,J) = C*YY - SS*WW QT(I+1,J) = SS*YY + C*WW 110 CONTINUE 120 CONTINUE C C ***** END OF TRANSFORMATION TO UPPER TRIANGULAR ***** C C C ***** END OF UPDATE ***** C C RETURN C C ***** END OF SUBROUTINE UPQRQF ***** END 'TWO QUADRICS PBHP0403, NO SOLUTIONS AT INFINITY .............' 00001 IFLGHM 00001 IFLGSC 4 ITOTDG 1.D-04 EPSBIG 1.D-14 EPSSML 1.D-00 SSPAR(5) 00 NUMRR 2 N 00006 NUMTRM(1) 00002 DEG(1,1,1) 00000 DEG(1,2,1) -.00098D 00 00000 DEG(1,1,2) 00002 DEG(1,2,2) 978000.D 00 00001 DEG(1,1,3) 00001 DEG(1,2,3) -9.8D 00 00001 DEG(1,1,4) 00000 DEG(1,2,4) -235.0D 00 00000 DEG(1,1,5) 00001 DEG(1,2,5) 88900.0D 00 00000 DEG(1,1,6) 00000 DEG(1,2,6) -1.000D 00 00006 NUMTRM(2) 00002 DEG(2,1,1) 00000 DEG(2,2,1) -.0100D 00 00000 DEG(2,1,2) 00002 DEG(2,2,2) -.9840D 00 00001 DEG(2,1,3) 00001 DEG(2,2,3) -29.70D 00 00001 DEG(2,1,4) 00000 DEG(2,2,4) .00987D 00 00000 DEG(2,1,5) 00001 DEG(2,2,5) -.1240D 00 00000 DEG(2,1,6) 00000 DEG(2,2,6) -.2500D 00 SXXXXXXXXXXXXXXXX.DSYY #### OUTPUT FOLLOWS POLYS TEST ROUTINE 5/20/85 TWO QUADRICS PBHP0403, NO SOLUTIONS AT INFINITY ......... IF IFLGHM=1,HOMOGENEOUS;IF IFLGHM=2,INHOMOGENEOUS;IFLGHM= 1 IF IFLGSC=1,SCLGEN USED; IF IFLGSC=2, NO SCALING; IFLGSC= 1 ITOTDG= 4 EPSBIG,EPSSML = 0.100000000000000D-03 0.100000000000000D-13 NUMBER OF EQUATIONS = 2 NUMBER OF RECALLS WHEN IFLAG=3: 40 ****** COEFFICIENT TABLEAU ****** NUMT( 1)= 6 KDEG( 1, 1, 1)= 2 KDEG( 1, 2, 1)= 0 COEF( 1, 1)=-0.980000000000000D-03 KDEG( 1, 1, 2)= 0 KDEG( 1, 2, 2)= 2 COEF( 1, 2)= 0.978000000000000D+06 KDEG( 1, 1, 3)= 1 KDEG( 1, 2, 3)= 1 COEF( 1, 3)=-0.980000000000000D+01 KDEG( 1, 1, 4)= 1 KDEG( 1, 2, 4)= 0 COEF( 1, 4)=-0.235000000000000D+03 KDEG( 1, 1, 5)= 0 KDEG( 1, 2, 5)= 1 COEF( 1, 5)= 0.889000000000000D+05 KDEG( 1, 1, 6)= 0 KDEG( 1, 2, 6)= 0 COEF( 1, 6)=-0.100000000000000D+01 NUMT( 2)= 6 KDEG( 2, 1, 1)= 2 KDEG( 2, 2, 1)= 0 COEF( 2, 1)=-0.100000000000000D-01 KDEG( 2, 1, 2)= 0 KDEG( 2, 2, 2)= 2 COEF( 2, 2)=-0.984000000000000D+00 KDEG( 2, 1, 3)= 1 KDEG( 2, 2, 3)= 1 COEF( 2, 3)=-0.297000000000000D+02 KDEG( 2, 1, 4)= 1 KDEG( 2, 2, 4)= 0 COEF( 2, 4)= 0.987000000000000D-02 KDEG( 2, 1, 5)= 0 KDEG( 2, 2, 5)= 1 COEF( 2, 5)=-0.124000000000000D+00 KDEG( 2, 1, 6)= 0 KDEG( 2, 2, 6)= 0 COEF( 2, 6)=-0.250000000000000D+00 PATH NUMBER = 1 FINAL VALUES FOR PATH ARCLEN = 0.100553311312353D+02 NFE = 53 IFLG2 = 1 T = 0.100000000000000D+01 X = 0.234233851959126D+04 0.791152831437911D-11 X =-0.788344824094138D+00-0.268347762088076D-14 X =-0.949359459408658D-02-0.106447550900261D-02 X = PATH NUMBER = 2 FINAL VALUES FOR PATH ARCLEN = 0.172112868960496D+01 NFE = 37 IFLG2 = 1 T = 0.100000000000000D+01 X = 0.161478579234367D-01 0.168496955498881D+01 X = 0.267994739614462D-03 0.442802993973661D-02 X =-0.381948972942403D+00 0.372068943457283D+00 X = PATH NUMBER = 3 FINAL VALUES FOR PATH ARCLEN = 0.202329539135269D+01 NFE = 35 IFLG2 = 1 T = 0.100000000000000D+01 X = 0.161478579234362D-01-0.168496955498881D+01 X = 0.267994739614461D-03-0.442802993973661D-02 X =-0.329370493847660D+00 0.556619775523013D+00 X = PATH NUMBER = 4 FINAL VALUES FOR PATH ARCLEN = 0.416327291917901D+01 NFE = 46 IFLG2 = 1 T = 0.100000000000000D+01 X = 0.908921229615394D-01-0.111985846294633D-14 X =-0.911497098197500D-01 0.117962440099502D-17 X =-0.573673395727962D-01 0.136243663709219D+00 X = TOTAL NFE OVER ALL PATHS = 171 0 MESSAGE SUMMARY: MESSAGE NUMBER - COUNT 0 208 70