#! /bin/sh # This is a shell archive. Remove anything before this line, then unpack # it by saving it into a file and typing "sh file". To overwrite existing # files, type "sh file -c". You can also feed this as standard input via # unshar, or by typing "sh 'README' <<'END_OF_FILE' XSince some compiler optimizations cause MACHAR to misbehave, XI've replaced the call on MACHAR in setup.f with corresponding Xcalls on PORT routines I1MACH and D1MACH, which now adapt Xthemselves automatically to most currently used machines. XThe original setup.f is now setup.f0, and the original machar.f Xis now machar.f0. X XAs of this writing, we do not know how to contact Rod Bain, the Xauthor of NNES. X X-- David M. Gay (dmg@bell-labs.com) X Bell Labs, Murray Hill X 8 February 1999 END_OF_FILE if test 485 -ne `wc -c <'README'`; then echo shar: \"'README'\" unpacked with wrong size! fi # end of 'README' fi if test -f 'abmul.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'abmul.f'\" else echo shar: Extracting \"'abmul.f'\" \(7666 characters\) sed "s/^X//" >'abmul.f' <<'END_OF_FILE' X SUBROUTINE ABMUL(NRADEC,NRAACT,NCBDEC,NCBACT,NCDEC ,NCACT , X $ AMAT ,BMAT ,CMAT ,AROW) XC XC FEB. 8, 1991 XC XC MATRIX MULTIPLICATION AB=C XC XC VERSION WITH INNER LOOP UNROLLED TO DEPTHS 32, 16, 8 AND 4 XC EACH ROW OF MATRIX A IS SAVED AS A COLUMN, AROW, BEFORE USE. XC XC NRADEC IS 1ST DIM. OF AMAT; NRAACT IS ACTUAL LIMIT FOR 1ST INDEX XC NCBDEC IS 2ND DIM. OF BMAT; NCBACT IS ACTUAL LIMIT FOR 2ND INDEX XC NCDEC IS COMMON DIMENSION OF AMAT & BMAT; NCACT IS ACTUAL LIMIT XC XC I.E. NRADEC IS THE NUMBER OF ROWS OF A DECLARED XC NCBDEC IS THE NUMBER OF COLUMNS OF B DECLARED XC NCDEC IS THE COMMON DECLARED DIMENSION XC XC MODIFICATION OF MATRIX MULTIPLIER DONATED BY PROF. JAMES XC MACKINNON, QUEEN'S UNIVERSITY, KINGSTON, ONTARIO, CANADA XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DIMENSION AMAT(NRADEC,NCDEC) ,BMAT(NCDEC,NCBDEC), X $ CMAT(NRADEC,NCBDEC) ,AROW(NCDEC) X DATA ZERO /0.0D0/ XC XC FIND NUMBER OF GROUPS OF SIZE 32, 16 ... XC X NCC32=NCACT/32 X NCC32R=NCACT-32*NCC32 X NCC16=NCC32R/16 X NCC16R=NCC32R-16*NCC16 X NCC8=NCC16R/8 X NCC8R=NCC16R-8*NCC8 X NCC4=NCC8R/4 X NCC4R=NCC8R-4*NCC4 XC XC REASSIGN ROWS TO VECTOR AROW. XC X DO 100 I=1,NRAACT X K=0 X IF(NCC32.GT.0) THEN X DO 200 KK=1,NCC32 X K=K+32 X AROW(K-31)=AMAT(I,K-31) X AROW(K-30)=AMAT(I,K-30) X AROW(K-29)=AMAT(I,K-29) X AROW(K-28)=AMAT(I,K-28) X AROW(K-27)=AMAT(I,K-27) X AROW(K-26)=AMAT(I,K-26) X AROW(K-25)=AMAT(I,K-25) X AROW(K-24)=AMAT(I,K-24) X AROW(K-23)=AMAT(I,K-23) X AROW(K-22)=AMAT(I,K-22) X AROW(K-21)=AMAT(I,K-21) X AROW(K-20)=AMAT(I,K-20) X AROW(K-19)=AMAT(I,K-19) X AROW(K-18)=AMAT(I,K-18) X AROW(K-17)=AMAT(I,K-17) X AROW(K-16)=AMAT(I,K-16) X AROW(K-15)=AMAT(I,K-15) X AROW(K-14)=AMAT(I,K-14) X AROW(K-13)=AMAT(I,K-13) X AROW(K-12)=AMAT(I,K-12) X AROW(K-11)=AMAT(I,K-11) X AROW(K-10)=AMAT(I,K-10) X AROW(K-9)=AMAT(I,K-9) X AROW(K-8)=AMAT(I,K-8) X AROW(K-7)=AMAT(I,K-7) X AROW(K-6)=AMAT(I,K-6) X AROW(K-5)=AMAT(I,K-5) X AROW(K-4)=AMAT(I,K-4) X AROW(K-3)=AMAT(I,K-3) X AROW(K-2)=AMAT(I,K-2) X AROW(K-1)=AMAT(I,K-1) X AROW(K)=AMAT(I,K) X200 CONTINUE X END IF X IF(NCC16.GT.0) THEN X DO 300 KK=1,NCC16 X K=K+16 X AROW(K-15)=AMAT(I,K-15) X AROW(K-14)=AMAT(I,K-14) X AROW(K-13)=AMAT(I,K-13) X AROW(K-12)=AMAT(I,K-12) X AROW(K-11)=AMAT(I,K-11) X AROW(K-10)=AMAT(I,K-10) X AROW(K-9)=AMAT(I,K-9) X AROW(K-8)=AMAT(I,K-8) X AROW(K-7)=AMAT(I,K-7) X AROW(K-6)=AMAT(I,K-6) X AROW(K-5)=AMAT(I,K-5) X AROW(K-4)=AMAT(I,K-4) X AROW(K-3)=AMAT(I,K-3) X AROW(K-2)=AMAT(I,K-2) X AROW(K-1)=AMAT(I,K-1) X AROW(K)=AMAT(I,K) X300 CONTINUE X END IF X IF(NCC8.GT.0) THEN X DO 400 KK=1,NCC8 X K=K+8 X AROW(K-7)=AMAT(I,K-7) X AROW(K-6)=AMAT(I,K-6) X AROW(K-5)=AMAT(I,K-5) X AROW(K-4)=AMAT(I,K-4) X AROW(K-3)=AMAT(I,K-3) X AROW(K-2)=AMAT(I,K-2) X AROW(K-1)=AMAT(I,K-1) X AROW(K)=AMAT(I,K) X400 CONTINUE X END IF X IF(NCC4.GT.0) THEN X DO 500 KK=1,NCC4 X K=K+4 X AROW(K-3)=AMAT(I,K-3) X AROW(K-2)=AMAT(I,K-2) X AROW(K-1)=AMAT(I,K-1) X AROW(K)=AMAT(I,K) X500 CONTINUE X END IF X IF(NCC4R.GT.0) THEN X DO 600 KK=1,NCC4R X K=K+1 X AROW(K)=AMAT(I,K) X600 CONTINUE X END IF XC XC FIND ENTRY FOR MATRIX C USING COLUMN VECTOR AROW. XC X DO 700 J=1,NCBACT X SUM=ZERO X K=0 X IF(NCC32.GT.0) THEN X DO 800 KK=1,NCC32 X K=K+32 X SUM=SUM X $ +AROW(K-31)*BMAT(K-31,J)+AROW(K-30)*BMAT(K-30,J) X $ +AROW(K-29)*BMAT(K-29,J)+AROW(K-28)*BMAT(K-28,J) X $ +AROW(K-27)*BMAT(K-27,J)+AROW(K-26)*BMAT(K-26,J) X $ +AROW(K-25)*BMAT(K-25,J)+AROW(K-24)*BMAT(K-24,J) X SUM=SUM X $ +AROW(K-23)*BMAT(K-23,J)+AROW(K-22)*BMAT(K-22,J) X $ +AROW(K-21)*BMAT(K-21,J)+AROW(K-20)*BMAT(K-20,J) X $ +AROW(K-19)*BMAT(K-19,J)+AROW(K-18)*BMAT(K-18,J) X $ +AROW(K-17)*BMAT(K-17,J)+AROW(K-16)*BMAT(K-16,J) X SUM=SUM X $ +AROW(K-15)*BMAT(K-15,J)+AROW(K-14)*BMAT(K-14,J) X $ +AROW(K-13)*BMAT(K-13,J)+AROW(K-12)*BMAT(K-12,J) X $ +AROW(K-11)*BMAT(K-11,J)+AROW(K-10)*BMAT(K-10,J) X $ +AROW(K-9) *BMAT(K-9,J) +AROW(K-8) *BMAT(K-8,J) X SUM=SUM X $ +AROW(K-7)*BMAT(K-7,J)+AROW(K-6)*BMAT(K-6,J) X $ +AROW(K-5)*BMAT(K-5,J)+AROW(K-4)*BMAT(K-4,J) X $ +AROW(K-3)*BMAT(K-3,J)+AROW(K-2)*BMAT(K-2,J) X $ +AROW(K-1)*BMAT(K-1,J)+AROW(K) *BMAT(K,J) X800 CONTINUE X END IF X IF(NCC16.GT.0) THEN X DO 900 KK=1,NCC16 X K=K+16 X SUM=SUM X $ +AROW(K-15)*BMAT(K-15,J)+AROW(K-14)*BMAT(K-14,J) X $ +AROW(K-13)*BMAT(K-13,J)+AROW(K-12)*BMAT(K-12,J) X $ +AROW(K-11)*BMAT(K-11,J)+AROW(K-10)*BMAT(K-10,J) X $ +AROW(K-9) *BMAT(K-9,J) +AROW(K-8) *BMAT(K-8,J) X SUM=SUM X $ +AROW(K-7)*BMAT(K-7,J)+AROW(K-6)*BMAT(K-6,J) X $ +AROW(K-5)*BMAT(K-5,J)+AROW(K-4)*BMAT(K-4,J) X $ +AROW(K-3)*BMAT(K-3,J)+AROW(K-2)*BMAT(K-2,J) X $ +AROW(K-1)*BMAT(K-1,J)+AROW(K) *BMAT(K,J) X900 CONTINUE X END IF X IF(NCC8.GT.0) THEN X DO 1000 KK=1,NCC8 X K=K+8 X SUM=SUM X $ +AROW(K-7)*BMAT(K-7,J)+AROW(K-6)*BMAT(K-6,J) X $ +AROW(K-5)*BMAT(K-5,J)+AROW(K-4)*BMAT(K-4,J) X $ +AROW(K-3)*BMAT(K-3,J)+AROW(K-2)*BMAT(K-2,J) X $ +AROW(K-1)*BMAT(K-1,J)+AROW(K) *BMAT(K,J) X1000 CONTINUE X END IF X IF(NCC4.GT.0) THEN X DO 1100 KK=1,NCC4 X K=K+4 X SUM=SUM X $ +AROW(K-3)*BMAT(K-3,J)+AROW(K-2)*BMAT(K-2,J) X $ +AROW(K-1)*BMAT(K-1,J)+AROW(K) *BMAT(K,J) X1100 CONTINUE X END IF X IF(NCC4R.GT.0) THEN X DO 1200 KK=1,NCC4R X K=K+1 X SUM=SUM+AROW(K)*BMAT(K,J) X1200 CONTINUE X END IF X CMAT(I,J)=SUM X700 CONTINUE X100 CONTINUE X RETURN XC XC LAST CARD OF SUBROUTINE ABMUL. XC X END END_OF_FILE if test 7666 -ne `wc -c <'abmul.f'`; then echo shar: \"'abmul.f'\" unpacked with wrong size! fi # end of 'abmul.f' fi if test -f 'ascalf.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'ascalf.f'\" else echo shar: Extracting \"'ascalf.f'\" \(1363 characters\) sed "s/^X//" >'ascalf.f' <<'END_OF_FILE' X SUBROUTINE ASCALF(N,EPSMCH,FVECC,JAC,SCALEF) XC XC FEB. 13, 1991 XC XC THIS SUBROUTINE ESTABLISHES SCALING FACTORS FOR THE XC RESIDUAL VECTOR IF FUNCTION ADAPTIVE SCALING IS CHOSEN XC USING INTEGER VARIABLE ITSCLF. XC XC NOTE: IN QUASI-NEWTON METHODS THE SCALING FACTORS ARE XC UPDATED ONLY WHEN THE JACOBIAN IS EVALUATED EXPLI- XC CITLY. XC XC SCALING FACTORS ARE DETERMINED FROM THE INFINITY NORMS XC OF THE ROWS OF THE JACOBIAN AND THE VALUES OF THE CURRENT XC FUNCTION VECTOR, FVECC. XC XC A MINIMUM TOLERANCE ON THE SCALING FACTOR IS THE SQUARE XC ROOT OF THE MACHINE PRECISION, SQRTEP. XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION JAC(N,N) X DIMENSION FVECC(N) ,SCALEF(N) X DATA ZERO,ONE /0.0D0,1.0D0/ XC X SQRTEP=SQRT(EPSMCH) XC XC I COUNTS THE ROWS. XC X DO 100 I=1,N X AMAX=ZERO XC XC FIND MAXIMUM ENTRY IN ROW I. XC X DO 200 J=1,N X AMAX=MAX(AMAX,ABS(JAC(I,J))) X200 CONTINUE XC X AMAX=MAX(AMAX,FVECC(I)) XC XC SET SCALING FACTOR TO A DEFAULT OF ONE IF ITH ROW IS ZEROS. XC X IF(AMAX.EQ.ZERO) AMAX=ONE X AMAX=MAX(AMAX,SQRTEP) X SCALEF(I)=ONE/AMAX X100 CONTINUE X RETURN XC XC LAST CARD OF SUBROUTINE ASCALF. XC X END END_OF_FILE if test 1363 -ne `wc -c <'ascalf.f'`; then echo shar: \"'ascalf.f'\" unpacked with wrong size! fi # end of 'ascalf.f' fi if test -f 'ascalx.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'ascalx.f'\" else echo shar: Extracting \"'ascalx.f'\" \(1196 characters\) sed "s/^X//" >'ascalx.f' <<'END_OF_FILE' X SUBROUTINE ASCALX(N,EPSMCH,JAC,SCALEX) XC XC FEB. 13, 1991 XC XC THIS SUBROUTINE ESTABLISHES SCALING FACTORS FOR THE XC COMPONENET VECTOR IF ADAPTIVE SCALING IS CHOSEN USING XC INTEGER ITSCLX. XC XC NOTE: IN QUASI-NEWTON METHODS THE SCALING FACTORS ARE XC UPDATED ONLY WHEN THE JACOBIAN IS EVALUATED EXPLI- XC CITLY. XC XC SCALING FACTORS ARE DETERMINED FROM THE INFINITY NORMS XC OF THE COLUMNS OF THE JACOBIAN. XC XC A MINIMUM TOLERANCE ON THE SCALING FACTOR IS THE SQUARE XC ROOT OF THE MACHINE PRECISION, SQRTEP. XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION JAC(N,N) X DIMENSION SCALEX(N) X DATA ZERO,ONE /0.0D0,1.0D0/ XC X SQRTEP=SQRT(EPSMCH) XC XC J COUNTS COLUMNS. XC X DO 100 J=1,N X AMAX=ZERO XC XC FIND MAXIMUM ENTRY IN JTH COLUMN. XC X DO 200 I=1,N X AMAX=MAX(AMAX,ABS(JAC(I,J))) X200 CONTINUE XC XC IF A COLUMN IS ALL ZEROS SET AMAX TO ONE. XC X IF(AMAX.EQ.ZERO) AMAX=ONE X SCALEX(J)=MAX(AMAX,SQRTEP) X100 CONTINUE X RETURN XC XC LAST CARD OF SUBROUTINE ASCALX. XC X END END_OF_FILE if test 1196 -ne `wc -c <'ascalx.f'`; then echo shar: \"'ascalx.f'\" unpacked with wrong size! fi # end of 'ascalx.f' fi if test -f 'atamul.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'atamul.f'\" else echo shar: Extracting \"'atamul.f'\" \(4482 characters\) sed "s/^X//" >'atamul.f' <<'END_OF_FILE' X SUBROUTINE ATAMUL(NRADEC,NCADEC,NRAACT,NCAACT,NRBDEC,NCBDEC, X $ AMAT ,BMAT) XC XC FEB. 8, 1991 XC XC MATRIX MULTIPLICATION: A^A=B XC XC VERSION WITH INNER LOOP UNROLLED TO DEPTHS 32, 16, 8 AND 4. XC XC NRADEC IS NUMBER OF ROWS IN A DECLARED XC NCADEC IS NUMBER OF COLUMNS IN A DECLARED XC NRAACT IS THE LIMIT FOR THE 1ST INDEX IN A XC NCAACT IS THE LIMIT FOR THE 2ND INDEX IN A XC NRBDEC IS NUMBER OF ROWS IN B DECLARED XC NCBDEC IS NUMBER OF COLUMNS IN B DECLARED XC XC MODIFIED VERSION OF THE MATRIX MULTIPLIER DONATED BY PROF. JAMES XC MACKINNON, QUEEN'S UNIVERSITY, KINGSTON, ONTARIO, CANADA XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DIMENSION AMAT(NRADEC,NCADEC), BMAT(NRBDEC,NCBDEC) X DATA ZERO /0.0D0/ XC XC FIND NUMBER OF GROUPS OF SIZE 32, 16 ... XC X NCC32=NRAACT/32 X NCC32R=NRAACT-32*NCC32 X NCC16=NCC32R/16 X NCC16R=NCC32R-16*NCC16 X NCC8=NCC16R/8 X NCC8R=NCC16R-8*NCC8 X NCC4=NCC8R/4 X NCC4R=NCC8R-4*NCC4 XC XC FIND ENTRY IN MATRIX B. XC X DO 100 I=1,NCAACT X DO 200 J=I,NCAACT X SUM=ZERO X K=0 X IF(NCC32.GT.0) THEN X DO 300 KK=1,NCC32 X K=K+32 X SUM=SUM X $ +AMAT(K-31,I)*AMAT(K-31,J)+AMAT(K-30,I)*AMAT(K-30,J) X $ +AMAT(K-29,I)*AMAT(K-29,J)+AMAT(K-28,I)*AMAT(K-28,J) X $ +AMAT(K-27,I)*AMAT(K-27,J)+AMAT(K-26,I)*AMAT(K-26,J) X $ +AMAT(K-25,I)*AMAT(K-25,J)+AMAT(K-24,I)*AMAT(K-24,J) X SUM=SUM X $ +AMAT(K-23,I)*AMAT(K-23,J)+AMAT(K-22,I)*AMAT(K-22,J) X $ +AMAT(K-21,I)*AMAT(K-21,J)+AMAT(K-20,I)*AMAT(K-20,J) X $ +AMAT(K-19,I)*AMAT(K-19,J)+AMAT(K-18,I)*AMAT(K-18,J) X $ +AMAT(K-17,I)*AMAT(K-17,J)+AMAT(K-16,I)*AMAT(K-16,J) X SUM=SUM X $ +AMAT(K-15,I)*AMAT(K-15,J)+AMAT(K-14,I)*AMAT(K-14,J) X $ +AMAT(K-13,I)*AMAT(K-13,J)+AMAT(K-12,I)*AMAT(K-12,J) X $ +AMAT(K-11,I)*AMAT(K-11,J)+AMAT(K-10,I)*AMAT(K-10,J) X $ +AMAT(K-9,I)*AMAT(K-9,J) +AMAT(K-8,I)*AMAT(K-8,J) X SUM=SUM X $ +AMAT(K-7,I)*AMAT(K-7,J)+AMAT(K-6,I)*AMAT(K-6,J) X $ +AMAT(K-5,I)*AMAT(K-5,J)+AMAT(K-4,I)*AMAT(K-4,J) X $ +AMAT(K-3,I)*AMAT(K-3,J)+AMAT(K-2,I)*AMAT(K-2,J) X $ +AMAT(K-1,I)*AMAT(K-1,J)+AMAT(K,I) *AMAT(K,J) X300 CONTINUE X END IF X IF(NCC16.GT.0) THEN X DO 400 KK=1,NCC16 X K=K+16 X SUM=SUM X $ +AMAT(K-15,I)*AMAT(K-15,J)+AMAT(K-14,I)*AMAT(K-14,J) X $ +AMAT(K-13,I)*AMAT(K-13,J)+AMAT(K-12,I)*AMAT(K-12,J) X $ +AMAT(K-11,I)*AMAT(K-11,J)+AMAT(K-10,I)*AMAT(K-10,J) X $ +AMAT(K-9,I)*AMAT(K-9,J) +AMAT(K-8,I) *AMAT(K-8,J) X SUM=SUM X $ +AMAT(K-7,I)*AMAT(K-7,J)+AMAT(K-6,I)*AMAT(K-6,J) X $ +AMAT(K-5,I)*AMAT(K-5,J)+AMAT(K-4,I)*AMAT(K-4,J) X $ +AMAT(K-3,I)*AMAT(K-3,J)+AMAT(K-2,I)*AMAT(K-2,J) X $ +AMAT(K-1,I)*AMAT(K-1,J)+AMAT(K,I)*AMAT(K,J) X400 CONTINUE X END IF X IF(NCC8.GT.0) THEN X DO 500 KK=1,NCC8 X K=K+8 X SUM=SUM X $ +AMAT(K-7,I)*AMAT(K-7,J)+AMAT(K-6,I)*AMAT(K-6,J) X $ +AMAT(K-5,I)*AMAT(K-5,J)+AMAT(K-4,I)*AMAT(K-4,J) X $ +AMAT(K-3,I)*AMAT(K-3,J)+AMAT(K-2,I)*AMAT(K-2,J) X $ +AMAT(K-1,I)*AMAT(K-1,J)+AMAT(K,I)*AMAT(K,J) X500 CONTINUE X END IF X IF(NCC4.GT.0) THEN X DO 600 KK=1,NCC4 X K=K+4 X SUM=SUM X $ +AMAT(K-3,I)*AMAT(K-3,J)+AMAT(K-2,I)*AMAT(K-2,J) X $ +AMAT(K-1,I)*AMAT(K-1,J)+AMAT(K,I)*AMAT(K,J) X600 CONTINUE X END IF X IF(NCC4R.GT.0) THEN X DO 700 KK=1,NCC4R X K=K+1 X SUM=SUM+AMAT(K,I)*AMAT(K,J) X700 CONTINUE X END IF X BMAT(I,J)=SUM X IF(I.NE.J) BMAT(J,I)=BMAT(I,J) X200 CONTINUE X100 CONTINUE X RETURN XC XC LAST CARD OF SUBROUTINE ATAMUL. XC X END END_OF_FILE if test 4482 -ne `wc -c <'atamul.f'`; then echo shar: \"'atamul.f'\" unpacked with wrong size! fi # end of 'atamul.f' fi if test -f 'ataov.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'ataov.f'\" else echo shar: Extracting \"'ataov.f'\" \(1786 characters\) sed "s/^X//" >'ataov.f' <<'END_OF_FILE' X SUBROUTINE ATAOV(OVERFL,MAXEXP,N,NUNIT,OUTPUT,A,B,SCALEF) XC XC SEPT. 8, 1991 XC XC THIS SUBROUTINE FINDS THE PRODUCT OF THE TRANSPOSE OF THE XC MATRIX A AND MATRIX A. EACH ENTRY IS CHECKED BEFORE BEING XC ACCEPTED. IF IT WOULD CAUSE AN OVERFLOW 10**MAXEXP IS XC INSERTED IN ITS PLACE. XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X INTEGER OUTPUT X DIMENSION A(N,N) ,B(N,N) ,SCALEF(N) X LOGICAL OVERFL ,WRNSUP X COMMON/NNES_2/WRNSUP X DATA ZERO,ONE,TWO,TEN /0.0D0,1.0D0,2.0D0,10.0D0/ XC X EPS=TEN**(-MAXEXP) X OVERFL=.FALSE. XC X DO 100 I=1,N X DO 200 J=I+1,N X SUM=ZERO X DO 300 K=1,N X IF(LOG10(ABS(A(K,I))+EPS)+LOG10(ABS(A(K,J))+EPS) X $ +TWO*LOG10(SCALEF(K)).GT.MAXEXP) THEN X OVERFL=.TRUE. X B(I,J)=SIGN(TEN**MAXEXP,A(K,I))*SIGN(ONE,A(K,J)) X IF(OUTPUT.GT.2.AND.(.NOT.WRNSUP)) THEN X WRITE(NUNIT,1) X1 FORMAT(T3,'*',T74,'*') X WRITE(NUNIT,2) B(I,J) X2 FORMAT(T3,'*',4X,'WARNING: COMPONENT IN', X $ ' MATRIX-MATRIX PRODUCT SET TO ',1PD12.3, X $ T74,'*') X END IF X GO TO 201 X END IF X SUM=SUM+A(K,I)*A(K,J)*SCALEF(K)*SCALEF(K) X300 CONTINUE X B(I,J)=SUM X B(J,I)=SUM X201 CONTINUE X200 CONTINUE X SUM=ZERO X DO 400 K=1,N X IF(TWO*(LOG10(ABS(A(K,I))+EPS)+LOG10(SCALEF(K))). X $ GT.MAXEXP) THEN X OVERFL=.TRUE. X B(I,I)=TEN**MAXEXP X IF(OUTPUT.GT.2.AND.(.NOT.WRNSUP)) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,2) B(I,I) X END IF X GO TO 401 X END IF X SUM=SUM+A(K,I)*A(K,I)*SCALEF(K)*SCALEF(K) X400 CONTINUE X B(I,I)=SUM X401 CONTINUE X100 CONTINUE X RETURN XC XC LAST CARD OF SUBROUTINE ATAOV. XC X END END_OF_FILE if test 1786 -ne `wc -c <'ataov.f'`; then echo shar: \"'ataov.f'\" unpacked with wrong size! fi # end of 'ataov.f' fi if test -f 'atbmul.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'atbmul.f'\" else echo shar: Extracting \"'atbmul.f'\" \(4592 characters\) sed "s/^X//" >'atbmul.f' <<'END_OF_FILE' X SUBROUTINE ATBMUL(NCADEC,NCAACT,NCBDEC,NCBACT,NCDEC,NCACT, X $ AMAT ,BMAT ,CMAT) XC XC FEB. 8, 1991 XC XC MATRIX MULTIPLICATION: A^B=C XC XC VERSION WITH INNER LOOP UNROLLED TO DEPTHS 32, 16, 8 AND 4. XC XC NCADEC IS 2ND DIM. OF AMAT; NCAACT IS ACTUAL LIMIT FOR 2ND INDEX XC NCBDEC IS 2ND DIM. OF BMAT; NCBACT IS ACTUAL LIMIT FOR 2ND INDEX XC NCDEC IS COMMON DIMENSION OF AMAT & BMAT; NCACT IS ACTUAL LIMIT XC XC I.E. NCADEC IS NUMBER OF COLUMNS OF A DECLARED XC NCBDEC IS NUMBER OF COLUMNS OF B DECLARED XC NCDEC IS THE NUMBER OF ROWS IN BOTH A AND B DECLARED XC XC MODIFIED VERSION OF THE MATRIX MULTIPLIER DONATED BY PROF. JAMES XC MACKINNON, QUEEN'S UNIVERSITY, KINGSTON, ONTARIO, CANADA XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DIMENSION AMAT(NCDEC,NCADEC), BMAT(NCDEC,NCBDEC), X $ CMAT(NCADEC,NCBDEC) X DATA ZERO /0.0D0/ XC XC FIND NUMBER OF GROUPS OF SIZE 32, 16 ... XC X NCC32=NCACT/32 X NCC32R=NCACT-32*NCC32 X NCC16=NCC32R/16 X NCC16R=NCC32R-16*NCC16 X NCC8=NCC16R/8 X NCC8R=NCC16R-8*NCC8 X NCC4=NCC8R/4 X NCC4R=NCC8R-4*NCC4 XC XC FIND ENTRY IN MATRIX C. XC X DO 100 I=1,NCAACT X DO 200 J=1,NCBACT X SUM=ZERO X K=0 X IF(NCC32.GT.0) THEN X DO 300 KK=1,NCC32 X K=K+32 X SUM=SUM X $ +AMAT(K-31,I)*BMAT(K-31,J)+AMAT(K-30,I)*BMAT(K-30,J) X $ +AMAT(K-29,I)*BMAT(K-29,J)+AMAT(K-28,I)*BMAT(K-28,J) X $ +AMAT(K-27,I)*BMAT(K-27,J)+AMAT(K-26,I)*BMAT(K-26,J) X $ +AMAT(K-25,I)*BMAT(K-25,J)+AMAT(K-24,I)*BMAT(K-24,J) X SUM=SUM X $ +AMAT(K-23,I)*BMAT(K-23,J)+AMAT(K-22,I)*BMAT(K-22,J) X $ +AMAT(K-21,I)*BMAT(K-21,J)+AMAT(K-20,I)*BMAT(K-20,J) X $ +AMAT(K-19,I)*BMAT(K-19,J)+AMAT(K-18,I)*BMAT(K-18,J) X $ +AMAT(K-17,I)*BMAT(K-17,J)+AMAT(K-16,I)*BMAT(K-16,J) X SUM=SUM X $ +AMAT(K-15,I)*BMAT(K-15,J)+AMAT(K-14,I)*BMAT(K-14,J) X $ +AMAT(K-13,I)*BMAT(K-13,J)+AMAT(K-12,I)*BMAT(K-12,J) X $ +AMAT(K-11,I)*BMAT(K-11,J)+AMAT(K-10,I)*BMAT(K-10,J) X $ +AMAT(K-9,I)*BMAT(K-9,J) +AMAT(K-8,I) *BMAT(K-8,J) X SUM=SUM X $ +AMAT(K-7,I)*BMAT(K-7,J)+AMAT(K-6,I)*BMAT(K-6,J) X $ +AMAT(K-5,I)*BMAT(K-5,J)+AMAT(K-4,I)*BMAT(K-4,J) X $ +AMAT(K-3,I)*BMAT(K-3,J)+AMAT(K-2,I)*BMAT(K-2,J) X $ +AMAT(K-1,I)*BMAT(K-1,J)+AMAT(K,I) *BMAT(K,J) X300 CONTINUE X END IF X IF(NCC16.GT.0) THEN X DO 400 KK=1,NCC16 X K=K+16 X SUM=SUM X $ +AMAT(K-15,I)*BMAT(K-15,J)+AMAT(K-14,I)*BMAT(K-14,J) X $ +AMAT(K-13,I)*BMAT(K-13,J)+AMAT(K-12,I)*BMAT(K-12,J) X $ +AMAT(K-11,I)*BMAT(K-11,J)+AMAT(K-10,I)*BMAT(K-10,J) X $ +AMAT(K-9,I)*BMAT(K-9,J) +AMAT(K-8,I) *BMAT(K-8,J) X SUM=SUM X $ +AMAT(K-7,I)*BMAT(K-7,J)+AMAT(K-6,I)*BMAT(K-6,J) X $ +AMAT(K-5,I)*BMAT(K-5,J)+AMAT(K-4,I)*BMAT(K-4,J) X $ +AMAT(K-3,I)*BMAT(K-3,J)+AMAT(K-2,I)*BMAT(K-2,J) X $ +AMAT(K-1,I)*BMAT(K-1,J)+AMAT(K,I) *BMAT(K,J) X400 CONTINUE X END IF X IF(NCC8.GT.0) THEN X DO 500 KK=1,NCC8 X K=K+8 X SUM=SUM X $ +AMAT(K-7,I)*BMAT(K-7,J)+AMAT(K-6,I)*BMAT(K-6,J) X $ +AMAT(K-5,I)*BMAT(K-5,J)+AMAT(K-4,I)*BMAT(K-4,J) X $ +AMAT(K-3,I)*BMAT(K-3,J)+AMAT(K-2,I)*BMAT(K-2,J) X $ +AMAT(K-1,I)*BMAT(K-1,J)+AMAT(K,I) *BMAT(K,J) X500 CONTINUE X END IF X IF(NCC4.GT.0) THEN X DO 600 KK=1,NCC4 X K=K+4 X SUM=SUM X $ +AMAT(K-3,I)*BMAT(K-3,J)+AMAT(K-2,I)*BMAT(K-2,J) X $ +AMAT(K-1,I)*BMAT(K-1,J)+AMAT(K,I) *BMAT(K,J) X600 CONTINUE X END IF X IF(NCC4R.GT.0) THEN X DO 700 KK=1,NCC4R X K=K+1 X SUM=SUM+AMAT(K,I)*BMAT(K,J) X700 CONTINUE X END IF X CMAT(I,J)=SUM X200 CONTINUE X100 CONTINUE X RETURN XC XC LAST CARD OF SUBROUTINE ATBMUL. XC X END X END_OF_FILE if test 4592 -ne `wc -c <'atbmul.f'`; then echo shar: \"'atbmul.f'\" unpacked with wrong size! fi # end of 'atbmul.f' fi if test -f 'atvov.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'atvov.f'\" else echo shar: Extracting \"'atvov.f'\" \(1198 characters\) sed "s/^X//" >'atvov.f' <<'END_OF_FILE' X SUBROUTINE ATVOV(OVERFL,MAXEXP,N,NUNIT,OUTPUT,AMAT,BVEC,CVEC) XC XC FEB. 8 ,1991 XC XC THIS SUBROUTINE FINDS THE PRODUCT OF THE TRANSPOSE OF THE XC MATRIX A AND THE VECTOR B WHERE EACH ENTRY IS CHECKED TO XC PREVENT OVERFLOWS. XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X INTEGER OUTPUT X DIMENSION AMAT(N,N) ,BVEC(N) ,CVEC(N) X LOGICAL OVERFL ,WRNSUP X COMMON/NNES_2/WRNSUP X DATA ZERO,ONE,TEN /0.0D0,1.0D0,10.0D0/ XC X EPS=TEN**(-MAXEXP) X OVERFL=.FALSE. XC X DO 100 I=1,N X SUM=ZERO X DO 200 J=1,N X IF(LOG10(ABS(AMAT(J,I))+EPS)+LOG10(ABS(BVEC(J))+EPS) X $ .GT.MAXEXP) THEN X OVERFL=.TRUE. X CVEC(I)=SIGN(TEN**MAXEXP,AMAT(J,I)) X $ *SIGN(ONE,BVEC(J)) X IF(OUTPUT.GT.2.AND.(.NOT.WRNSUP)) THEN X WRITE(NUNIT,1) X1 FORMAT(T3,'*',T74,'*') X WRITE(NUNIT,2) CVEC(I) X2 FORMAT(T3,'*',4X,'WARNING: COMPONENT IN', X $ ' MATRIX-VECTOR PRODUCT SET TO ',1PD12.3,T74,'*') X END IF X GO TO 101 X END IF X SUM=SUM+AMAT(J,I)*BVEC(J) X200 CONTINUE X CVEC(I)=SUM X101 CONTINUE X100 CONTINUE X RETURN XC XC LAST CARD OF SUBROUTINE ATVOV. XC X END END_OF_FILE if test 1198 -ne `wc -c <'atvov.f'`; then echo shar: \"'atvov.f'\" unpacked with wrong size! fi # end of 'atvov.f' fi if test -f 'avmul.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'avmul.f'\" else echo shar: Extracting \"'avmul.f'\" \(4104 characters\) sed "s/^X//" >'avmul.f' <<'END_OF_FILE' X SUBROUTINE AVMUL(NRADEC,NRAACT,NCDEC ,NCACT ,AMAT ,BVEC ,CVEC) XC XC FEB. 8, 1991 XC XC MATRIX-VECTOR MULTIPLICATION AB=C XC XC VERSION WITH INNER LOOP UNROLLED TO DEPTHS 32, 16, 8 AND 4 XC EACH ROW OF MATRIX A IS SAVED AS A COLUMN BEFORE USE. XC XC NRADEC IS 1ST DIM. OF AMAT; NRAACT IS ACTUAL LIMIT FOR 1ST INDEX XC NCDEC IS COMMON DIMENSION OF AMAT & BVEC; NCACT IS ACTUAL LIMIT XC XC I.E. NRADEC IS THE NUMBER OF ROWS OF A DECLARED XC NCDEC IS THE COMMON DECLARED DIMENSION (COLUMNS OF A AND XC ROWS OF B) XC XC MODIFICATION OF THE MATRIX MULTIPLIER DONATED BY PROF. JAMES XC MACKINNON, QUEEN'S UNIVERSITY, KINGSTON, ONTARIO, CANADA XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DIMENSION AMAT(NRADEC,NCDEC), BVEC(NCDEC), CVEC(NRADEC) X DATA ZERO /0.0D0/ XC XC FIND NUMBER OF GROUPS OF SIZE 32, 16 ... XC X NCC32=NCACT/32 X NCC32R=NCACT-32*NCC32 X NCC16=NCC32R/16 X NCC16R=NCC32R-16*NCC16 X NCC8=NCC16R/8 X NCC8R=NCC16R-8*NCC8 X NCC4=NCC8R/4 X NCC4R=NCC8R-4*NCC4 X DO 100 I=1,NRAACT XC XC FIND ENTRY FOR VECTOR C. XC X SUM=ZERO X K=0 X IF(NCC32.GT.0) THEN X DO 200 KK=1,NCC32 X K=K+32 X SUM=SUM X $ +AMAT(I,K-31)*BVEC(K-31)+AMAT(I,K-30)*BVEC(K-30) X $ +AMAT(I,K-29)*BVEC(K-29)+AMAT(I,K-28)*BVEC(K-28) X $ +AMAT(I,K-27)*BVEC(K-27)+AMAT(I,K-26)*BVEC(K-26) X $ +AMAT(I,K-25)*BVEC(K-25)+AMAT(I,K-24)*BVEC(K-24) X SUM=SUM X $ +AMAT(I,K-23)*BVEC(K-23)+AMAT(I,K-22)*BVEC(K-22) X $ +AMAT(I,K-21)*BVEC(K-21)+AMAT(I,K-20)*BVEC(K-20) X $ +AMAT(I,K-19)*BVEC(K-19)+AMAT(I,K-18)*BVEC(K-18) X $ +AMAT(I,K-17)*BVEC(K-17)+AMAT(I,K-16)*BVEC(K-16) X SUM=SUM X $ +AMAT(I,K-15)*BVEC(K-15)+AMAT(I,K-14)*BVEC(K-14) X $ +AMAT(I,K-13)*BVEC(K-13)+AMAT(I,K-12)*BVEC(K-12) X $ +AMAT(I,K-11)*BVEC(K-11)+AMAT(I,K-10)*BVEC(K-10) X $ +AMAT(I,K-9)*BVEC(K-9) +AMAT(I,K-8) *BVEC(K-8) X SUM=SUM X $ +AMAT(I,K-7)*BVEC(K-7)+AMAT(I,K-6)*BVEC(K-6) X $ +AMAT(I,K-5)*BVEC(K-5)+AMAT(I,K-4)*BVEC(K-4) X $ +AMAT(I,K-3)*BVEC(K-3)+AMAT(I,K-2)*BVEC(K-2) X $ +AMAT(I,K-1)*BVEC(K-1)+AMAT(I,K) *BVEC(K) X200 CONTINUE X END IF X IF(NCC16.GT.0) THEN X DO 300 KK=1,NCC16 X K=K+16 X SUM=SUM X $ +AMAT(I,K-15)*BVEC(K-15)+AMAT(I,K-14)*BVEC(K-14) X $ +AMAT(I,K-13)*BVEC(K-13)+AMAT(I,K-12)*BVEC(K-12) X $ +AMAT(I,K-11)*BVEC(K-11)+AMAT(I,K-10)*BVEC(K-10) X $ +AMAT(I,K-9)*BVEC(K-9) +AMAT(I,K-8) *BVEC(K-8) X SUM=SUM X $ +AMAT(I,K-7)*BVEC(K-7)+AMAT(I,K-6)*BVEC(K-6) X $ +AMAT(I,K-5)*BVEC(K-5)+AMAT(I,K-4)*BVEC(K-4) X $ +AMAT(I,K-3)*BVEC(K-3)+AMAT(I,K-2)*BVEC(K-2) X $ +AMAT(I,K-1)*BVEC(K-1)+AMAT(I,K) *BVEC(K) X300 CONTINUE X END IF X IF(NCC8.GT.0) THEN X DO 400 KK=1,NCC8 X K=K+8 X SUM=SUM X $ +AMAT(I,K-7)*BVEC(K-7)+AMAT(I,K-6)*BVEC(K-6) X $ +AMAT(I,K-5)*BVEC(K-5)+AMAT(I,K-4)*BVEC(K-4) X $ +AMAT(I,K-3)*BVEC(K-3)+AMAT(I,K-2)*BVEC(K-2) X $ +AMAT(I,K-1)*BVEC(K-1)+AMAT(I,K) *BVEC(K) X400 CONTINUE X END IF X IF(NCC4.GT.0) THEN X DO 500 KK=1,NCC4 X K=K+4 X SUM=SUM X $ +AMAT(I,K-3)*BVEC(K-3)+AMAT(I,K-2)*BVEC(K-2) X $ +AMAT(I,K-1)*BVEC(K-1)+AMAT(I,K) *BVEC(K) X500 CONTINUE X END IF X IF(NCC4R.GT.0) THEN X DO 600 KK=1,NCC4R X K=K+1 X SUM=SUM+AMAT(I,K)*BVEC(K) X600 CONTINUE X END IF X CVEC(I)=SUM X100 CONTINUE X RETURN XC XC LAST CARD OF SUBROUTINE AVMUL. XC X END END_OF_FILE if test 4104 -ne `wc -c <'avmul.f'`; then echo shar: \"'avmul.f'\" unpacked with wrong size! fi # end of 'avmul.f' fi if test -f 'bakdif.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'bakdif.f'\" else echo shar: Extracting \"'bakdif.f'\" \(510 characters\) sed "s/^X//" >'bakdif.f' <<'END_OF_FILE' X SUBROUTINE BAKDIF(OVERFL,J ,N ,DELTAJ,TEMPJ ,FVEC , X $ FVECJ1,JACFDM,XC ,FVECEV) XC XC FEB. 6, 1991 XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION JACFDM(N,N) X DIMENSION FVEC(N),FVECJ1(N),XC(N) X LOGICAL OVERFL X EXTERNAL FVECEV X DELTAJ=TEMPJ-XC(J) X CALL FVECEV(OVERFL,N,FVECJ1,XC) X IF(.NOT.OVERFL) THEN X DO 100 I=1,N X JACFDM(I,J)=(FVEC(I)-FVECJ1(I))/DELTAJ X100 CONTINUE X END IF X RETURN XC XC LAST CARD OF SUBROUTINE BAKDIF. XC X END END_OF_FILE if test 510 -ne `wc -c <'bakdif.f'`; then echo shar: \"'bakdif.f'\" unpacked with wrong size! fi # end of 'bakdif.f' fi if test -f 'bnddif.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'bnddif.f'\" else echo shar: Extracting \"'bnddif.f'\" \(1208 characters\) sed "s/^X//" >'bnddif.f' <<'END_OF_FILE' X SUBROUTINE BNDDIF(OVERFL,J ,N ,EPSMCH,BOUNDL,BOUNDU, X $ FVECC ,FVECJ1,JACFDM,WV3 ,XC ,FVECEV) XC XC FEB. 15, 1991 XC XC FINITE DIFFERENCE CALCULATION WHEN THE BOUNDS FOR COMPONENT J XC ARE SO CLOSE THAT NEITHER A FORWARD NOR BACKWARD DIFFERENCE XC CAN BE PERFORMED. XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION JACFDM(N,N) X DIMENSION BOUNDL(N) ,BOUNDU(N), FVECC(N) ,FVECJ1(N) , X $ WV3(N) ,XC(N) X LOGICAL OVERFL X EXTERNAL FVECEV X DATA ZERO /0.0D0/ XC X EPS3Q=EPSMCH**0.75 XC XC STORE CURRENT X DO 100 I=1,N X WV3(I)=FVECC(I) X100 CONTINUE X XC(J)=BOUNDU(J) X CALL FVECEV(OVERFL,N,FVECJ1,XC) X IF(.NOT.OVERFL) THEN X XC(J)=BOUNDL(J) X CALL FVECEV(OVERFL,N,FVECC,XC) X IF(.NOT.OVERFL) THEN X DO 200 I=1,N XC XC ENSURE THAT THE JACOBIAN CALCULATION ISN'T JUST NOISE. XC X IF(FVECJ1(I)-FVECC(I).GT.EPS3Q) THEN X JACFDM(I,J)=(FVECJ1(I)-FVECC(I))/ X $ (BOUNDU(J)-BOUNDL(J)) X ELSE X JACFDM(I,J)=ZERO X END IF X200 CONTINUE X END IF X END IF X DO 300 I=1,N X FVECC(I)=WV3(I) X300 CONTINUE X RETURN XC XC LAST CARD OF SUBROUTINE BNDDIF. XC X END END_OF_FILE if test 1208 -ne `wc -c <'bnddif.f'`; then echo shar: \"'bnddif.f'\" unpacked with wrong size! fi # end of 'bnddif.f' fi if test -f 'broyfa.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'broyfa.f'\" else echo shar: Extracting \"'broyfa.f'\" \(4367 characters\) sed "s/^X//" >'broyfa.f' <<'END_OF_FILE' X SUBROUTINE BROYFA(OVERCH,OVERFL,SCLFCH,SCLXCH,MAXEXP, X $ N ,NUNIT ,OUTPUT,EPSMCH,A , X $ DELF ,FVEC ,FVECC ,JAC ,RDIAG , X $ S ,SCALEF,SCALEX,T ,W , X $ XC ,XPLUS ) XC XC FEB. 23, 1992 XC XC THE BROYDEN QUASI-NEWTON METHOD IS APPLIED TO THE FACTORED XC FORM OF THE JACOBIAN. XC XC NOTE: T AND W ARE TEMPORARY WORKING VECTORS ONLY. XC XC THE UPDATE OCCURS ONLY IF A SIGNIFICANT CHANGE IN THE XC JACOBIAN WOULD RESULT, I.E., NOT ALL THE VALUES IN VECTOR W XC ARE LESS THAN THE THRESHOLD IN MAGNITUDE. IF THE VECTOR XC W IS ESSENTIALLY ZERO THEN THE LOGICAL VARIABLE SKIPUP XC REMAINS SET AT TRUE. XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION JAC(N,N) X INTEGER OUTPUT X DIMENSION A(N,N) ,DELF(N) ,FVEC(N) ,FVECC(N) , X $ RDIAG(N) ,S(N) ,SCALEF(N) ,SCALEX(N), X $ T(N) ,W(N) ,XC(N) ,XPLUS(N) X LOGICAL OVERCH ,OVERFL ,SCLFCH ,SCLXCH , X $ SKIPUP X DATA ZERO,TEN /0.0D0,10.0D0/ XC X OVERFL=.FALSE. X EPS=TEN**(-MAXEXP) X SQRTEP=SQRT(EPSMCH) XC X DO 100 I=1,N X A(I,I)=RDIAG(I) X S(I)=XPLUS(I)-XC(I) X100 CONTINUE XC XC R IS NOW IN THE UPPER TRIANGLE OF A. XC X SKIPUP=.TRUE. XC XC THE BROYDEN UPDATE IS CONDENSED INTO THE FORM XC XC A(NEW) = A(OLD) + T S^ XC XC THE PRODUCT A*S IS FORMED IN TWO STAGES AS R IS IN THE UPPER XC TRIANGLE OF MATRIX A AND Q^ IS IN JAC. XC XC FIRST MULTIPLY R*S (A IS CONSIDERED UPPER TRIANGULAR) XC X CALL UVMUL(N,N,N,N,A,S,T) XC XC NOTE: THIS T IS TEMPORARY - IT IS THE T FROM BELOW WHICH XC IS SENT TO SUBROUTINE QRUPDA. XC X DO 200 I=1,N X CALL INNERP(OVERCH,OVERFL,MAXEXP,N ,N ,N , X $ NUNIT ,OUTPUT,SUM ,JAC(N*(I-1)+1,1),T) X W(I)=SCALEF(I)*(FVEC(I)-FVECC(I))-SUM XC XC TEST TO ENSURE VECTOR W IS NONZERO. ANY VALUE GREATER XC THAN THE THRESHOLD WILL SET SKIPUP TO FALSE. XC X IF(ABS(W(I)).GT.SQRTEP*SCALEF(I)*(ABS(FVEC(I))+ X $ ABS(FVECC(I)))) THEN X SKIPUP=.FALSE. X ELSE X W(I)=ZERO X END IF X200 CONTINUE XC XC IF W(I)=0 FOR ALL I THEN THE UPDATE IS SKIPPED. XC X IF(.NOT.SKIPUP) THEN XC XC T=Q^W; Q^ IS IN JAC. XC X CALL AVMUL(N,N,N,N,JAC,W,T) X IF(SCLXCH) THEN X DO 300 I=1,N X W(I)=S(I)*SCALEX(I) X300 CONTINUE X ELSE X CALL MATCOP(N,N,1,1,N,1,S,W) X END IF X CALL TWONRM(OVERFL,MAXEXP,N,EPSMCH,DENOM,W) XC XC IF OVERFLOW WOULD OCCUR MAKE NO CHANGE TO JACOBIAN. XC X IF(OVERFL.OR.LOG10(DENOM+EPS).GT.MAXEXP/2) THEN X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X1 FORMAT(T3,'*',T74,'*') X WRITE(NUNIT,2) X2 FORMAT(T3,'*',4X,'WARNING: JACOBIAN NOT UPDATED', X $ ' TO AVOID OVERFLOW IN DENOMINATOR OF',T74,'*') X WRITE(NUNIT,3) X3 FORMAT(T3,'*',4X,'BROYDEN UPDATE',T74,'*') X END IF X RETURN X ELSE X DENOM=DENOM*DENOM X END IF XC XC IF DENOM IS ZERO AVOID DIVIDE BY ZERO AND CONTINUE WITH XC SAME JACOBIAN. XC X IF(DENOM.EQ.ZERO) RETURN XC XC THE SCALED VERSION OF S REPLACES THE ORIGINAL BEFORE XC BEING SENT TO QRUPDA. XC X DO 400 I=1,N X S(I)=S(I)*SCALEX(I)*SCALEX(I)/DENOM X400 CONTINUE XC XC UPDATE THE QR DECOMPOSITION USING A SERIES OF GIVENS XC ROTATIONS. XC X CALL QRUPDA(OVERFL,MAXEXP,N,EPSMCH,A,JAC,T,S) XC XC RESET RDIAG AS DIAGONAL OF CURRENT R WHICH IS IN XC THE UPPER TRIANGE OF A. XC X DO 500 I=1,N X RDIAG(I)=A(I,I) X500 CONTINUE X END IF XC XC UPDATE THE GRADIENT VECTOR, DELF. THE NEW Q^ IS IN JAC. XC XC DELF = (QR)^F = R^Q^F = R^JAC F XC X IF(SCLFCH) THEN X DO 600 I=1,N X W(I)=FVEC(I)*SCALEF(I) X600 CONTINUE X ELSE X CALL MATCOP(N,N,1,1,N,1,FVEC,W) X END IF X CALL AVMUL(N,N,N,N,JAC,W,T) X CALL UTBMUL(N,N,1,1,N,N,A,T,DELF) X RETURN XC XC LAST CARD OF SUBROUTINE BROYFA. XC X END END_OF_FILE if test 4367 -ne `wc -c <'broyfa.f'`; then echo shar: \"'broyfa.f'\" unpacked with wrong size! fi # end of 'broyfa.f' fi if test -f 'broyun.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'broyun.f'\" else echo shar: Extracting \"'broyun.f'\" \(2115 characters\) sed "s/^X//" >'broyun.f' <<'END_OF_FILE' X SUBROUTINE BROYUN(OVERFL,MAXEXP,N ,NUNIT ,OUTPUT, X $ EPSMCH,FVEC ,FVECC ,JAC ,SCALEX, X $ WV1 ,XC ,XPLUS) XC XC FEB. 23, 1992 XC XC UPDATE THE JACOBIAN USING BROYDEN'S METHOD. XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION JAC(N,N) X INTEGER OUTPUT X DIMENSION FVEC(N) ,FVECC(N) ,SCALEX(N),WV1(N) , X $ XC(N) ,XPLUS(N) X LOGICAL OVERFL X DATA ZERO,TEN /0.0D0,10.0D0/ XC X EPS=TEN**(-MAXEXP) X SQRTEP=SQRT(EPSMCH) XC X DO 100 I=1,N X WV1(I)=(XPLUS(I)-XC(I))*SCALEX(I) X100 CONTINUE X CALL TWONRM(OVERFL,MAXEXP,N,EPSMCH,DENOM,WV1) XC XC IF OVERFLOW WOULD OCCUR MAKE NO CHANGE TO JACOBIAN. XC X IF(OVERFL.OR.LOG10(DENOM+EPS).GT.MAXEXP/2) THEN X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X1 FORMAT(T3,'*',T74,'*') X WRITE(NUNIT,2) X2 FORMAT(T3,'*',4X,'WARNING: JACOBIAN NOT UPDATED', X $ ' TO AVOID OVERFLOW IN DENOMINATOR OF',T74,'*') X WRITE(NUNIT,3) X3 FORMAT(T3,'*',4X,'BROYDEN UPDATE',T74,'*') X END IF X RETURN X ELSE X DENOM=DENOM*DENOM X END IF XC XC IF DENOM IS ZERO, AVOID OVERFLOW, CONTINUE WITH SAME JACOBIAN. XC X IF(DENOM.EQ.ZERO) RETURN XC XC UPDATE JACOBIAN BY ROWS. XC X DO 200 I=1,N X SUM=ZERO X DO 300 J=1,N X SUM=SUM+JAC(I,J)*(XPLUS(J)-XC(J)) X300 CONTINUE X TEMPI=FVEC(I)-FVECC(I)-SUM XC XC CHECK TO ENSURE THAT SOME MEANINGFUL CHANGE IS BEING MADE XC TO THE APPROXIMATE JACOBIAN; IF NOT, SKIP UPDATING ROW I. XC X IF(ABS(TEMPI).GE.SQRTEP*(ABS(FVEC(I))+ABS(FVECC(I)))) X $ THEN X TEMPI=TEMPI/DENOM X DO 400 J=1,N X JAC(I,J)=JAC(I,J)+TEMPI* X $ (XPLUS(J)-XC(J))*SCALEX(J)*SCALEX(J) X400 CONTINUE X END IF X200 CONTINUE X RETURN XC XC LAST CARD OF SUBROUTINE BROYUN. XC X END END_OF_FILE if test 2115 -ne `wc -c <'broyun.f'`; then echo shar: \"'broyun.f'\" unpacked with wrong size! fi # end of 'broyun.f' fi if test -f 'cholde.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'cholde.f'\" else echo shar: Extracting \"'cholde.f'\" \(1982 characters\) sed "s/^X//" >'cholde.f' <<'END_OF_FILE' X SUBROUTINE CHOLDE(N,MAXADD,MAXFFL,SQRTEP,H,L) XC XC FEB. 23, 1992 XC XC THIS SUBROUTINE FINDS THE CHOLESKY DECOMPOSITION OF THE XC MATRIX, H, AND RETURNS IT IN THE LOWER TRIANGLE OF XC MATRIX, L. XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION L(N,N) ,MAXADD ,MAXFFL ,MINL ,MINL2 , X $ MINLJJ X DIMENSION H(N,N) X DATA ZERO /0.0D0/ XC X MINL=SQRT(SQRTEP)*MAXFFL XC XC MAXFFL EQUALS 0 WHEN THE MATRIX IS KNOWN TO BE POSITIVE XC DEFINITE. XC X IF(MAXFFL.EQ.ZERO) THEN XC XC FIND SQUARE ROOT OF LARGEST MAGNITUDE DIAGONAL ELEMENT XC AND SET MINL2. XC X DO 100 I=1,N X MAXFFL=MAX(MAXFFL,ABS(H(I,I))) X100 CONTINUE X MAXFFL=SQRT(MAXFFL) X MINL2=SQRTEP*MAXFFL X END IF XC XC MAXADD CONTAINS THE MAXIMUM AMOUNT WHICH IS IMPLICITLY ADDED XC TO ANY DIAGONAL ELEMENT OF MATRIX H. XC X MAXADD=ZERO X DO 200 J=1,N X SUM=ZERO X DO 300 I=1,J-1 X SUM=SUM+L(J,I)*L(J,I) X300 CONTINUE X L(J,J)=H(J,J)-SUM X MINLJJ=ZERO X DO 400 I=J+1,N X SUM=ZERO X DO 500 K=1,J-1 X SUM=SUM+L(I,K)*L(J,K) X500 CONTINUE X L(I,J)=H(J,I)-SUM X MINLJJ=MAX(MINLJJ,ABS(L(I,J))) X400 CONTINUE X MINLJJ=MAX(MINLJJ/MAXFFL,MINL) X IF(L(J,J).GT.MINLJJ*MINLJJ) THEN XC XC NORMAL CHOLESKY DECOMPOSITION. XC X L(J,J)=SQRT(L(J,J)) X ELSE XC XC IMPLICITLY PERTURB DIAGONAL OF H. XC X IF(MINLJJ.LT.MINL2) THEN X MINLJJ=MINL2 X END IF X MAXADD=MAX(MAXADD,MINLJJ*MINLJJ-L(J,J)) X L(J,J)=MINLJJ X END IF X DO 600 I=J+1,N X L(I,J)=L(I,J)/L(J,J) X600 CONTINUE X200 CONTINUE X RETURN XC XC LAST CARD OF SUBROUTINE CHOLDE. XC X END END_OF_FILE if test 1982 -ne `wc -c <'cholde.f'`; then echo shar: \"'cholde.f'\" unpacked with wrong size! fi # end of 'cholde.f' fi if test -f 'chsolv.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'chsolv.f'\" else echo shar: Extracting \"'chsolv.f'\" \(692 characters\) sed "s/^X//" >'chsolv.f' <<'END_OF_FILE' X SUBROUTINE CHSOLV(OVERCH,OVERFL,MAXEXP,N ,NUNIT , X $ OUTPUT,L ,RHS ,S ,WV2 ) XC XC FEB. 14, 1991 XC XC THIS SUBROUTINE USES FORWARD/BACKWARD SUBSTITUTION TO SOLVE THE XC SYSTEM OF LINEAR EQUATIONS: XC XC (LL^)S=RHS XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION L(N,N) X INTEGER OUTPUT X DIMENSION RHS(N) ,S(N) ,WV2(N) X LOGICAL OVERCH ,OVERFL XC X CALL LSOLV(OVERCH,OVERFL,MAXEXP,N,NUNIT,OUTPUT,L,WV2,RHS) X CALL LTSOLV(OVERCH,OVERFL,MAXEXP,N,NUNIT,OUTPUT,L,S,WV2) XC X RETURN XC XC LAST CARD OF SUBROUTINE CHSOLV. XC X END END_OF_FILE if test 692 -ne `wc -c <'chsolv.f'`; then echo shar: \"'chsolv.f'\" unpacked with wrong size! fi # end of 'chsolv.f' fi if test -f 'condno.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'condno.f'\" else echo shar: Extracting \"'condno.f'\" \(4495 characters\) sed "s/^X//" >'condno.f' <<'END_OF_FILE' X SUBROUTINE CONDNO(OVERCH,OVERFL,MAXEXP,N ,NUNIT , X $ OUTPUT,CONNUM,A ,P ,PM , X $ Q ,RDIAG ) XC XC FEB. 14, 1991 XC XC THIS SUBROUTINE ESTIMATES THE CONDITION NUMBER OF A XC QR-DECOMPOSED MATRIX USING THE METHOD OF CLINE, MOLER, XC STEWART AND WILKINSON (SIAM J. N.A. 16 P368 (1979) ). XC XC IF A POTENTIAL OVERFLOW IS DETECTED AT ANY POINT THEN A XC CONDITION NUMBER EQUIVALENT TO THAT OF A SINGULAR MATRIX XC IS ASSIGNED BY THE CALLING SUBROUTINE. XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DIMENSION A(N,N) ,P(N) ,PM(N) ,RDIAG(N) ,Q(N) X LOGICAL OVERCH ,OVERFL X DATA ZERO,ONE,TEN /0.0D0,1.0D0,10.0D0/ XC X OVERFL=.FALSE. X EPS=TEN**(-MAXEXP) XC X CONNUM=ABS(RDIAG(1)) X DO 100 J=2,N X TEMP=ZERO X DO 200 I=1,J-1 X IF(OVERCH) THEN X IF(ABS(A(I,J)).GT.TEN**(MAXEXP-1)) THEN X OVERFL=.TRUE. X RETURN X END IF X END IF X TEMP=TEMP+ABS(A(I,J)) X200 CONTINUE X TEMP=TEMP+ABS(RDIAG(J)) X CONNUM=MAX(CONNUM,TEMP) X100 CONTINUE X Q(1)=ONE/RDIAG(1) X DO 300 I=2,N X IF(OVERCH) THEN X IF(LOG10(ABS(Q(1))+EPS)+LOG10(ABS(A(1,I))+EPS) X $ .GT.MAXEXP) THEN X OVERFL=.TRUE. X RETURN X END IF X END IF X P(I)=A(1,I)*Q(1) X300 CONTINUE X DO 400 J=2,N X IF(OVERCH) THEN X IF(LOG10(ABS(P(J))+EPS)-LOG10(ABS(RDIAG(J))+EPS) X $ .GT.MAXEXP) THEN X OVERFL=.TRUE. X RETURN X END IF X END IF X QP=(ONE-P(J))/RDIAG(J) X QM=(-ONE-P(J))/RDIAG(J) X TEMP=ABS(QP) X TEMPM=ABS(QM) X DO 500 I=J+1,N X IF(OVERCH) THEN X IF(LOG10(ABS(A(J,I))+EPS)+LOG10(ABS(QM)+EPS) X $ .GT.MAXEXP) THEN X OVERFL=.TRUE. X RETURN X END IF X END IF X PM(I)=P(I)+A(J,I)*QM X IF(OVERCH) THEN X IF(LOG10(ABS(PM(I))+EPS)-LOG10(ABS(RDIAG(I))+EPS) X $ .GT.MAXEXP) THEN X OVERFL=.TRUE. X RETURN X END IF X END IF X TEMPM=TEMPM+(ABS(PM(I))/ABS(RDIAG(I))) X IF(OVERCH) THEN X IF(TEMPM.GT.TEN**(MAXEXP-1)) THEN X OVERFL=.TRUE. X RETURN X END IF X END IF X IF(OVERCH) THEN X IF(LOG10(ABS(A(J,I))+EPS)+LOG10(ABS(QP)+EPS) X $ .GT.MAXEXP) THEN X OVERFL=.TRUE. X RETURN X END IF X END IF X P(I)=P(I)+A(J,I)*QP X IF(OVERCH) THEN X IF(LOG10(ABS(P(I))+EPS)-LOG10(ABS(RDIAG(I))+EPS) X $ .GT.MAXEXP) THEN X OVERFL=.TRUE. X RETURN X END IF X END IF X TEMP=TEMP+(ABS(P(I))/ABS(RDIAG(I))) X IF(OVERCH) THEN X IF(TEMP.GT.TEN**(MAXEXP-1)) THEN X OVERFL=.TRUE. X RETURN X END IF X END IF X500 CONTINUE X IF(TEMP.GE.TEMPM) THEN X Q(J)=QP X ELSE X Q(J)=QM X DO 600 I=J+1,N X P(I)=PM(I) X600 CONTINUE X END IF X400 CONTINUE X QNORM=ZERO X DO 700 J=1,N X QNORM=QNORM+ABS(Q(J)) X IF(OVERCH) THEN X IF(QNORM.GT.TEN**(MAXEXP-1)) THEN X OVERFL=.TRUE. X RETURN X END IF X END IF X700 CONTINUE X IF(LOG10(CONNUM)-LOG10(QNORM).GT.MAXEXP) THEN X OVERFL=.TRUE. X RETURN X END IF X CONNUM=CONNUM/QNORM X CALL RSOLV(OVERCH,OVERFL,MAXEXP,N,NUNIT,OUTPUT,A,RDIAG,Q) X IF(OVERFL) RETURN X QNORM=ZERO X DO 800 J=1,N X QNORM=QNORM+ABS(Q(J)) X IF(OVERCH) THEN X IF(QNORM.GT.TEN**(MAXEXP-1)) THEN X OVERFL=.TRUE. X RETURN X END IF X END IF X800 CONTINUE X CONNUM=CONNUM*QNORM X RETURN XC XC LAST CARD OF SUBROUTINE CONDNO. XC X END END_OF_FILE if test 4495 -ne `wc -c <'condno.f'`; then echo shar: \"'condno.f'\" unpacked with wrong size! fi # end of 'condno.f' fi if test -f 'd1mach.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'d1mach.f'\" else echo shar: Extracting \"'d1mach.f'\" \(7515 characters\) sed "s/^X//" >'d1mach.f' <<'END_OF_FILE' X DOUBLE PRECISION FUNCTION D1MACH(I) X INTEGER I XC XC DOUBLE-PRECISION MACHINE CONSTANTS XC D1MACH( 1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE. XC D1MACH( 2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. XC D1MACH( 3) = B**(-T), THE SMALLEST RELATIVE SPACING. XC D1MACH( 4) = B**(1-T), THE LARGEST RELATIVE SPACING. XC D1MACH( 5) = LOG10(B) XC X INTEGER SMALL(2) X INTEGER LARGE(2) X INTEGER RIGHT(2) X INTEGER DIVER(2) X INTEGER LOG10(2) X INTEGER SC, CRAY1(38), J X COMMON /D9MACH/ CRAY1 X SAVE SMALL, LARGE, RIGHT, DIVER, LOG10, SC X DOUBLE PRECISION DMACH(5) X EQUIVALENCE (DMACH(1),SMALL(1)) X EQUIVALENCE (DMACH(2),LARGE(1)) X EQUIVALENCE (DMACH(3),RIGHT(1)) X EQUIVALENCE (DMACH(4),DIVER(1)) X EQUIVALENCE (DMACH(5),LOG10(1)) XC THIS VERSION ADAPTS AUTOMATICALLY TO MOST CURRENT MACHINES. XC R1MACH CAN HANDLE AUTO-DOUBLE COMPILING, BUT THIS VERSION OF XC D1MACH DOES NOT, BECAUSE WE DO NOT HAVE QUAD CONSTANTS FOR XC MANY MACHINES YET. XC TO COMPILE ON OLDER MACHINES, ADD A C IN COLUMN 1 XC ON THE NEXT LINE X DATA SC/0/ XC AND REMOVE THE C FROM COLUMN 1 IN ONE OF THE SECTIONS BELOW. XC CONSTANTS FOR EVEN OLDER MACHINES CAN BE OBTAINED BY XC mail netlib@research.bell-labs.com XC send old1mach from blas XC PLEASE SEND CORRECTIONS TO dmg OR ehg@bell-labs.com. XC XC MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES. XC DATA SMALL(1),SMALL(2) / O402400000000, O000000000000 / XC DATA LARGE(1),LARGE(2) / O376777777777, O777777777777 / XC DATA RIGHT(1),RIGHT(2) / O604400000000, O000000000000 / XC DATA DIVER(1),DIVER(2) / O606400000000, O000000000000 / XC DATA LOG10(1),LOG10(2) / O776464202324, O117571775714 /, SC/987/ XC XC MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING XC 32-BIT INTEGERS. XC DATA SMALL(1),SMALL(2) / 8388608, 0 / XC DATA LARGE(1),LARGE(2) / 2147483647, -1 / XC DATA RIGHT(1),RIGHT(2) / 612368384, 0 / XC DATA DIVER(1),DIVER(2) / 620756992, 0 / XC DATA LOG10(1),LOG10(2) / 1067065498, -2063872008 /, SC/987/ XC XC MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. XC DATA SMALL(1),SMALL(2) / O000040000000, O000000000000 / XC DATA LARGE(1),LARGE(2) / O377777777777, O777777777777 / XC DATA RIGHT(1),RIGHT(2) / O170540000000, O000000000000 / XC DATA DIVER(1),DIVER(2) / O170640000000, O000000000000 / XC DATA LOG10(1),LOG10(2) / O177746420232, O411757177572 /, SC/987/ XC XC ON FIRST CALL, IF NO DATA UNCOMMENTED, TEST MACHINE TYPES. X IF (SC .NE. 987) THEN X DMACH(1) = 1.D13 X IF ( SMALL(1) .EQ. 1117925532 X * .AND. SMALL(2) .EQ. -448790528) THEN X* *** IEEE BIG ENDIAN *** X SMALL(1) = 1048576 X SMALL(2) = 0 X LARGE(1) = 2146435071 X LARGE(2) = -1 X RIGHT(1) = 1017118720 X RIGHT(2) = 0 X DIVER(1) = 1018167296 X DIVER(2) = 0 X LOG10(1) = 1070810131 X LOG10(2) = 1352628735 X ELSE IF ( SMALL(2) .EQ. 1117925532 X * .AND. SMALL(1) .EQ. -448790528) THEN X* *** IEEE LITTLE ENDIAN *** X SMALL(2) = 1048576 X SMALL(1) = 0 X LARGE(2) = 2146435071 X LARGE(1) = -1 X RIGHT(2) = 1017118720 X RIGHT(1) = 0 X DIVER(2) = 1018167296 X DIVER(1) = 0 X LOG10(2) = 1070810131 X LOG10(1) = 1352628735 X ELSE IF ( SMALL(1) .EQ. -2065213935 X * .AND. SMALL(2) .EQ. 10752) THEN X* *** VAX WITH D_FLOATING *** X SMALL(1) = 128 X SMALL(2) = 0 X LARGE(1) = -32769 X LARGE(2) = -1 X RIGHT(1) = 9344 X RIGHT(2) = 0 X DIVER(1) = 9472 X DIVER(2) = 0 X LOG10(1) = 546979738 X LOG10(2) = -805796613 X ELSE IF ( SMALL(1) .EQ. 1267827943 X * .AND. SMALL(2) .EQ. 704643072) THEN X* *** IBM MAINFRAME *** X SMALL(1) = 1048576 X SMALL(2) = 0 X LARGE(1) = 2147483647 X LARGE(2) = -1 X RIGHT(1) = 856686592 X RIGHT(2) = 0 X DIVER(1) = 873463808 X DIVER(2) = 0 X LOG10(1) = 1091781651 X LOG10(2) = 1352628735 X ELSE IF ( SMALL(1) .EQ. 1120022684 X * .AND. SMALL(2) .EQ. -448790528) THEN X* *** CONVEX C-1 *** X SMALL(1) = 1048576 X SMALL(2) = 0 X LARGE(1) = 2147483647 X LARGE(2) = -1 X RIGHT(1) = 1019215872 X RIGHT(2) = 0 X DIVER(1) = 1020264448 X DIVER(2) = 0 X LOG10(1) = 1072907283 X LOG10(2) = 1352628735 X ELSE IF ( SMALL(1) .EQ. 815547074 X * .AND. SMALL(2) .EQ. 58688) THEN X* *** VAX G-FLOATING *** X SMALL(1) = 16 X SMALL(2) = 0 X LARGE(1) = -32769 X LARGE(2) = -1 X RIGHT(1) = 15552 X RIGHT(2) = 0 X DIVER(1) = 15568 X DIVER(2) = 0 X LOG10(1) = 1142112243 X LOG10(2) = 2046775455 X ELSE X DMACH(2) = 1.D27 + 1 X DMACH(3) = 1.D27 X LARGE(2) = LARGE(2) - RIGHT(2) X IF (LARGE(2) .EQ. 64 .AND. SMALL(2) .EQ. 0) THEN X CRAY1(1) = 67291416 X DO 10 J = 1, 20 X CRAY1(J+1) = CRAY1(J) + CRAY1(J) X 10 CONTINUE X CRAY1(22) = CRAY1(21) + 321322 X DO 20 J = 22, 37 X CRAY1(J+1) = CRAY1(J) + CRAY1(J) X 20 CONTINUE X IF (CRAY1(38) .EQ. SMALL(1)) THEN X* *** CRAY *** X CALL I1MCRY(SMALL(1), J, 8285, 8388608, 0) X SMALL(2) = 0 X CALL I1MCRY(LARGE(1), J, 24574, 16777215, 16777215) X CALL I1MCRY(LARGE(2), J, 0, 16777215, 16777214) X CALL I1MCRY(RIGHT(1), J, 16291, 8388608, 0) X RIGHT(2) = 0 X CALL I1MCRY(DIVER(1), J, 16292, 8388608, 0) X DIVER(2) = 0 X CALL I1MCRY(LOG10(1), J, 16383, 10100890, 8715215) X CALL I1MCRY(LOG10(2), J, 0, 16226447, 9001388) X ELSE X WRITE(*,9000) X STOP 779 X END IF X ELSE X WRITE(*,9000) X STOP 779 X END IF X END IF X SC = 987 X END IF X* SANITY CHECK X IF (DMACH(4) .GE. 1.0D0) STOP 778 X IF (I .LT. 1 .OR. I .GT. 5) THEN X WRITE(*,*) 'D1MACH(I): I =',I,' is out of bounds.' X STOP X END IF X D1MACH = DMACH(I) X RETURN X 9000 FORMAT(/' Adjust D1MACH by uncommenting data statements'/ X *' appropriate for your machine.') X* /* Standard C source for D1MACH -- remove the * in column 1 */ X*#include X*#include X*#include X*double d1mach_(long *i) X*{ X* switch(*i){ X* case 1: return DBL_MIN; X* case 2: return DBL_MAX; X* case 3: return DBL_EPSILON/FLT_RADIX; X* case 4: return DBL_EPSILON; X* case 5: return log10(FLT_RADIX); X* } X* fprintf(stderr, "invalid argument: d1mach(%ld)\n", *i); X* exit(1); return 0; /* some compilers demand return values */ X*} X END X SUBROUTINE I1MCRY(A, A1, B, C, D) X**** SPECIAL COMPUTATION FOR OLD CRAY MACHINES **** X INTEGER A, A1, B, C, D X A1 = 16777216*B + C X A = 16777216*A1 + D X END END_OF_FILE if test 7515 -ne `wc -c <'d1mach.f'`; then echo shar: \"'d1mach.f'\" unpacked with wrong size! fi # end of 'd1mach.f' fi if test -f 'delcau.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'delcau.f'\" else echo shar: Extracting \"'delcau.f'\" \(4979 characters\) sed "s/^X//" >'delcau.f' <<'END_OF_FILE' X SUBROUTINE DELCAU(CAUCHY,OVERCH,OVERFL,ITNUM ,MAXEXP, X $ N ,NUNIT ,OUTPUT,BETA ,CAULEN, X $ DELTA ,EPSMCH,MAXSTP,NEWLEN,SQRTZ , X $ A ,DELF ,SCALEX,WV1 ) XC XC FEB. 23, 1992 XC XC THIS SUBROUTINE ESTABLISHES AN INITIAL TRUST REGION, DELTA, XC IF ONE IS NOT SPECIFIED BY THE USER AND FINDS THE LENGTH OF XC THE SCALED CAUCHY STEP, CAULEN, AT EACH STEP IF THE DOUBLE XC DOGLEG OPTION IS BEING USED. XC XC THE USER HAS TWO CHOICES FOR THE INITIAL TRUST REGION: XC 1) BASED ON THE SCALED CAUCHY STEP XC 2) BASED ON THE SCALED NEWTON STEP XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION MAXSTP ,NEWLEN X INTEGER OUTPUT X DIMENSION A(N,N) ,DELF(N) ,SCALEX(N) ,WV1(N) X LOGICAL CAUCHY ,OVERCH ,OVERFL X DATA ZERO,THREE,TEN/0.0D0,3.0D0,10.0D0/ XC X OVERFL=.FALSE. X EPS=TEN**(-MAXEXP) XC XC IF DELTA IS NOT GIVEN EVALUATE IT USING EITHER THE CAUCHY XC STEP OR THE NEWTON STEP AS SPECIFIED BY THE USER. XC XC THE SCALED CAUCHY LENGTH, CAULEN, IS REQUIRED IN TWO CASES. XC 1) WHEN SELECTED AS THE CRITERION FOR THE INITIAL DELTA XC 2) IN THE DOUBLE DOGLEG STEP REGARDLESS OF (1) XC X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X1 FORMAT(T3,'*',T74,'*') X WRITE(NUNIT,1) X WRITE(NUNIT,2) X2 FORMAT(T3,'*',4X,'DETERMINATION OF SCALED CAUCHY', X $ ' STEP LENGTH, CAULEN',T74,'*') X END IF XC XC FIND FACTOR WHICH GIVES CAUCHY POINT WHEN MULTPLYING XC STEEPEST DESCENT DIRECTION, DELF. XC XC CAULEN= ZETA**1.5/BETA XC = SQRTZ**3/BETA XC X DO 100 I=1,N X WV1(I)=DELF(I)/SCALEX(I) X100 CONTINUE X CALL TWONRM(OVERFL,MAXEXP,N,EPSMCH,SQRTZ,WV1) X IF(OVERFL) THEN X CAULEN=TEN**MAXEXP X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,3) SQRTZ X3 FORMAT(T3,'*',7X,'ZETA SET TO ',1PD11.3,' TO' X $ ' AVOID OVERFLOW',T74,'*') X WRITE(NUNIT,4) CAULEN X4 FORMAT(T3,'*',7X,'SCALED CAUCHY LENGTH, CAULEN ', X $ 'SET TO',1PD9.2,' TO AVOID OVERFLOW',T74,'*') X IF(ITNUM.EQ.1) THEN X WRITE(NUNIT,5) X5 FORMAT(T3,'*',7X,'THE PROBLEM SHOULD BE RESCALED', X $ ' OR A NEW STARTING POINT CHOSEN',T74,'*') X WRITE(NUNIT,6) X6 FORMAT(T3,'*',7X,'EXECUTION CONTINUES WITH', X $ ' SUBSTITUTIONS AS LISTED ABOVE',T74,'*') X END IF X END IF X ELSE X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,7) SQRTZ X7 FORMAT(T3,'*',7X,'SQUARE ROOT OF ZETA, SQRTZ: ', X $ 1PD12.3,T74,'*') X END IF X END IF XC XC NOTE: THE LOWER TRIANGLE OF MATRIX A NOW CONTAINS THE XC TRANSPOSE OF R WHERE A=QR. XC X BETA=ZERO X DO 200 I=1,N X TEMP=ZERO X DO 300 J=I,N X IF(OVERCH) THEN X IF(LOG10(ABS(A(J,I))+EPS)+LOG10(ABS(DELF(J))+EPS). X $ GT.MAXEXP) THEN X CAULEN=SQRT(EPSMCH) X GO TO 301 X END IF X END IF X TEMP=TEMP+A(J,I)*DELF(J)/(SCALEX(J)*SCALEX(J)) X300 CONTINUE X BETA=BETA+TEMP*TEMP X200 CONTINUE X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,8) BETA X8 FORMAT(T3,'*',7X,'BETA: ',1PD11.3,6X,'NOTE: ', X $ 'CAULEN=ZETA**1.5/BETA',T74,'*') X WRITE(NUNIT,1) X END IF XC XC AVOID OVERFLOWS IN FINDING CAULEN. XC X IF(THREE*LOG10(SQRTZ+EPS)-LOG10(BETA+EPS).LT.MAXEXP X $ .AND.(.NOT.OVERFL).AND.BETA.NE.ZERO) THEN XC XC NORMAL DETERMINATION. XC X CAULEN=SQRTZ*SQRTZ*SQRTZ/BETA XC XC THIS STEP AVOIDS DIVIDE BY ZERO IN DOGLEG IN THE XC (RARE) CASE WHERE DELF(I)=0 FOR ALL I BUT THE XC POINT IS NOT YET A SOLUTION - MOST LIKELY A BAD XC STARTING ESTIMATE. XC X CAULEN=MAX(CAULEN,TEN**(-MAXEXP)) XC X ELSE XC XC SUBSTITUTION TO AVOID OVERFLOW. XC X CAULEN=TEN**MAXEXP X END IF X301 CONTINUE X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,9) CAULEN X9 FORMAT(T3,'*',7X,'SCALED CAUCHY LENGTH, CAULEN: ', X $ 1PD12.3,T74,'*') X END IF XC XC ESTABLISH INITIAL TRUST REGION IF NEEDED. XC X IF(DELTA.LT.ZERO) THEN XC XC USE DISTANCE TO CAUCHY POINT OR LENGTH OF NEWTON STEP. XC X IF(CAUCHY) THEN X DELTA=MIN(CAULEN,MAXSTP) X ELSE X DELTA=MIN(NEWLEN,MAXSTP) X END IF X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,10) DELTA X10 FORMAT(T3,'*',7X,'INITIAL TRUST REGION SIZE, DELTA: ', X $ 1PD12.3,T74,'*') X END IF X END IF X RETURN XC XC LAST CARD OF SUBROUTINE DELCAU. XC X END END_OF_FILE if test 4979 -ne `wc -c <'delcau.f'`; then echo shar: \"'delcau.f'\" unpacked with wrong size! fi # end of 'delcau.f' fi if test -f 'deufls.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'deufls.f'\" else echo shar: Extracting \"'deufls.f'\" \(23007 characters\) sed "s/^X//" >'deufls.f' <<'END_OF_FILE' X SUBROUTINE DEUFLS(ABORT ,DEUFLH,GEOMS ,OVERCH,OVERFL, X $ QNFAIL,QRSING,RESTRT,SCLFCH,SCLXCH, X $ ACPCOD,ACPTCR,CONTYP,ITNUM ,JUPDM , X $ MAXEXP,MAXLIN,N ,NFUNC ,NUNIT , X $ OUTPUT,QNUPDM,STOPCR,ALPHA ,CONFAC, X $ DELFTS,EPSMCH,FCNMAX,FCNNEW,FCNOLD, X $ LAMBDA,NEWMAX,SBRNRM,SIGMA ,A , X $ ASTORE,BOUNDL,BOUNDU,DELF ,FVEC , X $ HHPI ,JAC ,RDIAG ,RHS ,S , X $ SBAR ,SCALEF,SCALEX,SN ,WV2 , X $ XC ,XPLUS ,FVECEV) XC XC FEB. 23, 1992 XC XC THIS SUBROUTINE CONDUCTS A LINE SEARCH IN THE NEWTON XC DIRECTION IF NO CONSTRAINTS ARE VIOLATED. IF THE FIRST XC TRIAL IS A FAILURE THERE ARE TWO TYPES OF LINE SEARCH XC AVAILABLE. XC 1) REDUCE THE RELAXATION FACTOR, LAMBDA, TO XC SIGMA*LAMBDA WHERE SIGMA IS USER-SPECIFIED XC (GEOMETRIC LINE SEARCH) XC 2) AT THE FIRST STEP MINIMIZE A QUADRATIC THROUGH XC THE OBJECTIVE FUNCTION AT THE CURRENT POINT AND XC TRIAL ESTIMATE (WHICH MUST BE A FAILURE) WITH XC INITIAL SLOPE DELFTS. AT SUBSEQUENT STEPS MINI- XC MIZE A CUBIC THROUGH THE OBJECTIVE FUNCTION AT XC THE TWO MOST RECENT FAILURES AND THE CURRENT XC POINT, AGAIN USING THE INITIAL SLOPE, DELFTS. XC XC CONVIO INDICATES A CONSTRAINT VIOLATION BY ONE OR MORE XC COMPONENTS XC FRSTST INDICATES THE FIRST STEP IN THE LINE SEARCH. XC XC RATIO RATIO OF PROPOSED STEP LENGTH IN (I)TH DIRECTION XC TO DISTANCE FROM (I)TH COMPONENT TO BOUNDARY XC VIOLATED XC RATIOM MINIMUM OF RATIOS FOR ALL CONSTAINTS VIOLATED XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION JAC(N,N) ,LAMBDA ,LAMPRE ,LAMTMP , X $ NEWMAX X INTEGER ACPCOD ,ACPTCR ,CONTYP ,OUTPUT , X $ STOPCR ,QNUPDM X DIMENSION A(N,N) ,ASTORE(N,N),BOUNDL(N),BOUNDU(N), X $ FVEC(N) ,HHPI(N) ,RDIAG(N) ,RHS(N) , X $ S(N) ,DELF(N) ,SBAR(N) ,SCALEF(N), X $ SCALEX(N),SN(N) ,WV2(N) ,XC(N) , X $ XPLUS(N) X LOGICAL ABORT ,CONVIO ,DEUFLH ,FRSTST , X $ GEOMS ,OVERCH ,OVERFL ,QNFAIL , X $ QRSING ,RESTRT ,SCLFCH ,SCLXCH , X $ WRNSUP X COMMON/NNES_2/WRNSUP X EXTERNAL FVECEV X DATA ZERO,POINT1,POINT5,ONE,TWO,THREE,TEN /0.0D0,0.1D0,0.5D0, X $ 1.0D0,2.0D0,3.0D0,10.0D0/ XC X FRSTST=.TRUE. X OVERFL=.FALSE. X EPS=TEN**(-MAXEXP) X DO 100 K=1,MAXLIN X RATIOM=ONE XC X CONVIO=.FALSE. XC XC FIND TRIAL POINT AND CHECK IF CONSTRAINTS VIOLATED (IF XC CONTYP IS NOT EQUAL TO ZERO). XC X DO 200 I=1,N XC XC NOTE: WV2 MARKS VIOLATIONS. WV2(I) CHANGES TO XC 1 FOR LOWER BOUND VIOLATIONS AND TO 2 FOR XC FOR UPPER BOUND VIOLATIONS. CONSTRAINT VIOL- XC ATIONS CAN ONLY OCCUR AT THE FIRST STEP. XC X WV2(I)=-ONE X XPLUS(I)=XC(I)+LAMBDA*SN(I) X IF(CONTYP.GT.0.AND.FRSTST) THEN X IF(XPLUS(I).LT.BOUNDL(I)) THEN X CONVIO=.TRUE. X WV2(I)=ONE X ELSEIF(XPLUS(I).GT.BOUNDU(I)) THEN X CONVIO=.TRUE. X WV2(I)=TWO X ELSE X WV2(I)=-ONE X END IF X END IF X200 CONTINUE XC XC IF CONSTRAINTS ARE VIOLATED FIRST REDUCE THE STEP XC SIZES FOR THE VIOLATING COMPONENTS TO OBTAIN A XC FEASIBLE POINT. IF THE DIRECTION TO THIS MODIFIED XC POINT IS NOT A DESCENT DIRECTION OR IF THE MODIFIED XC STEP DOES NOT LEAD TO AN ACCEPTABLE POINT THEN RETURN XC TO THE NEWTON DIRECTION AND START A LINE SEARCH AT A XC FEASIBLE POINT WHERE THE COMPONENT WHICH HAS THE XC SMALLEST VALUE OF RATIO (DEFINED BELOW) IS TAKEN TO XC "CONFAC" OF THE DISTANCE TO THE BOUNDARY. DEFAULT XC VALUE OF CONFAC IS 0.95. XC X IF(CONVIO) THEN X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X1 FORMAT(T3,'*',T74,'*') X WRITE(NUNIT,2) K X2 FORMAT(T3,'*',10X,'LINE SEARCH STEP:',I3,T74,'*') X WRITE(NUNIT,1) X WRITE(NUNIT,3) LAMBDA X3 FORMAT(T3,'*',10X,'LAMBDA FOR ATTEMPTED STEP: ', X $ 1PD12.3,T74,'*') X WRITE(NUNIT,4) X4 FORMAT(T3,'*',10X,'CONSTRAINT VIOLATED',T74,'*') X WRITE(NUNIT,1) X WRITE(NUNIT,5) X5 FORMAT(T3,'*',10X,'TRIAL ESTIMATES (VIOLATIONS', X $ ' MARKED)',T74,'*') X WRITE(NUNIT,1) X DO 300 I=1,N X IF(WV2(I).GT.ZERO) THEN X WRITE(NUNIT,6) I,XPLUS(I) X6 FORMAT(T3,'*',13X,'XPLUS(',I3,') = ',1PD12.3, X $ 2X,'*',T74,'*') X ELSE X WRITE(NUNIT,7) I,XPLUS(I) X7 FORMAT(T3,'*',13X,'XPLUS(',I3,') = ',1PD12.3, X $ T74,'*') X END IF X300 CONTINUE X END IF X DO 400 I=1,N X IF(WV2(I).GT.ZERO) THEN XC XC FIND RATIO FOR THIS VIOLATING COMPONENT. XC X IF(WV2(I).EQ.ONE) THEN X RATIO=-(XC(I)-BOUNDL(I))/ X $ (XPLUS(I)-XC(I)) X ELSEIF(WV2(I).EQ.TWO) THEN X RATIO=(BOUNDU(I)-XC(I))/ X $ (XPLUS(I)-XC(I)) X END IF XC XC NOTE: THIS LINE IS FOR OUTPUT PURPOSES ONLY. XC X WV2(I)=RATIO XC X RATIOM=MIN(RATIOM,RATIO) X IF(RATIO.GT.POINT5) THEN X S(I)=CONFAC*RATIO*LAMBDA*SN(I) X ELSE XC XC WITHIN BUFFER ZONE - ONLY TAKE 1/2 XC OF THE STEP YOU WOULD TAKE OTHERWISE. XC X S(I)=POINT5*CONFAC*RATIO*LAMBDA*SN(I) X END IF XC XC ESTABLISH MODIFIED TRIAL POINT. XC X XPLUS(I)=XC(I)+S(I) X ELSE XC XC FOR NONVIOLATORS XPLUS REMAINS UNCHANGED BUT XC THE COMPONENT OF S IS LOADED TO CHECK THE XC DIRECTIONAL DERIVATIVE. XC X S(I)=LAMBDA*SN(I) X END IF X400 CONTINUE X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,8) X8 FORMAT(T3,'*',7X,'NEW S AND XPLUS VECTORS', X $ ' (WITH RATIOS FOR VIOLATIONS)',T74,'*') X WRITE(NUNIT,1) X WRITE(NUNIT,9) X9 FORMAT(T3,'*',7X,'NOTE: RATIOS ARE RATIO OF', X $ ' LENGTH TO BOUNDARY FROM CURRENT',T74,'*') X WRITE(NUNIT,10) X10 FORMAT(T3,'*',13X,'X VECTOR TO MAGNITUDE OF', X $ ' CORRESPONDING PROPOSED STEP',T74,'*') X WRITE(NUNIT,1) X DO 500 I=1,N X IF(WV2(I).LT.ZERO) THEN X WRITE(NUNIT,11) I,S(I),I,XPLUS(I) X11 FORMAT(T3,'*',7X,'S(',I3,') = ',1PD12.3,4X, X $ 'XPLUS(',I3,') = ',1PD12.3,T74,'*') X ELSE X WRITE(NUNIT,12) I,S(I),I,XPLUS(I),WV2(I) X12 FORMAT(T3,'*',7X,'S(',I3,') = ',1PD12.3,4X, X $ 'XPLUS(',I3,') = ',1PD12.3,1X,1PD11.3,T74,'*') X END IF X500 CONTINUE X WRITE(NUNIT,1) X WRITE(NUNIT,13) RATIOM X13 FORMAT(T3,'*',7X,'MINIMUM OF RATIOS, RATIOM: ', X $ 1PD12.3,T74,'*') X END IF XC XC CHECK DIRECTIONAL DERIVATIVE FOR MODIFIED POINT, DLFTSM. XC X CALL INNERP(OVERCH,OVERFL,MAXEXP,N ,N ,N , X $ NUNIT ,OUTPUT,DLFTSM,DELF ,S ) X OVERFL=.FALSE. X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,14) DLFTSM X14 FORMAT(T3,'*',7X,'INNER PRODUCT OF DELF AND S FOR', X $ ' MODIFIED S: ',1PD12.3,T74,'*') X END IF XC XC IF INNER PRODUCT IS POSITIVE RETURN TO NEWTON DIRECTION XC AND CONDUCT A LINE SEARCH WITHIN THE FEASIBLE REGION. XC X IF(DLFTSM.GT.ZERO) THEN X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,15) X15 FORMAT(T3,'*',7X,'DELFTS > 0',' START LINE', X $ ' SEARCH AT LAMBDA=CONFAC*LAMBDA*RATIOM',T74,'*') X WRITE(NUNIT,16) X16 FORMAT(T3,'*',7X,'NOTE: NO TRIAL POINT WAS', X $ ' EVALUATED AT THIS STEP OF LINE SEARCH',T74,'*') X END IF XC XC THE STARTING POINT IS SET AT JUST INSIDE THE MOST XC VIOLATED BOUNDARY. XC X LAMBDA=CONFAC*RATIOM*LAMBDA XC XC LAMBDA IS ALREADY SET - SKIP NORMAL PROCEDURE. XC X GO TO 101 X END IF XC X END IF XC XC NO CONSTRAINTS VIOLATED - EVALUATE RESIDUAL VECTOR XC AT NEW POINT. XC X CALL FVECEV(OVERFL,N,FVEC,XPLUS) X NFUNC=NFUNC+1 XC XC CHECK FOR OVERFLOW IN FUNCTION VECTOR EVALUATION. XC IF SO, REDUCE STEP LENGTH AND CONTINUE LINE SEARCH. XC X IF(OVERFL) THEN XC X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,17) X17 FORMAT(T3,'*',7X,'OVERFLOW IN FUNCTION VECTOR', X $ ' - STEP LENGTH REDUCED',T74,'*') XC XC FORCE STEP TO BE WITHIN CONSTRAINTS - DON'T CALL XC THIS THE FIRST STEP, I.E. FRSTST STAYS AT TRUE. XC X END IF X IF(CONVIO) THEN X LAMBDA=RATIOM*CONFAC*LAMBDA X ELSE X LAMBDA=SIGMA*LAMBDA X END IF XC XC LAMBDA IS ALREADY SET - SKIP NORMAL PROCEDURE. XC X GO TO 101 X END IF XC XC EVALUATE (POSSIBLY SCALED) OBJECTIVE FUNCTION AT NEW POINT. XC X CALL FCNEVL(OVERFL,MAXEXP,N ,NUNIT ,OUTPUT, X $ EPSMCH,FCNNEW,FVEC ,SCALEF,WV2 ) X IF(OVERFL) THEN XC X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,18) X18 FORMAT(T3,'*',7X,'OVERFLOW IN OBJECTIVE FUNCTION', X $ ' - STEP LENGTH REDUCED',T74,'*') XC XC FORCE STEP TO BE WITHIN CONSTRAINTS - DON'T CALL XC THIS THE FIRST STEP, I.E. FRSTST STAYS AT TRUE. XC X END IF X IF(CONVIO) THEN X LAMBDA=RATIOM*CONFAC*LAMBDA X ELSE X LAMBDA=SIGMA*LAMBDA X END IF X GO TO 101 X END IF XC XC IF DEUFLHARD'S METHOD IS BEING USED FOR EITHER XC RELAXATION FACTOR INITIALIZATION OR THE SECOND XC ACCEPTANCE CRITERION THEN EVALUATE SBAR. EVALU- XC ATION METHOD DEPENDS UPON WHETHER THE JACOBIAN XC WAS PERTURBED IN THE SOLUTION OF THE LINEAR SYSTEM. XC LOGICAL VARIABLE QRSING IS TRUE IF PERTURBATION XC TOOK PLACE. XC X IF(DEUFLH.OR.ACPTCR.EQ.12) THEN X IF(QRSING) THEN XC XC FORM -J^F AS RIGHT HAND SIDE - METHOD DEPENDS ON XC WHETHER QNUPDM EQUALS 0 OR 1 IF A QUASI-NEWTON XC UPDATE IS BEING USED. IF JUPDM IS 0 THEN THE NEWTON XC STEP HAS BEEN FOUND IN SUBROUTINE NSTPUN. XC X IF(JUPDM.EQ.0.OR.QNUPDM.EQ.0) THEN XC XC UNSCALED JACOBIAN IN MATRIX JAC. XC X DO 600 I=1,N X IF(SCLFCH) THEN X WV2(I)=-FVEC(I)*SCALEF(I)*SCALEF(I) X ELSE X WV2(I)=-FVEC(I) X END IF X600 CONTINUE X CALL ATBMUL(N,N,1,1,N,N,JAC,WV2,RHS) X ELSE XC XC R IN UPPER TRIANGLE OF A PLUS RDIAG AND Q^ IN JAC XC - FROM QR DECOMPOSITION OF SCALED JACOBIAN. XC X DO 700 I=1,N X WV2(I)=ZERO X DO 800 J=1,N X WV2(I)=WV2(I)-JAC(I,J)*FVEC(J)*SCALEF(J) X800 CONTINUE X700 CONTINUE X RHS(1)=RDIAG(1)*WV2(1) X DO 900 J=2,N X RHS(J)=ZERO X DO 1000 I=1,J-1 X RHS(J)=RHS(J)+A(I,J)*WV2(I) X1000 CONTINUE X RHS(J)=RHS(J)+RDIAG(J)*WV2(J) X900 CONTINUE X END IF X CALL CHSOLV(OVERCH,OVERFL,MAXEXP,N ,NUNIT , X $ OUTPUT,A ,RHS ,SBAR ,WV2 ) X ELSE XC XC RIGHT HAND SIDE IS -FVEC. XC X IF(QNUPDM.EQ.0.OR.JUPDM.EQ.0) THEN XC XC QR DECOMPOSITION OF SCALED JACOBIAN STORED IN XC ASTORE. XC X DO 1100 I=1,N X SBAR(I)=-FVEC(I)*SCALEF(I) X1100 CONTINUE X CALL QRSOLV(OVERCH,OVERFL,MAXEXP,N ,NUNIT , X $ OUTPUT,ASTORE,HHPI ,RDIAG ,SBAR ) X ELSE XC XC SET UP RIGHT HAND SIDE - MULTIPLY -FVEC BY Q^ XC (STORED IN JAC). XC X DO 1200 I=1,N X WV2(I)=-FVEC(I)*SCALEF(I) X1200 CONTINUE X CALL AVMUL(N,N,N,N,JAC,WV2,SBAR) X CALL RSOLV(OVERCH,OVERFL,MAXEXP,N ,NUNIT , X $ OUTPUT,A ,RDIAG ,SBAR ) X END IF X END IF XC XC NORM OF SCALED SBAR IS NEEDED FOR SECOND ACCEPTANCE TEST. XC X IF(ACPTCR.EQ.12) THEN X DO 1300 I=1,N X WV2(I)=SCALEX(I)*SBAR(I) X1300 CONTINUE X CALL TWONRM(OVERFL,MAXEXP,N,EPSMCH,SBRNRM,WV2) X END IF X END IF XC X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,2) K X WRITE(NUNIT,1) X WRITE(NUNIT,3) LAMBDA X WRITE(NUNIT,1) X IF(.NOT.CONVIO) THEN X WRITE(NUNIT,19) X19 FORMAT(T3,'*',10X,'NEW COMPONENT/FCN VECTORS', X $ ' (XPLUS(I)=XC(I)+LAMBDA*SN(I))',T74,'*') X ELSE X WRITE(NUNIT,20) X20 FORMAT(T3,'*',10X,'NEW FUNCTION VECTORS', X $ ' AT MODIFIED POINT',T74,'*') X END IF X WRITE(NUNIT,1) X DO 1400 I=1,N X WRITE(NUNIT,21) I,XPLUS(I),I,FVEC(I) X21 FORMAT(T3,'*',10X,'XPLUS(',I3,') = ',1PD12.3, X $ 5X,'FVEC(',I3,') = ',1PD12.3,T74,'*') X1400 CONTINUE X WRITE(NUNIT,1) X IF(.NOT.SCLFCH) THEN X WRITE(NUNIT,22) FCNNEW X22 FORMAT(T3,'*',10X,'OBJECTIVE FUNCTION VALUE', X $ ' AT XPLUS: .........'1PD12.3,T74,'*') X ELSE X WRITE(10,23) FCNNEW X23 FORMAT(T3,'*',10X,'SCALED OBJECTIVE FUNCTION VALUE', X $ ' AT XPLUS: ..'1PD12.3,T74,'*') X END IF X WRITE(NUNIT,24) FCNMAX+ALPHA*LAMBDA*DELFTS X24 FORMAT(T3,'*',10X,'FCNMAX+ALPHA*LAMBDA*DELFTS:', X $ ' ................',1PD12.3,T74,'*') X IF(DEUFLH.OR.ACPTCR.EQ.12) THEN X IF(ITNUM .GT.0) THEN X IF(.NOT.SCLXCH) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,25) X25 FORMAT(T3,'*',10X,'DEUFLHARD SBAR VECTOR', X $ T74,'*') X WRITE(NUNIT,1) X DO 1500 I=1,N X WRITE(NUNIT,26) I,SBAR(I) X26 FORMAT(T3,'*',10X,'SBAR(',I3,') = ', X $ 1PD12.3,T74,'*') X1500 CONTINUE X ELSE X WRITE(NUNIT,1) X WRITE(NUNIT,27) X27 FORMAT(T3,'*',10X,'DEUFLHARD SBAR VECTOR', X $ 14X,'IN SCALED X UNITS',T74,'*') X WRITE(NUNIT,1) X DO 1600 I=1,N X WRITE(NUNIT,28) I,SBAR(I),I,SCALEX(I)*SBAR(I) X28 FORMAT(T3,'*',10X,'SBAR(',I3,') = ',1PD12.3, X $ 8X,'SBAR(',I3,') = ',1PD12.3,T74,'*') X1600 CONTINUE X END IF X END IF X END IF X IF(ACPTCR.EQ.12) THEN X WRITE(NUNIT,1) X IF(.NOT.SCLXCH) THEN X WRITE(NUNIT,29) SBRNRM X29 FORMAT(T3,'*',10X,'VALUE OF SBRNRM', X $ ' AT XPLUS: ..................'1PD12.3,T74,'*') X ELSE X WRITE(NUNIT,30) SBRNRM X30 FORMAT(T3,'*',10X,'VALUE OF SCALED SBRNRM', X $ ' AT XPLUS: ...........'1PD12.3,T74,'*') X END IF X WRITE(NUNIT,31) NEWMAX X31 FORMAT(T3,'*',10X,'NEWMAX:',' ..............', X $ '......................',1PD12.3,T74,'*') X END IF X END IF XC XC CHECK FOR ACCEPTABLE STEP. XC X IF(FCNNEW.LT.FCNMAX+ALPHA*LAMBDA*DELFTS) THEN X ACPCOD=1 XC XC NOTE: STEP WILL BE ACCEPTED REGARDLESS OF NEXT TEST. XC THIS SECTION IS FOR BOOKKEEPING ONLY. XC X IF(ACPTCR.EQ.12) THEN X IF(SBRNRM.LT.NEWMAX) THEN X ACPCOD=12 X END IF X END IF XC X RETURN X END IF X IF(ACPTCR.EQ.12.AND.SBRNRM.LT.NEWMAX) THEN X ACPCOD=2 X RETURN X END IF XC XC FAILURE OF STEP ACCEPTANCE TEST. XC X IF(CONVIO) THEN X LAMBDA=CONFAC*RATIOM*LAMBDA XC XC LAMBDA IS ALREADY SET - SKIP NORMAL PROCEDURE. XC X GO TO 101 X END IF X IF(LAMBDA.EQ.ZERO) THEN X IF(OUTPUT.GT.0) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,32) X32 FORMAT(T3,'*',7X,'LAMBDA IS 0.0: NO PROGRESS', X $ ' POSSIBLE - CHECK BOUNDS OR START',T74,'*') X END IF X ABORT=.TRUE. X RETURN X END IF X IF(GEOMS) THEN XC XC GEOMETRIC LINE SEARCH XC X LAMBDA=SIGMA*LAMBDA XC X ELSE XC X IF(FRSTST) THEN X FRSTST=.FALSE. XC XC FIND MINIMUM OF QUADRATIC AT FIRST STEP. XC X LAMTMP=-(LAMBDA*LAMBDA)*DELFTS/ X $ (TWO*(FCNNEW-FCNOLD-LAMBDA*DELFTS)) X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,33) LAMTMP X33 FORMAT(T3,'*',13X,'TEMPORARY LAMBDA FROM', X $ ' QUADRATIC MODEL: ',1PD11.3,T74,'*') X END IF XC X ELSE XC XC FIND MINIMUM OF CUBIC AT SUBSEQUENT STEPS. XC X FACTOR=ONE/(LAMBDA-LAMPRE) X IF(LAMBDA*LAMBDA.EQ.ZERO) THEN X LAMBDA=SIGMA*LAMBDA XC XC NOTE: IF THIS LAMBDA**2 WAS ZERO ANY SUBSEQUENT XC LAMBDA**2 WILL ALSO BE ZERO. XC X GO TO 101 X END IF X ACUBIC=FACTOR*((ONE/LAMBDA*LAMBDA)*(FCNNEW-FCNOLD- X $ LAMBDA*DELFTS)-((ONE/LAMPRE*LAMBDA)*(FPLPRE- X $ FCNOLD-LAMPRE*DELFTS))) X BCUBIC=FACTOR*((-LAMPRE/LAMBDA*LAMBDA)*(FCNNEW-FCNOLD- X $ LAMBDA*DELFTS)+((LAMBDA/LAMPRE*LAMBDA)*(FPLPRE- X $ FCNOLD-LAMPRE*DELFTS))) X IF(TWO*LOG10(ABS(BCUBIC)+EPS).GT.DBLE(MAXEXP)) X $ THEN X LAMTMP=SIGMA*LAMBDA X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,34) X34 FORMAT(T3,'*',13X,'POTENTIAL OVERFLOW IN' X $ ' CALCULATING TRIAL LAMBDA FROM',T74,'*') X WRITE(NUNIT,35) X35 FORMAT(T3,'*',13X,'CUBIC MODEL - LAMBDA', X $ ' SET TO SIGMA*LAMBDA',T74,'*') X END IF X ELSE X DISC=BCUBIC*BCUBIC-THREE*ACUBIC*DELFTS X IF(ABS(ACUBIC).LE.EPSMCH) THEN X LAMTMP=-DELFTS/(TWO*BCUBIC) X ELSE X IF(DISC.LT.ZERO) THEN X LAMTMP=SIGMA*LAMBDA X ELSE X LAMTMP=(-BCUBIC+SQRT(DISC))/(THREE*ACUBIC) X END IF X END IF X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,36) LAMTMP X36 FORMAT(T3,'*',13X,'TEMPORARY LAMBDA FROM', X $ ' CUBIC MODEL: .....',1PD11.3,T74,'*') X END IF X END IF X IF(LAMTMP.GT.SIGMA*LAMBDA) THEN X LAMTMP=SIGMA*LAMBDA X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,37) X37 FORMAT(T3,'*',13X,'LAMTMP TOO LARGE - REDUCED', X $ ' TO SIGMA*LAMBDA',T74,'*') X END IF X END IF X END IF X LAMPRE=LAMBDA X FPLPRE=FCNNEW X IF(LAMTMP.LT.POINT1*LAMBDA) THEN X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,38) X38 FORMAT(T3,'*',13X,'LAMTMP TOO SMALL - INCREASED', X $ ' TO 0.1*LAMBDA',T74,'*') X END IF X LAMBDA=POINT1*LAMBDA X ELSE X IF(OUTPUT.GT.4.AND.LAMTMP.NE.SIGMA*LAMBDA) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,39) X39 FORMAT(T3,'*',13X,'LAMTMP WITHIN LIMITS - ', X $ 'LAMBDA SET TO LAMTMP',T74,'*') X END IF X LAMBDA=LAMTMP X END IF X END IF X101 CONTINUE X100 CONTINUE XC XC FAILURE IN LINE SEARCH XC X ACPCOD=0 XC XC IF A QUASI-NEWTON STEP HAS FAILED IN THE LINE SEARCH THEN XC SET QNFAIL TO TRUE ANS RETURN TO SUBROUTINE NNES. THIS WILL XC CAUSE THE JACOBIAN TO BE RE-EVALUATED EXPLICITLY AND A LINE XC SEARCH IN THE NEW DIRECTION CONDUCTED. XC X IF(.NOT.RESTRT) THEN X QNFAIL=.TRUE. X RETURN X END IF XC XC FALL THROUGH MAIN LOOP - WARNING GIVEN. XC X IF(OUTPUT.GT.2.AND.(.NOT.WRNSUP)) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,40) MAXLIN X40 FORMAT(T3,'*',7X,'WARNING: ',I3,' CYCLES COMPLETED', X $ ' IN LINE SEARCH WITHOUT SUCCESS',T74,'*') X END IF X IF(STOPCR.EQ.2.OR.STOPCR.EQ.3) THEN X STOPCR=12 X WRITE(NUNIT,1) X WRITE(NUNIT,41) X41 FORMAT(T3,'*',7X,'STOPPING CRITERION RESET FROM ', X $ '2 TO 12 TO AVOID HANGING',T74,'*') X END IF X RETURN XC XC LAST CARD OF SUBROUTINE DEUFLS. XC X END END_OF_FILE if test 23013 -ne `wc -c <'deufls.f'`; then echo shar: \"'deufls.f'\" unpacked with wrong size! fi # end of 'deufls.f' fi if test -f 'dogleg.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dogleg.f'\" else echo shar: Extracting \"'dogleg.f'\" \(7772 characters\) sed "s/^X//" >'dogleg.f' <<'END_OF_FILE' X SUBROUTINE DOGLEG(FRSTDG,NEWTKN,OVERCH,OVERFL,MAXEXP, X $ N ,NOTRST,NUNIT ,OUTPUT,BETA , X $ CAULEN,DELTA ,ETAFAC,NEWLEN,SQRTZ , X $ DELF ,S ,SCALEX,SN ,SSDHAT, X $ VHAT ) XC XC FEB. 23, 1992 XC XC THIS SUBROUTINE FINDS A TRUST REGION STEP USING THE XC (DOUBLE) DOGLEG METHOD. XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION LAMBDA ,NEWLEN X INTEGER OUTPUT X DIMENSION DELF(N) ,S(N) ,SCALEX(N),SN(N) , X $ SSDHAT(N),VHAT(N) X LOGICAL FRSTDG ,NEWTKN ,OVERCH ,OVERFL , X $ WRNSUP X COMMON/NNES_2/WRNSUP X DATA ZERO,ONE /0.0D0,1.0D0/ XC X OVERFL=.FALSE. XC X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X1 FORMAT(T3,'*',70X,'*') X WRITE(NUNIT,2) NOTRST,DELTA X2 FORMAT(T3,'*',4X,'TRUST REGION STEP:',I6,2X, X $ 'TRUST REGION LENGTH, DELTA:',1PD11.3,2X,'*') X WRITE(NUNIT,1) X WRITE(NUNIT,3) NEWLEN X3 FORMAT(T3,'*',7X,'LENGTH OF NEWTON STEP, NEWLEN: ', X $ 1PD11.3,21X,'*') X END IF XC XC CHECK FOR NEWTON STEP WITHIN TRUST REGION - IF SO USE XC NEWTON STEP. XC X IF(NEWLEN.LE.DELTA) THEN X DO 100 I=1,N X S(I)=SN(I) X100 CONTINUE X NEWTKN=.TRUE. X TEMP=DELTA X DELTA=NEWLEN X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,4) X4 FORMAT(T3,'*',7X,'NEWTON STEP WITHIN ACCEPTABLE RANGE', X $ ' ( <= THAN DELTA)',11X,'*') X IF(TEMP.EQ.DELTA) THEN X WRITE(NUNIT,5) DELTA X5 FORMAT(T3,'*',7X,'DELTA STAYS AT LENGTH OF NEWTON', X $ ' STEP: ',1PD11.3,14X,'*') X ELSE X WRITE(NUNIT,6) X6 FORMAT(T3,'*',7X,'DELTA SET TO LENGTH OF NEWTON', X $ ' STEP',29X,'*') X END IF X WRITE(NUNIT,1) X WRITE(NUNIT,7) X7 FORMAT(T3,'*',7X,'FULL NEWTON STEP ATTEMPTED',37X,'*') X END IF X RETURN X ELSE XC XC NEWTON STEP NOT WITHIN TRUST REGION - APPLY (DOUBLE) XC DOGLEG PROCEDURE. (IF ETAFAC EQUALS 1.0 THEN THE SINGLE XC DOGLEG PROCEDURE IS BEING APPLIED). XC X NEWTKN=.FALSE. X IF(FRSTDG) THEN XC XC SPECIAL SECTION FOR FIRST DOGLEG STEP - CALCULATES XC CAUCHY POINT (MINIMIZER OF MODEL FUNCTION IN STEEPEST XC DESCENT DIRECTION OF THE OBJECTIVE FUNCTION). XC X FRSTDG=.FALSE. X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,1) X IF(ETAFAC.EQ.ONE) THEN X WRITE(NUNIT,8) X8 FORMAT(T3,'*',7X,'FIRST SINGLE DOGLEG STEP', X $ 39X,'*') X ELSE X WRITE(NUNIT,9) X9 FORMAT(T3,'*',7X,'FIRST DOUBLE DOGLEG STEP', X $ 39X,'*') X END IF X WRITE(NUNIT,1) X WRITE(NUNIT,10) X10 FORMAT(T3,'*',10X,'SCALED CAUCHY STEP',42X,'*') X WRITE(NUNIT,1) X END IF XC XC NOTE: BETA AND SQRTZ WERE CALCULATED IN SUBROUTINE DELCAU. XC X ZETA=SQRTZ*SQRTZ XC XC FIND STEP TO CAUCHY POINT. XC X FACTOR=-(ZETA/BETA) X DO 200 I=1,N X SSDHAT(I)=FACTOR*(DELF(I)/SCALEX(I)) X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,11) I,SSDHAT(I) X11 FORMAT(T3,'*',13X,'SSDHAT(',I3,') = ',1PD12.3, X $ 31X,'*') X END IF X200 CONTINUE X CALL INNERP(OVERCH,OVERFL,MAXEXP,N,N,N ,NUNIT , X $ OUTPUT,DELFTS,DELF ,SN ) X OVERFL=.FALSE. XC XC PROTECT AGAINST (RARE) CASE WHEN CALCULATED DIRECTIONAL XC DERIVATIVE EQUALS ZERO. XC X IF(DELFTS.NE.ZERO) THEN XC XC STANDARD EXECUTION. XC X GAMMA=(ZETA/ABS(DELFTS))*(ZETA/BETA) X ETA=ETAFAC+(ONE-ETAFAC)*GAMMA X ELSE X IF(OUTPUT.GT.1.AND.(.NOT.WRNSUP)) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,12) X12 FORMAT(T3,'*',4X,'WARNING: DELFTS=0; ETA SET', X $ ' TO 1.0 TO AVOID DIVISION BY ZERO',8X,'*') X END IF X ETA=ONE X END IF X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,13) ETA X13 FORMAT(T3,'*',10X,'ETA = ',1PD11.3,43X,'*') X WRITE(NUNIT,1) X WRITE(NUNIT,14) X14 FORMAT(T3,'*',10X,'VHAT VECTOR VHAT(I)=ETA*', X $ 'SN(I)*SCALEX(I)-SSDHAT(I)',7X,'*') X WRITE(NUNIT,1) X END IF X DO 300 I=1,N X VHAT(I)=ETA*SCALEX(I)*SN(I)-SSDHAT(I) X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,15) I,VHAT(I) X15 FORMAT(T3,'*',13X,'VHAT(',I3,') = ',1PD12.3, X $ 33X,'*') X END IF X300 CONTINUE X END IF XC XC ETA*NEWLEN <= DELTA MEANS TAKE STEP IN NEWTON DIRECTION XC TO TRUST REGION BOUNDARY. XC X IF(ETA*NEWLEN.LE.DELTA) THEN X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,16) X16 FORMAT(T3,'*',10X,'ETA*NEWLEN <= DELTA S(I)', X $ '= (DELTA/NEWLEN)*SN(I)',10X,'*') X END IF X DO 400 I=1,N X S(I)=(DELTA/NEWLEN)*SN(I) X400 CONTINUE X ELSE XC XC DISTANCE TO CAUCHY POINT >= DELTA MEANS TAKE STEP IN XC STEEPEST DESCENT DIRECTION TO TRUST REGION BOUNDARY. XC X IF(CAULEN.GE.DELTA) THEN X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,17) X17 FORMAT(T3,'*',10X,'CAULEN >= DELTA S(I)', X $ '=(DELTA/CAULEN)*(SSDHAT(I)/SCALEX(I))',1X,'*') X END IF X DO 500 I=1,N X S(I)=(DELTA/CAULEN)*(SSDHAT(I)/SCALEX(I)) X500 CONTINUE X ELSE XC XC TAKE (DOUBLE) DOGLEG STEP. XC X CALL INNERP(OVERCH,OVERFL,MAXEXP,N,N,N ,NUNIT , X $ OUTPUT,TEMP ,SSDHAT,VHAT ) X CALL INNERP(OVERCH,OVERFL,MAXEXP,N,N,N ,NUNIT , X $ OUTPUT,TEMPV ,VHAT ,VHAT ) X OVERFL=.FALSE. X LAMBDA=(-TEMP+SQRT(TEMP*TEMP-TEMPV*(CAULEN*CAULEN X $ -DELTA*DELTA)))/TEMPV X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,18) X18 FORMAT(T3,'*',10X,'S(I)=(SSDHAT(I)+LAMBDA*VHAT(I))', X $ '/SCALEX(I)',19X,'*') X WRITE(NUNIT,1) X WRITE(NUNIT,19) LAMBDA X19 FORMAT(T3,'*',10X,'WHERE LAMBDA = ',1PD12.3,33X,'*') X END IF X DO 600 I=1,N X S(I)=(SSDHAT(I)+LAMBDA*VHAT(I))/SCALEX(I) X600 CONTINUE X END IF X END IF X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,1) X WRITE(NUNIT,20) X20 FORMAT(T3,'*',10X,'REVISED STEP FROM SUBROUTINE', X $ ' DOGLEG',25X,'*') X WRITE(NUNIT,1) X DO 700 I=1,N X WRITE(NUNIT,21) I,S(I) X21 FORMAT(T3,'*',13X,'S(',I3,') = ',1PD12.3,36X,'*') X700 CONTINUE X END IF X END IF X RETURN X END END_OF_FILE if test 7772 -ne `wc -c <'dogleg.f'`; then echo shar: \"'dogleg.f'\" unpacked with wrong size! fi # end of 'dogleg.f' fi if test -f 'ex1.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'ex1.f'\" else echo shar: Extracting \"'ex1.f'\" \(3556 characters\) sed "s/^X//" >'ex1.f' <<'END_OF_FILE' X PROGRAM EX1 XC XC ROSENBROCK'S BANANA XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X PARAMETER ( MGLL= 10, X $ N= 2, X $ NUNIT= 10) X DOUBLE PRECISION X $ JAC(N,N) ,LAM0 ,MSTPF ,NSTTOL X INTEGER ACPTCR ,OUTPUT ,QNUPDM ,STOPCR , X $ SUPPRS ,TRMCOD ,TRUPDM X DIMENSION A(N,N) ,BOUNDL(N) ,BOUNDU(N) ,DELF(N) , X $ FSAVE(N) ,FTRACK(0:MGLL-1) ,FVEC(N) , X $ FVECC(N) ,H(N,N) ,HHPI(N) ,PLEE(N,N), X $ RDIAG(N) ,S(N) ,SBAR(N) ,SCALEF(N), X $ SCALEX(N) ,SN(N) ,SSDHAT(N) , X $ STRACK(0:MGLL-1) ,VHAT(N) ,WV1(N) , X $ WV2(N) ,WV3(N) ,WV4(N) ,XC(N) , X $ XPLUS(N) ,XSAVE(N) X LOGICAL ABSNEW ,BYPASS ,CAUCHY ,DEUFLH , X $ GEOMS ,LINESR ,MATSUP ,NEWTON , X $ OVERCH ,WRNSUP X CHARACTER*6 HELP X EXTERNAL FCN,JACOB X COMMON/NNES_1/MATSUP X COMMON/NNES_2/WRNSUP X COMMON/NNES_3/BYPASS X COMMON/NNES_4/NFETOT X OPEN(UNIT=NUNIT,FILE='EX1.OUT',STATUS='UNKNOWN') X XC(1)=-1.2D0 X XC(2)=1.0D0 X CALL SETUP(ABSNEW ,CAUCHY ,DEUFLH ,GEOMS ,LINESR , X $ NEWTON ,OVERCH ,ACPTCR ,ITSCLF ,ITSCLX , X $ JACTYP ,JUPDM ,MAXEXP ,MAXIT ,MAXNS , X $ MAXQNS ,MINQNS ,N ,NARMIJ ,NIEJEV , X $ NJACCH ,OUTPUT ,QNUPDM ,STOPCR ,SUPPRS , X $ TRUPDM ,ALPHA ,CONFAC ,DELTA ,DELFAC , X $ EPSMCH ,ETAFAC ,FDTOLJ ,FTOL ,LAM0 , X $ MSTPF ,NSTTOL ,OMEGA ,RATIOF ,SIGMA , X $ STPTOL ,BOUNDL ,BOUNDU ,SCALEF ,SCALEX , X $ HELP) X CALL NNES(ABSNEW ,CAUCHY ,DEUFLH ,GEOMS ,LINESR , X $ NEWTON ,OVERCH ,ACPTCR ,ITSCLF ,ITSCLX , X $ JACTYP ,JUPDM ,MAXEXP ,MAXIT ,MAXNS , X $ MAXQNS ,MGLL ,MINQNS ,N ,NARMIJ , X $ NIEJEV ,NJACCH ,NJETOT ,NUNIT ,OUTPUT , X $ QNUPDM ,STOPCR ,SUPPRS ,TRMCOD ,TRUPDM , X $ ALPHA ,CONFAC ,DELTA ,DELFAC ,EPSMCH , X $ ETAFAC ,FCNNEW ,FDTOLJ ,FTOL ,LAM0 , X $ MSTPF ,NSTTOL ,OMEGA ,RATIOF ,SIGMA , X $ STPTOL ,A ,BOUNDL ,BOUNDU ,DELF , X $ FSAVE ,FTRACK ,FVEC ,FVECC ,H , X $ HHPI ,JAC ,PLEE ,RDIAG ,S , X $ SBAR ,SCALEF ,SCALEX ,SN ,SSDHAT , X $ STRACK ,VHAT ,WV1 ,WV2 ,WV3 , X $ WV4 ,XC ,XPLUS ,XSAVE ,HELP , X $ FCN ,JACOB ) X STOP X END X SUBROUTINE FCN(OVERFL,N,FVEC,XC) X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DIMENSION FVEC(N),XC(N) X COMMON/NNES_4/NFETOT X LOGICAL OVERFL X OVERFL=.FALSE. X NFETOT=NFETOT+1 Xc Xc Rosenbrock Banana Function Xc Xc f1 = 10(x2 - x1**2) Xc f2 = 1 - x1 Xc Xc start: (-1.2,1) Xc (6.39,-0.221) Xc Xc sol'n: (1,1) Xc X FVEC(1)=10.0D0*(XC(2)-XC(1)**2) X FVEC(2)=1.0D0-XC(1) X RETURN X END X SUBROUTINE JACOB(OVERFL,N,JAC,XC) X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION JAC(N,N) X DIMENSION XC(N) X LOGICAL OVERFL X OVERFL=.FALSE. X RETURN X END X END_OF_FILE if test 3556 -ne `wc -c <'ex1.f'`; then echo shar: \"'ex1.f'\" unpacked with wrong size! fi # end of 'ex1.f' fi if test -f 'ex2.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'ex2.f'\" else echo shar: Extracting \"'ex2.f'\" \(4486 characters\) sed "s/^X//" >'ex2.f' <<'END_OF_FILE' X PROGRAM EX2 XC XC XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X PARAMETER ( MGLL= 10, X $ N= 6, X $ NUNIT= 10) X DOUBLE PRECISION X $ JAC(N,N) ,LAM0 ,MSTPF ,NSTTOL X INTEGER ACPTCR ,OUTPUT ,QNUPDM ,STOPCR , X $ SUPPRS ,TRMCOD ,TRUPDM X DIMENSION A(N,N) ,BOUNDL(N) ,BOUNDU(N) ,DELF(N) , X $ FSAVE(N) ,FTRACK(0:MGLL-1) ,FVEC(N) , X $ FVECC(N) ,H(N,N) ,HHPI(N) ,PLEE(N,N), X $ RDIAG(N) ,S(N) ,SBAR(N) ,SCALEF(N), X $ SCALEX(N) ,SN(N) ,SSDHAT(N) , X $ STRACK(0:MGLL-1) ,VHAT(N) ,WV1(N) , X $ WV2(N) ,WV3(N) ,WV4(N) ,XC(N) , X $ XPLUS(N) ,XSAVE(N) X LOGICAL ABSNEW ,BYPASS ,CAUCHY ,DEUFLH , X $ GEOMS ,LINESR ,MATSUP ,NEWTON , X $ OVERCH ,WRNSUP X CHARACTER*6 HELP X EXTERNAL FCN,JACOB X COMMON/NNES_1/MATSUP X COMMON/NNES_2/WRNSUP X COMMON/NNES_3/BYPASS X COMMON/NNES_4/NFETOT X OPEN(UNIT=NUNIT,FILE='EX2.OUT',STATUS='UNKNOWN') X DO 100 I=1,N X XC(I)=1.0D0 X100 CONTINUE X CALL SETUP(ABSNEW ,CAUCHY ,DEUFLH ,GEOMS ,LINESR , X $ NEWTON ,OVERCH ,ACPTCR ,ITSCLF ,ITSCLX , X $ JACTYP ,JUPDM ,MAXEXP ,MAXIT ,MAXNS , X $ MAXQNS ,MINQNS ,N ,NARMIJ ,NIEJEV , X $ NJACCH ,OUTPUT ,QNUPDM ,STOPCR ,SUPPRS , X $ TRUPDM ,ALPHA ,CONFAC ,DELTA ,DELFAC , X $ EPSMCH ,ETAFAC ,FDTOLJ ,FTOL ,LAM0 , X $ MSTPF ,NSTTOL ,OMEGA ,RATIOF ,SIGMA , X $ STPTOL ,BOUNDL ,BOUNDU ,SCALEF ,SCALEX , X $ HELP) X OUTPUT=5 X BOUNDL(3)=0.0D0 X BOUNDL(4)=0.0D0 X BOUNDL(6)=0.0D0 XC XC STOPS PREMATURELY UNLESS THIS ARE SET VERY STIFF XC X NSTTOL=1.0D-16 X STPTOL=1.0D-16 XC XC THIS PARAMETER AFFECTS ILL-CONDITIONED JACOBIAN MECHANISM XC XC THIS WILL WORK, =.FALSE. WILL FAIL XC X BYPASS=.TRUE. X CALL NNES(ABSNEW ,CAUCHY ,DEUFLH ,GEOMS ,LINESR , X $ NEWTON ,OVERCH ,ACPTCR ,ITSCLF ,ITSCLX , X $ JACTYP ,JUPDM ,MAXEXP ,MAXIT ,MAXNS , X $ MAXQNS ,MGLL ,MINQNS ,N ,NARMIJ , X $ NIEJEV ,NJACCH ,NJETOT ,NUNIT ,OUTPUT , X $ QNUPDM ,STOPCR ,SUPPRS ,TRMCOD ,TRUPDM , X $ ALPHA ,CONFAC ,DELTA ,DELFAC ,EPSMCH , X $ ETAFAC ,FCNNEW ,FDTOLJ ,FTOL ,LAM0 , X $ MSTPF ,NSTTOL ,OMEGA ,RATIOF ,SIGMA , X $ STPTOL ,A ,BOUNDL ,BOUNDU ,DELF , X $ FSAVE ,FTRACK ,FVEC ,FVECC ,H , X $ HHPI ,JAC ,PLEE ,RDIAG ,S , X $ SBAR ,SCALEF ,SCALEX ,SN ,SSDHAT , X $ STRACK ,VHAT ,WV1 ,WV2 ,WV3 , X $ WV4 ,XC ,XPLUS ,XSAVE ,HELP , X $ FCN ,JACOB ) X STOP X END X SUBROUTINE FCN(OVERFL,N,FVEC,XC) X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DIMENSION FVEC(N),XC(N) X COMMON/NNES_4/NFETOT X LOGICAL OVERFL X OVERFL=.FALSE. X NFETOT=NFETOT+1 Xc Xc Hiebert's 2nd Chemical Engineering Problem Xc Xc source: Hiebert; Sandia Technical Report #SAND80-0181 Xc Sandia National Laboratories, Albuquerque, NM (1980) Xc Xc f1 = X1 + X2 + X4 - .001 Xc f2 = X5 + X6 -55 Xc f3 = X1 + X2 + X3 +2X5 + X6 - 110.001 Xc f4 = X1 - 0.1X2 Xc f5 = X1 - 10000X3X4 Xc f6 = X5 - 5.5e15X3X6 Xc Xc start: (0,0,0,0,0,0) Xc (1,1,1,1,1,1) Xc (1e-4,1e-3,0,1e-4,55,1e-4) Xc (10,10,10,10,10,10,10) Xc Xc sol'n (8.264e-5,8.264e-4,9.091e-5,9.091e-5,55,1.1e-10) Xc X FVEC(1)=XC(1)+XC(2)+XC(4)-0.001D0 X FVEC(2)=XC(5)+XC(6)-55.0D0 X FVEC(3)=XC(1)+XC(2)+XC(3)+2.0D0*XC(5)+XC(6)-110.001D0 X FVEC(4)=XC(1)-0.1D0*XC(2) X FVEC(5)=XC(1)-1.0D04*XC(3)*XC(4) X FVEC(6)=XC(5)-5.5D15*XC(3)*XC(6) X RETURN X END X SUBROUTINE JACOB(OVERFL,N,JAC,XC) X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION JAC(N,N) X DIMENSION XC(N) X LOGICAL OVERFL X OVERFL=.FALSE. X RETURN X END X END_OF_FILE if test 4486 -ne `wc -c <'ex2.f'`; then echo shar: \"'ex2.f'\" unpacked with wrong size! fi # end of 'ex2.f' fi if test -f 'fcnevl.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'fcnevl.f'\" else echo shar: Extracting \"'fcnevl.f'\" \(1240 characters\) sed "s/^X//" >'fcnevl.f' <<'END_OF_FILE' X SUBROUTINE FCNEVL(OVERFL,MAXEXP,N ,NUNIT ,OUTPUT, X $ EPSMCH,FCNNEW,FVEC ,SCALEF,WV1 ) XC XC FEB. 23, 1992 XC XC THE OBJECTIVE FUNCTION, FCNNEW, DEFINED BY: XC XC FCNNEW:=1/2(SCALEF*FVEC^SCALEF*FVEC) XC XC IS EVALUATED BY THIS SUBROUTINE. XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X INTEGER OUTPUT X DIMENSION FVEC(N) ,SCALEF(N) ,WV1(N) X LOGICAL OVERFL ,WRNSUP X COMMON/NNES_2/WRNSUP X DATA TWO,TEN /2.0D0,10.0D0/ XC X OVERFL=.FALSE. X EPS=TEN**(-MAXEXP) XC X DO 100 I=1,N X WV1(I)=FVEC(I)*SCALEF(I) X100 CONTINUE X CALL TWONRM(OVERFL,MAXEXP,N,EPSMCH,FCNNEW,WV1) XC XC IF AN OVERFLOW WOULD OCCUR SUBSTITUTE A LARGE VALUE XC FOR FCNNEW. XC X IF(OVERFL.OR.TWO*LOG10(FCNNEW+EPS).GT.MAXEXP) THEN X OVERFL=.TRUE. X FCNNEW=TEN**MAXEXP X IF(OUTPUT.GT.2.AND.(.NOT.WRNSUP)) THEN X WRITE(NUNIT,1) X1 FORMAT(T3,'*',T74,'*') X WRITE(NUNIT,2) FCNNEW X2 FORMAT(T3,'*',4X,'WARNING: TO AVOID OVERFLOW', X $ ' OBJECTIVE FUNCTION SET TO: ',1PD11.3,T74,'*') X END IF X RETURN X END IF X FCNNEW=FCNNEW*FCNNEW/TWO X RETURN X END END_OF_FILE if test 1240 -ne `wc -c <'fcnevl.f'`; then echo shar: \"'fcnevl.f'\" unpacked with wrong size! fi # end of 'fcnevl.f' fi if test -f 'fordif.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'fordif.f'\" else echo shar: Extracting \"'fordif.f'\" \(484 characters\) sed "s/^X//" >'fordif.f' <<'END_OF_FILE' X SUBROUTINE FORDIF(OVERFL,J ,N ,DELTAJ,FVEC , X $ FVECJ1,JACFDM,XC ,FVECEV) XC XC FEB. 6, 1991 XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION JACFDM(N,N) X DIMENSION FVEC(N),FVECJ1(N),XC(N) X LOGICAL OVERFL X EXTERNAL FVECEV X CALL FVECEV(OVERFL,N,FVECJ1,XC) X IF(.NOT.OVERFL) THEN X DO 100 I=1,N X JACFDM(I,J)=(FVECJ1(I)-FVEC(I))/DELTAJ X100 CONTINUE X END IF X X RETURN XC XC LAST CARD OF SUBROUTINE FORDIF. XC X END END_OF_FILE if test 484 -ne `wc -c <'fordif.f'`; then echo shar: \"'fordif.f'\" unpacked with wrong size! fi # end of 'fordif.f' fi if test -f 'gradf.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'gradf.f'\" else echo shar: Extracting \"'gradf.f'\" \(2490 characters\) sed "s/^X//" >'gradf.f' <<'END_OF_FILE' X SUBROUTINE GRADF(OVERCH,OVERFL,RESTRT,SCLFCH,SCLXCH,JUPDM , X $ MAXEXP,N ,NUNIT ,OUTPUT,QNUPDM,DELF , X $ FVECC ,JAC ,SCALEF,SCALEX,WV1 ) XC XC FEB. 23, 1992 XC XC THIS SUBROUTINE COMPUTES THE GRADIENT OF THE FUNCTION XC XC F=1/2{SCALEF*FVECC)^(SCALEF*FVECC} XC XC WHICH IS USED AS THE OBJECTIVE FUNCTION FOR MINIMIZATION. XC XC NOTE: WHEN THE FACTORED FORM OF THE JACOBIAN IS UPDATED IN XC QUASI-NEWTON METHODS THE GRADIENT IS UPDATED AS WELL XC IN THE SAME SUBROUTINE - IT IS PRINTED HERE THOUGH. XC IN THESE CASES QNUPDM > 0. XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION JAC(N,N) X INTEGER OUTPUT ,QNUPDM X DIMENSION DELF(N) ,FVECC(N),SCALEF(N),SCALEX(N),WV1(N) X LOGICAL OVERCH ,OVERFL ,RESTRT ,SCLFCH ,SCLXCH XC X IF(RESTRT.OR.JUPDM.EQ.0.OR.QNUPDM.EQ.0) THEN XC XC GRADIENT NOT ALREADY UPDATED: FIND DELF = J^F. XC X DO 100 I=1,N X IF(SCLFCH) THEN X WV1(I)=FVECC(I)*SCALEF(I)*SCALEF(I) X ELSE X WV1(I)=FVECC(I) X END IF X100 CONTINUE X IF(OVERCH) THEN ! CHECK EACH ENTRY INDIVIDUALLY X CALL ATVOV(OVERFL,MAXEXP,N ,NUNIT , X $ OUTPUT,JAC ,WV1 ,DELF ) X ELSE X CALL ATBMUL(N,N,1,1,N,N,JAC,WV1,DELF) X END IF X END IF XC XC PRINT GRADIENT VECTOR, DELF. XC X IF(OUTPUT.GT.3) THEN X IF(.NOT.SCLXCH) THEN X WRITE(NUNIT,1) X1 FORMAT(T3,'*',T74,'*') X IF(.NOT.SCLFCH) THEN X WRITE(NUNIT,2) X2 FORMAT(T3,'*',4X,'GRADIENT OF OBJECTIVE FUNCTION', X $ T74,'*') X ELSE X WRITE(NUNIT,3) X3 FORMAT(T3,'*',4X,'GRADIENT OF SCALED OBJECTIVE', X $ ' FUNCTION',T74,'*') X END IF X WRITE(NUNIT,1) X DO 300 I=1,N X WRITE(NUNIT,4) I,DELF(I) X4 FORMAT(T3,'*',6X,'DELF(',I3,') = ',1PD12.3,T74,'*') X300 CONTINUE X ELSE X WRITE(NUNIT,1) X WRITE(NUNIT,5) X5 FORMAT(T3,'*',4X,'GRADIENT OF OBJECTIVE FUNCTION',9X, X $ 'IN SCALED X UNITS',T74,'*') X WRITE(NUNIT,1) X DO 400 I=1,N X WRITE(NUNIT,6) I,DELF(I),I,SCALEF(I)*SCALEF(I)* X $ DELF(I)/SCALEX(I) X6 FORMAT(T3,'*',6X,'DELF(',I3,') = ',1PD12.3, X $ 9X,'DELF(',I3,') = ',1PD12.3,T74,'*') X400 CONTINUE X END IF X END IF X RETURN XC XC LAST CARD OF SUBROUTINE GRADF. XC X END END_OF_FILE if test 2490 -ne `wc -c <'gradf.f'`; then echo shar: \"'gradf.f'\" unpacked with wrong size! fi # end of 'gradf.f' fi if test -f 'hlpchk.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'hlpchk.f'\" else echo shar: Extracting \"'hlpchk.f'\" \(177 characters\) sed "s/^X//" >'hlpchk.f' <<'END_OF_FILE' X PROGRAM HLPCHK X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X CHARACTER*6 HELP X NUNIT=10 X OPEN(UNIT=NUNIT,FILE='H.OUT',STATUS='UNKNOWN') X HELP='ALL' X CALL OLHELP(NUNIT,HELP) X STOP X END END_OF_FILE if test 177 -ne `wc -c <'hlpchk.f'`; then echo shar: \"'hlpchk.f'\" unpacked with wrong size! fi # end of 'hlpchk.f' fi if test -f 'i1mach.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'i1mach.f'\" else echo shar: Extracting \"'i1mach.f'\" \(9699 characters\) sed "s/^X//" >'i1mach.f' <<'END_OF_FILE' X INTEGER FUNCTION I1MACH(I) X INTEGER I XC XC I1MACH( 1) = THE STANDARD INPUT UNIT. XC I1MACH( 2) = THE STANDARD OUTPUT UNIT. XC I1MACH( 3) = THE STANDARD PUNCH UNIT. XC I1MACH( 4) = THE STANDARD ERROR MESSAGE UNIT. XC I1MACH( 5) = THE NUMBER OF BITS PER INTEGER STORAGE UNIT. XC I1MACH( 6) = THE NUMBER OF CHARACTERS PER CHARACTER STORAGE UNIT. XC INTEGERS HAVE FORM SIGN ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) XC I1MACH( 7) = A, THE BASE. XC I1MACH( 8) = S, THE NUMBER OF BASE-A DIGITS. XC I1MACH( 9) = A**S - 1, THE LARGEST MAGNITUDE. XC FLOATS HAVE FORM SIGN (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) XC WHERE EMIN .LE. E .LE. EMAX. XC I1MACH(10) = B, THE BASE. XC SINGLE-PRECISION XC I1MACH(11) = T, THE NUMBER OF BASE-B DIGITS. XC I1MACH(12) = EMIN, THE SMALLEST EXPONENT E. XC I1MACH(13) = EMAX, THE LARGEST EXPONENT E. XC DOUBLE-PRECISION XC I1MACH(14) = T, THE NUMBER OF BASE-B DIGITS. XC I1MACH(15) = EMIN, THE SMALLEST EXPONENT E. XC I1MACH(16) = EMAX, THE LARGEST EXPONENT E. XC X INTEGER IMACH(16), OUTPUT, SC, SMALL(2) X SAVE IMACH, SC X REAL RMACH X EQUIVALENCE (IMACH(4),OUTPUT), (RMACH,SMALL(1)) X INTEGER I3, J, K, T3E(3) X DATA T3E(1) / 9777664 / X DATA T3E(2) / 5323660 / X DATA T3E(3) / 46980 / XC THIS VERSION ADAPTS AUTOMATICALLY TO MOST CURRENT MACHINES, XC INCLUDING AUTO-DOUBLE COMPILERS. XC TO COMPILE ON OLDER MACHINES, ADD A C IN COLUMN 1 XC ON THE NEXT LINE X DATA SC/0/ XC AND REMOVE THE C FROM COLUMN 1 IN ONE OF THE SECTIONS BELOW. XC CONSTANTS FOR EVEN OLDER MACHINES CAN BE OBTAINED BY XC mail netlib@research.bell-labs.com XC send old1mach from blas XC PLEASE SEND CORRECTIONS TO dmg OR ehg@bell-labs.com. XC XC MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES. XC XC DATA IMACH( 1) / 5 / XC DATA IMACH( 2) / 6 / XC DATA IMACH( 3) / 43 / XC DATA IMACH( 4) / 6 / XC DATA IMACH( 5) / 36 / XC DATA IMACH( 6) / 4 / XC DATA IMACH( 7) / 2 / XC DATA IMACH( 8) / 35 / XC DATA IMACH( 9) / O377777777777 / XC DATA IMACH(10) / 2 / XC DATA IMACH(11) / 27 / XC DATA IMACH(12) / -127 / XC DATA IMACH(13) / 127 / XC DATA IMACH(14) / 63 / XC DATA IMACH(15) / -127 / XC DATA IMACH(16) / 127 /, SC/987/ XC XC MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING XC 32-BIT INTEGER ARITHMETIC. XC XC DATA IMACH( 1) / 5 / XC DATA IMACH( 2) / 6 / XC DATA IMACH( 3) / 7 / XC DATA IMACH( 4) / 6 / XC DATA IMACH( 5) / 32 / XC DATA IMACH( 6) / 4 / XC DATA IMACH( 7) / 2 / XC DATA IMACH( 8) / 31 / XC DATA IMACH( 9) / 2147483647 / XC DATA IMACH(10) / 2 / XC DATA IMACH(11) / 24 / XC DATA IMACH(12) / -127 / XC DATA IMACH(13) / 127 / XC DATA IMACH(14) / 56 / XC DATA IMACH(15) / -127 / XC DATA IMACH(16) / 127 /, SC/987/ XC XC MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. XC XC NOTE THAT THE PUNCH UNIT, I1MACH(3), HAS BEEN SET TO 7 XC WHICH IS APPROPRIATE FOR THE UNIVAC-FOR SYSTEM. XC IF YOU HAVE THE UNIVAC-FTN SYSTEM, SET IT TO 1. XC XC DATA IMACH( 1) / 5 / XC DATA IMACH( 2) / 6 / XC DATA IMACH( 3) / 7 / XC DATA IMACH( 4) / 6 / XC DATA IMACH( 5) / 36 / XC DATA IMACH( 6) / 6 / XC DATA IMACH( 7) / 2 / XC DATA IMACH( 8) / 35 / XC DATA IMACH( 9) / O377777777777 / XC DATA IMACH(10) / 2 / XC DATA IMACH(11) / 27 / XC DATA IMACH(12) / -128 / XC DATA IMACH(13) / 127 / XC DATA IMACH(14) / 60 / XC DATA IMACH(15) /-1024 / XC DATA IMACH(16) / 1023 /, SC/987/ XC X IF (SC .NE. 987) THEN X* *** CHECK FOR AUTODOUBLE *** X SMALL(2) = 0 X RMACH = 1E13 X IF (SMALL(2) .NE. 0) THEN X* *** AUTODOUBLED *** X IF ( (SMALL(1) .EQ. 1117925532 X * .AND. SMALL(2) .EQ. -448790528) X * .OR. (SMALL(2) .EQ. 1117925532 X * .AND. SMALL(1) .EQ. -448790528)) THEN X* *** IEEE *** X IMACH(10) = 2 X IMACH(14) = 53 X IMACH(15) = -1021 X IMACH(16) = 1024 X ELSE IF ( SMALL(1) .EQ. -2065213935 X * .AND. SMALL(2) .EQ. 10752) THEN X* *** VAX WITH D_FLOATING *** X IMACH(10) = 2 X IMACH(14) = 56 X IMACH(15) = -127 X IMACH(16) = 127 X ELSE IF ( SMALL(1) .EQ. 1267827943 X * .AND. SMALL(2) .EQ. 704643072) THEN X* *** IBM MAINFRAME *** X IMACH(10) = 16 X IMACH(14) = 14 X IMACH(15) = -64 X IMACH(16) = 63 X ELSE X WRITE(*,9010) X STOP 777 X END IF X IMACH(11) = IMACH(14) X IMACH(12) = IMACH(15) X IMACH(13) = IMACH(16) X ELSE X RMACH = 1234567. X IF (SMALL(1) .EQ. 1234613304) THEN X* *** IEEE *** X IMACH(10) = 2 X IMACH(11) = 24 X IMACH(12) = -125 X IMACH(13) = 128 X IMACH(14) = 53 X IMACH(15) = -1021 X IMACH(16) = 1024 X SC = 987 X ELSE IF (SMALL(1) .EQ. -1271379306) THEN X* *** VAX *** X IMACH(10) = 2 X IMACH(11) = 24 X IMACH(12) = -127 X IMACH(13) = 127 X IMACH(14) = 56 X IMACH(15) = -127 X IMACH(16) = 127 X SC = 987 X ELSE IF (SMALL(1) .EQ. 1175639687) THEN X* *** IBM MAINFRAME *** X IMACH(10) = 16 X IMACH(11) = 6 X IMACH(12) = -64 X IMACH(13) = 63 X IMACH(14) = 14 X IMACH(15) = -64 X IMACH(16) = 63 X SC = 987 X ELSE IF (SMALL(1) .EQ. 1251390520) THEN X* *** CONVEX C-1 *** X IMACH(10) = 2 X IMACH(11) = 24 X IMACH(12) = -128 X IMACH(13) = 127 X IMACH(14) = 53 X IMACH(15) = -1024 X IMACH(16) = 1023 X ELSE X DO 10 I3 = 1, 3 X J = SMALL(1) / 10000000 X K = SMALL(1) - 10000000*J X IF (K .NE. T3E(I3)) GO TO 20 X SMALL(1) = J X 10 CONTINUE X* *** CRAY T3E *** X IMACH( 1) = 5 X IMACH( 2) = 6 X IMACH( 3) = 0 X IMACH( 4) = 0 X IMACH( 5) = 64 X IMACH( 6) = 8 X IMACH( 7) = 2 X IMACH( 8) = 63 X CALL I1MCR1(IMACH(9), K, 32767, 16777215, 16777215) X IMACH(10) = 2 X IMACH(11) = 53 X IMACH(12) = -1021 X IMACH(13) = 1024 X IMACH(14) = 53 X IMACH(15) = -1021 X IMACH(16) = 1024 X GO TO 35 X 20 CALL I1MCR1(J, K, 16405, 9876536, 0) X IF (SMALL(1) .NE. J) THEN X WRITE(*,9020) X STOP 777 X END IF X* *** CRAY 1, XMP, 2, AND 3 *** X IMACH(1) = 5 X IMACH(2) = 6 X IMACH(3) = 102 X IMACH(4) = 6 X IMACH(5) = 46 X IMACH(6) = 8 X IMACH(7) = 2 X IMACH(8) = 45 X CALL I1MCR1(IMACH(9), K, 0, 4194303, 16777215) X IMACH(10) = 2 X IMACH(11) = 47 X IMACH(12) = -8188 X IMACH(13) = 8189 X IMACH(14) = 94 X IMACH(15) = -8141 X IMACH(16) = 8189 X GO TO 35 X END IF X END IF X IMACH( 1) = 5 X IMACH( 2) = 6 X IMACH( 3) = 7 X IMACH( 4) = 6 X IMACH( 5) = 32 X IMACH( 6) = 4 X IMACH( 7) = 2 X IMACH( 8) = 31 X IMACH( 9) = 2147483647 X 35 SC = 987 X END IF X 9010 FORMAT(/' Adjust autodoubled I1MACH by uncommenting data'/ X * ' statements appropriate for your machine and setting'/ X * ' IMACH(I) = IMACH(I+3) for I = 11, 12, and 13.') X 9020 FORMAT(/' Adjust I1MACH by uncommenting data statements'/ X * ' appropriate for your machine.') X IF (I .LT. 1 .OR. I .GT. 16) GO TO 40 X I1MACH = IMACH(I) X RETURN X 40 WRITE(*,*) 'I1MACH(I): I =',I,' is out of bounds.' X STOP X* /* C source for I1MACH -- remove the * in column 1 */ X* /* Note that some values may need changing. */ X*#include X*#include X*#include X*#include X* X*long i1mach_(long *i) X*{ X* switch(*i){ X* case 1: return 5; /* standard input */ X* case 2: return 6; /* standard output */ X* case 3: return 7; /* standard punch */ X* case 4: return 0; /* standard error */ X* case 5: return 32; /* bits per integer */ X* case 6: return sizeof(int); X* case 7: return 2; /* base for integers */ X* case 8: return 31; /* digits of integer base */ X* case 9: return LONG_MAX; X* case 10: return FLT_RADIX; X* case 11: return FLT_MANT_DIG; X* case 12: return FLT_MIN_EXP; X* case 13: return FLT_MAX_EXP; X* case 14: return DBL_MANT_DIG; X* case 15: return DBL_MIN_EXP; X* case 16: return DBL_MAX_EXP; X* } X* fprintf(stderr, "invalid argument: i1mach(%ld)\n", *i); X* exit(1);return 0; /* some compilers demand return values */ X*} X END X SUBROUTINE I1MCR1(A, A1, B, C, D) X**** SPECIAL COMPUTATION FOR OLD CRAY MACHINES **** X INTEGER A, A1, B, C, D X A1 = 16777216*B + C X A = 16777216*A1 + D X END END_OF_FILE if test 9699 -ne `wc -c <'i1mach.f'`; then echo shar: \"'i1mach.f'\" unpacked with wrong size! fi # end of 'i1mach.f' fi if test -f 'initch.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'initch.f'\" else echo shar: Extracting \"'initch.f'\" \(9587 characters\) sed "s/^X//" >'initch.f' <<'END_OF_FILE' X SUBROUTINE INITCH(INSTOP,LINESR,NEWTON,OVERFL,SCLFCH, X $ SCLXCH,ACPTCR,CONTYP,JACTYP,JUPDM , X $ MAXEXP,N ,NUNIT ,OUTPUT,QNUPDM, X $ STOPCR,TRUPDM,EPSMCH,FCNOLD,FTOL , X $ BOUNDL,BOUNDU,FVECC ,SCALEF,SCALEX, X $ WV1 ,XC ,FVECEV) XC XC AUG. 27, 1991 XC XC THIS SUBROUTINE FIRST CHECKS TO SEE IF N IS WITHIN THE XC ACCEPTABLE RANGE. XC XC THE SECOND CHECK IS TO SEE IF THE INITIAL ESTIMATE IS XC ALREADY A SOLUTION BY THE FUNCTION VALUE CRITERION, FTOL. XC XC THE THIRD CHECK IS MADE TO SEE IF THE NEWTON OPTION IS BEING XC USED WITH THE LINE SEARCH. IF NOT A WARNING IS GIVEN AND XC THE LINE SEARCH OPTION IS INVOKED. XC XC THE FOURTH CHECK IS TO ENSURE APPLICABILITY OF SELECTED XC VALUES FOR INTEGER CONSTANTS. XC XC THE FIFTH CHECK IS TO WARN THE USER IF INITIAL ESTIMATES XC ARE NOT WITHIN THE RANGES SET BY THE BOUNDL AND BOUNDU XC VECTORS. CONTYP IS CHANGED FROM 0 TO 1 IF ANY BOUND HAS XC BEEN SET BY THE USER XC XC THE SIXTH CHECK ENSURES BOUNDL(I) < BOUNDU(I) FOR ALL I. XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X INTEGER ACPTCR ,CONTYP ,OUTPUT ,QNUPDM , X $ STOPCR ,TRUPDM X DIMENSION BOUNDL(N),BOUNDU(N),FVECC(N) ,SCALEF(N), X $ SCALEX(N),WV1(N) ,XC(N) X LOGICAL FRSTER ,INSTOP ,LINESR ,NEWTON , X $ OVERFL ,SCLFCH ,SCLXCH X EXTERNAL FVECEV X DATA ZERO,ONE,TEN /0.0D0,1.0D0,10.0D0/ XC X INSTOP=.FALSE. X TEMP1=-TEN**MAXEXP X TEMP2=TEN**MAXEXP XC XC CHECK FOR N IN RANGE. XC X IF(N.LE.0) THEN X INSTOP=.TRUE. X WRITE(NUNIT,1) X1 FORMAT(T3,72('*')) X WRITE(NUNIT,2) X2 FORMAT(T3,'*',T74,'*') X WRITE(NUNIT,3) X3 FORMAT(T3,'*',2X,'N IS OUT OF RANGE - RESET TO POSITIVE', X $ ' INTEGER',T74,'*') X WRITE(NUNIT,2) X WRITE(NUNIT,1) X END IF XC XC CHECK FOR SCALING FACTORS POSITIVE. XC X FRSTER=.TRUE. X SCLFCH=.FALSE. X SCLXCH=.FALSE. X DO 100 I=1,N X IF(SCALEF(I).LE.ZERO) THEN X IF(FRSTER) THEN X INSTOP=.TRUE. X FRSTER=.FALSE. X WRITE(NUNIT,1) X END IF X WRITE(NUNIT,2) X WRITE(NUNIT,4) I,SCALEF(I) X4 FORMAT(T3,'*',7X,'SCALEF(',I3,') = ',1PD12.3, X $ 4X,'SHOULD BE POSITIVE',T74,'*') X END IF X IF(SCALEF(I).NE.ONE) SCLFCH=.TRUE. X IF(SCALEX(I).LE.ZERO) THEN X IF(FRSTER) THEN X INSTOP=.TRUE. X FRSTER=.FALSE. X WRITE(NUNIT,1) X END IF X WRITE(NUNIT,2) X WRITE(NUNIT,5) I,SCALEX(I) X5 FORMAT(T3,'*',7X,'SCALEX(',I3,') = ',1PD12.3, X $ 4X,'SHOULD BE POSITIVE',T74,'*') X END IF X IF(SCALEX(I).NE.ONE) SCLXCH=.TRUE. X100 CONTINUE X IF(.NOT.FRSTER) THEN X WRITE(NUNIT,2) X WRITE(NUNIT,1) X END IF XC XC EVALUATE INITIAL RESIDUAL VECTOR AND OBJECTIVE FUNCTION AND XC CHECK TO SEE IF THE INITIAL GUESS IS ALREADY A SOLUTION. XC X CALL FVECEV(OVERFL,N,FVECC,XC) XC XC NOTE: NUMBER OF LINE SEARCH FUNCTION EVALUATIONS, NFUNC, XC INITIALIZED AT 1 WHICH REPRESENTS THIS EVALUATION. XC X IF(OVERFL) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,2) X WRITE(NUNIT,6) X6 FORMAT(T3,'*',7X,'OVERFLOW IN INITIAL FUNCTION', X $ ' VECTOR EVALUATION',T74,'*') X WRITE(NUNIT,2) X WRITE(NUNIT,1) X INSTOP=.TRUE. X RETURN X END IF X CALL FCNEVL(OVERFL,MAXEXP,N ,NUNIT ,OUTPUT,EPSMCH, X $ FCNOLD,FVECC ,SCALEF,WV1 ) X IF(OVERFL) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,2) X WRITE(NUNIT,7) X7 FORMAT(T3,'*',7X,'OVERFLOW IN INITIAL OBJECTIVE ', X $ ' FUNCTION EVALUATION',T74,'*') X WRITE(NUNIT,2) X WRITE(NUNIT,1) X INSTOP=.TRUE. X RETURN X END IF XC XC CHECK FOR SOLUTION USING SECOND STOPPING CRITERION. XC X DO 200 I=1,N X IF(ABS(FVECC(I)).GT.FTOL) GO TO 201 X200 CONTINUE X INSTOP=.TRUE. X WRITE(NUNIT,1) X WRITE(NUNIT,2) X WRITE(NUNIT,8) X8 FORMAT(T3,'*',2X,'WARNING: THIS IS ALREADY A SOLUTION', X $ ' BY THE CRITERIA OF THE SOLVER',T74,'*') X WRITE(NUNIT,2) XC XC IF THE PROBLEM IS BADLY SCALED THE OBJECTIVE FUNCTION XC MAY MEET THE TOLERANCE ALTHOUGH THE INITIAL ESTIMATE XC IS NOT THE SOLUTION. XC X WRITE(NUNIT,9) X9 FORMAT(T3,'*',2X,'THIS MAY POSSIBLY BE ALLEVIATED BY ', X $ 'RESCALING THE PROBLEM IF THE',T74,'*') X WRITE(NUNIT,10) X10 FORMAT(T3,'*',2X,'INITIAL ESTIMATE IS KNOWN NOT TO BE', X $ ' A SOLUTION',T74,'*') X WRITE(NUNIT,2) X WRITE(NUNIT,1) X201 CONTINUE ! FVEC(I) > FTOL FOR SOME I FROM 200 LOOP XC XC CHECK FOR NEWTON'S METHOD REQUESTED BUT LINE SEARCH NOT XC BEING USED. XC X IF(NEWTON.AND.(.NOT.LINESR)) THEN X LINESR=.TRUE. X WRITE(NUNIT,1) X WRITE(NUNIT,2) X WRITE(NUNIT,11) X11 FORMAT(T3,'*',2X,'WARNING: INCOMPATIBLE OPTIONS', X $ ': NEWTON=.TRUE. AND LINESR=.FALSE.',T74,'*') X WRITE(NUNIT,12) X12 FORMAT(T3,'*',2X,'LINESR SET TO .TRUE.; EXECUTION' X $ ' OF NEWTON METHOD CONTINUING',T74,'*') X WRITE(NUNIT,2) X WRITE(NUNIT,1) X END IF XC XC CHECK INTEGER CONSTANTS. XC X IF(ACPTCR.NE.1.AND.ACPTCR.NE.12) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,2) X WRITE(NUNIT,13) ACPTCR X13 FORMAT(T3,'*',2X,'ACPTCR NOT AN ACCEPTABLE VALUE: ', X $ I5,T74,'*') X INSTOP=.TRUE. X WRITE(NUNIT,2) X WRITE(NUNIT,1) X END IF X IF(JACTYP.LT.0.OR.JACTYP.GT.3) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,2) X WRITE(NUNIT,14) JACTYP X14 FORMAT(T3,'*',2X,'JACTYP:',I5,' - NOT IN PROPER RANGE', X $ T74,'*') X INSTOP=.TRUE. X WRITE(NUNIT,2) X WRITE(NUNIT,1) X END IF X IF(STOPCR.NE.1.AND.STOPCR.NE.12.AND.STOPCR.NE.2. X $ AND.STOPCR.NE.3) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,2) X WRITE(NUNIT,15) STOPCR X15 FORMAT(T3,'*',2X,'STOPCR NOT AN ACCEPTABLE VALUE: ', X $ I5,T74,'*') X INSTOP=.TRUE. X WRITE(NUNIT,2) X WRITE(NUNIT,1) X END IF X IF(QNUPDM.LT.0.OR.QNUPDM.GT.1) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,2) X WRITE(NUNIT,16) QNUPDM X16 FORMAT(T3,'*',2X,'QNUPDM:',I5,' - NOT IN PROPER RANGE', X $ T74,'*') X INSTOP=.TRUE. X WRITE(NUNIT,2) X WRITE(NUNIT,1) X END IF X IF(TRUPDM.LT.0.OR.TRUPDM.GT.1) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,2) X WRITE(NUNIT,17) TRUPDM X17 FORMAT(T3,'*',2X,'TRUPDM:',I5,' - NOT IN PROPER RANGE', X $ T74,'*') X INSTOP=.TRUE. X WRITE(NUNIT,2) X WRITE(NUNIT,1) X END IF X IF(JUPDM.LT.0.OR.JUPDM.GT.2) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,2) X WRITE(NUNIT,18) JUPDM X18 FORMAT(T3,'*',2X,'JUPDM:',I5,' - NOT IN PROPER RANGE', X $ T74,'*') X INSTOP=.TRUE. X WRITE(NUNIT,2) X WRITE(NUNIT,1) X END IF XC XC CHECK FOR INITIAL ESTIMATES NOT WITHIN SPECIFIED BOUNDS AND XC SET CONTYP TO 1 => AT LEAST ONE BOUND IS IN EFFECT. XC X CONTYP=0 X DO 300 I=1,N X IF((BOUNDL(I).NE.TEMP1.OR.BOUNDU(I).NE.TEMP2)) THEN X CONTYP=1 X GO TO 301 X END IF X300 CONTINUE X301 CONTINUE X FRSTER=.TRUE. X IF(CONTYP.NE.0) THEN X DO 400 I=1,N XC XC CHECK FOR INITIAL ESTIMATES OUT OF RANGE AND LOWER XC BOUND GREATER THAN OR EQUAL TO THE UPPER BOUND. XC X IF(XC(I).LT.BOUNDL(I).OR.XC(I).GT.BOUNDU(I)) THEN X IF(FRSTER) THEN X INSTOP=.TRUE. X FRSTER=.FALSE. X WRITE(NUNIT,1) X WRITE(NUNIT,2) X WRITE(NUNIT,19) X19 FORMAT(T3,'*',7X,'COMPONENTS MUST BE WITHIN', X $ ' BOUNDS',T74,'*') X WRITE(NUNIT,2) X WRITE(NUNIT,20) X20 FORMAT(T3,'*',8X,'NO.',9X,'XC',16X,'BOUNDL',10X, X $ 'BOUNDU',T74,'*') X WRITE(NUNIT,2) X END IF X WRITE(NUNIT,21) I,XC(I),BOUNDL(I),BOUNDU(I) X21 FORMAT(T3,'*',7X,I3,3X,1PD12.3,9X,1PD12.3,4X, X $ 1PD12.3,T74,'*') X END IF X400 CONTINUE X IF(.NOT.FRSTER) THEN X WRITE(NUNIT,2) X WRITE(NUNIT,1) X END IF XC X FRSTER=.TRUE. X DO 500 I=1,N X IF(BOUNDL(I).GE.BOUNDU(I)) THEN X IF(FRSTER) THEN X FRSTER=.FALSE. X WRITE(NUNIT,1) X WRITE(NUNIT,2) X WRITE(NUNIT,22) X22 FORMAT(T3,'*',7X,'LOWER BOUND MUST BE LESS THAN', X $ ' UPPER BOUND - VIOLATIONS LISTED',T74,'*') X WRITE(NUNIT,2) X END IF X WRITE(NUNIT,23) I,BOUNDL(I),I,BOUNDU(I) X23 FORMAT(T3,'*',7X,'BOUNDL(',I3,') = ',1PD12.3, X $ 4X,'BOUNDU(',I3,') = ',1PD12.3,T74,'*') X END IF X500 CONTINUE X IF(.NOT.FRSTER) THEN X WRITE(NUNIT,2) X WRITE(NUNIT,1) X END IF X END IF X RETURN XC XC LAST CARD OF SUBROUTINE INITCH. XC X END END_OF_FILE if test 9587 -ne `wc -c <'initch.f'`; then echo shar: \"'initch.f'\" unpacked with wrong size! fi # end of 'initch.f' fi if test -f 'innerp.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'innerp.f'\" else echo shar: Extracting \"'innerp.f'\" \(4156 characters\) sed "s/^X//" >'innerp.f' <<'END_OF_FILE' X SUBROUTINE INNERP(OVERCH,OVERFL,MAXEXP,LDIMA ,LDIMB ,N , X $ NUNIT ,OUTPUT,DTPRO ,A ,B ) XC XC FEB. 14, 1991 XC XC THIS SUBROUTINE FINDS THE INNER PRODUCT OF TWO VECTORS, XC A AND B. IF OVERCH IS FALSE, UNROLLED LOOPS ARE USED. XC XC LDIMA IS THE DIMENSION OF A XC LDIMB IS THE DIMENSION OF B XC N IS THE DEPTH INTO A AND B THE INNER PRODUCT IS DESIRED. XC (USUALLY LDIMA=LDIMB=N) XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X INTEGER OUTPUT X DIMENSION A(LDIMA) ,B(LDIMB) X LOGICAL OVERCH ,OVERFL ,WRNSUP X COMMON/NNES_2/WRNSUP X DATA ZERO,ONE,TEN /0.0D0,1.0D0,10.0D0/ XC X EPS=TEN**(-MAXEXP) X OVERFL=.FALSE. XC X DTPRO=ZERO X IF(OVERCH) THEN X DO 100 I=1,N X IF(LOG10(ABS(A(I))+EPS)+LOG10(ABS(B(I))+EPS) X $ .GT.MAXEXP) THEN X OVERFL=.TRUE. X DTPRO=SIGN(TEN**MAXEXP,A(I))*SIGN(ONE,B(I)) X IF(OUTPUT.GT.2.AND.(.NOT.WRNSUP)) THEN X WRITE(NUNIT,1) X1 FORMAT(T3,'*',T74,'*') X WRITE(NUNIT,2) DTPRO X2 FORMAT(T3,'*',4X,'WARNING: TO AVOID OVERFLOW,', X $ ' INNER PRODUCT SET TO ',1PD12.3,T74,'*') X END IF X RETURN X END IF X DTPRO=DTPRO+A(I)*B(I) X100 CONTINUE X ELSE XC XC SET NUMBER OF GROUPS OF EACH SIZE. XC X NG32=N/32 X NG32R=N-32*NG32 X NG16=NG32R/16 X NG16R=NG32R-16*NG16 X NG8=NG16R/8 X NG8R=NG16R-8*NG8 X NG4=NG8R/4 X NG4R=NG8R-4*NG4 XC XC FIND INNER PRODUCT. XC X K=0 X IF(NG32.GT.0) THEN X DO 200 KK=1,NG32 X K=K+32 X DTPRO=DTPRO X $ +A(K-31)*B(K-31)+A(K-30)*B(K-30) X $ +A(K-29)*B(K-29)+A(K-28)*B(K-28) X $ +A(K-27)*B(K-27)+A(K-26)*B(K-26) X $ +A(K-25)*B(K-25)+A(K-24)*B(K-24) X DTPRO=DTPRO X $ +A(K-23)*B(K-23)+A(K-22)*B(K-22) X $ +A(K-21)*B(K-21)+A(K-20)*B(K-20) X $ +A(K-19)*B(K-19)+A(K-18)*B(K-18) X $ +A(K-17)*B(K-17)+A(K-16)*B(K-16) X DTPRO=DTPRO X $ +A(K-15)*B(K-15)+A(K-14)*B(K-14) X $ +A(K-13)*B(K-13)+A(K-12)*B(K-12) X $ +A(K-11)*B(K-11)+A(K-10)*B(K-10) X $ +A(K-9) *B(K-9) +A(K-8) *B(K-8) X DTPRO=DTPRO X $ +A(K-7)*B(K-7)+A(K-6)*B(K-6) X $ +A(K-5)*B(K-5)+A(K-4)*B(K-4) X $ +A(K-3)*B(K-3)+A(K-2)*B(K-2) X $ +A(K-1)*B(K-1)+A(K) *B(K) X200 CONTINUE X END IF X IF(NG16.GT.0) THEN X DO 300 KK=1,NG16 X K=K+16 X DTPRO=DTPRO X $ +A(K-15)*B(K-15)+A(K-14)*B(K-14) X $ +A(K-13)*B(K-13)+A(K-12)*B(K-12) X $ +A(K-11)*B(K-11)+A(K-10)*B(K-10) X $ +A(K-9) *B(K-9) +A(K-8)*B(K-8) X DTPRO=DTPRO X $ +A(K-7)*B(K-7)+A(K-6)*B(K-6) X $ +A(K-5)*B(K-5)+A(K-4)*B(K-4) X $ +A(K-3)*B(K-3)+A(K-2)*B(K-2) X $ +A(K-1)*B(K-1)+A(K) *B(K) X300 CONTINUE X END IF X IF(NG8.GT.0) THEN X DO 400 KK=1,NG8 X K=K+8 X DTPRO=DTPRO X $ +A(K-7)*B(K-7)+A(K-6)*B(K-6) X $ +A(K-5)*B(K-5)+A(K-4)*B(K-4) X $ +A(K-3)*B(K-3)+A(K-2)*B(K-2) X $ +A(K-1)*B(K-1)+A(K) *B(K) X400 CONTINUE X END IF X IF(NG4.GT.0) THEN X DO 500 KK=1,NG4 X K=K+4 X DTPRO=DTPRO X $ +A(K-3)*B(K-3)+A(K-2)*B(K-2) X $ +A(K-1)*B(K-1)+A(K) *B(K) X500 CONTINUE X END IF X IF(NG4R.GT.0) THEN X DO 600 KK=1,NG4R X K=K+1 X DTPRO=DTPRO+A(K)*B(K) X600 CONTINUE X END IF X END IF X RETURN XC XC LAST CARD OF SUBROUTINE INNERP. XC X END END_OF_FILE if test 4156 -ne `wc -c <'innerp.f'`; then echo shar: \"'innerp.f'\" unpacked with wrong size! fi # end of 'innerp.f' fi if test -f 'jaccd.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'jaccd.f'\" else echo shar: Extracting \"'jaccd.f'\" \(1603 characters\) sed "s/^X//" >'jaccd.f' <<'END_OF_FILE' X SUBROUTINE JACCD(N ,NUNIT ,OUTPUT,EPSMCH,FVECJ1, X $ FVECJ2,JACFDM,SCALEX,XC ,FVECEV) XC XC FEB. 11, 1991 XC XC THIS SUBROUTINE EVALUATES THE JACOBIAN USING CENTRAL XC DIFFERENCES. XC XC FVECJ1 AND FVECJ2 ARE TEMPORARY VECTORS TO HOLD THE XC RESIDUAL VECTORS FOR THE CENTRAL DIFFERENCE CALCULATION. XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION JACFDM(N,N) X INTEGER OUTPUT X DIMENSION FVECJ1(N) ,FVECJ2(N) ,SCALEX(N) ,XC(N) X LOGICAL OVERFL ,WRNSUP X COMMON/NNES_2/WRNSUP X EXTERNAL FVECEV X DATA ONE,TWO /1.0D0,2.0D0/ XC X OVERFL=.FALSE. X CURTEP=EPSMCH**0.33 XC X DO 100 J=1,N X DELTAJ=(CURTEP)*SIGN((MAX(ABS(XC(J)), X $ ONE/SCALEX(J))),XC(J)) X TEMPJ=XC(J) X XC(J)=XC(J)+DELTAJ XC XC NOTE: THIS STEP IS FOR FLOATING POINT ACCURACY ONLY. XC X DELTAJ=XC(J)-TEMPJ XC X CALL FVECEV(OVERFL,N,FVECJ1,XC) X XC(J)=TEMPJ-DELTAJ X CALL FVECEV(OVERFL,N,FVECJ2,XC) X IF(OVERFL.AND.OUTPUT.GT.2.AND.(.NOT.WRNSUP)) THEN X WRITE(NUNIT,1) X1 FORMAT(T3,'*',T74,'*') X WRITE(NUNIT,2) X2 FORMAT(T3,'*',4X,'WARNING: OVERFLOW IN FUNCTION', X $ ' VECTOR IN "JACCD"',T74,'*') X END IF X DO 200 I=1,N X JACFDM(I,J)=(FVECJ1(I)-FVECJ2(I))/(TWO*DELTAJ) X200 CONTINUE X XC(J)=TEMPJ X100 CONTINUE X RETURN XC XC LAST CARD OF SUBROUTINE JACCD. XC X END END_OF_FILE if test 1603 -ne `wc -c <'jaccd.f'`; then echo shar: \"'jaccd.f'\" unpacked with wrong size! fi # end of 'jaccd.f' fi if test -f 'jacfd.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'jacfd.f'\" else echo shar: Extracting \"'jacfd.f'\" \(6257 characters\) sed "s/^X//" >'jacfd.f' <<'END_OF_FILE' X SUBROUTINE JACFD(JACTYP,N ,NUNIT ,OUTPUT,EPSMCH, X $ BOUNDL,BOUNDU,FVECC ,FVECJ1,JACFDM, X $ SCALEX,WV3 ,XC ,FVECEV) XC XC FEB. 15, 1991 XC XC THIS SUBROUTINE EVALUATES THE JACOBIAN USING XC ONE-SIDED FINITE DIFFERENCES. XC XC JACTYP "1" SIGNIFIES FORWARD DIFFERENCES XC JACTYP "2" SIGNIFIES BACKWARD DIFFERENCES XC XC FVECJ1 IS A TEMPORARY VECTOR WHICH STORES THE RESIDUAL XC VECTOR FOR THE FINITE DIFFERENCE CALCULATION. XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION JACFDM(N,N) X INTEGER OUTPUT X DIMENSION BOUNDL(N) ,BOUNDU(N) ,FVECC(N) ,FVECJ1(N), X $ SCALEX(N) ,WV3(N) ,XC(N) X LOGICAL OVERFL ,WRNSUP X COMMON/NNES_2/WRNSUP X EXTERNAL FVECEV X DATA ZERO,ONE /0.0D0,1.0D0/ XC X SQRTEP=SQRT(EPSMCH) XC XC FINITE-DIFFERENCE CALCULATION BY COLUMNS. XC X DO 100 J=1,N XC XC DELTAJ IS THE STEP SIZE - IT IS ALWAYS POSITIVE. XC X DELTAJ=SQRTEP*MAX(ABS(XC(J)),ONE/SCALEX(J)) X TEMPJ=XC(J) ! TEMPORARY STORAGE OF XC(J) X IF(JACTYP.EQ.1) THEN X IF(XC(J)+DELTAJ.LE.BOUNDU(J)) THEN XC XC STEP WITHIN BOUNDS - COMPLETE FORWARD DIFFERENCE. XC X XC(J)=XC(J)+DELTAJ X DELTAJ=XC(J)-TEMPJ X CALL FORDIF(OVERFL,J ,N ,DELTAJ,FVECC , X $ FVECJ1,JACFDM,XC ,FVECEV) X ELSE XC XC STEP WOULD VIOLATE BOUNDU - TRY BACKWARD DIFFERENCE. XC X IF(XC(J)-DELTAJ.GE.BOUNDL(J)) THEN X XC(J)=XC(J)-DELTAJ X CALL BAKDIF(OVERFL,J ,N ,DELTAJ,TEMPJ , X $ FVECC ,FVECJ1,JACFDM,XC ,FVECEV) X ELSE XC XC STEP WOULD ALSO VIOLATE BOUNDL - IF THE DIFFERENCE XC IN THE BOUNDS, (BOUNDU-BOUNDL), IS GREATER THAN XC DELTAJ CALCULATE THE FUNCTION VECTOR AT EACH BOUND XC AND USE THIS DIFFERENCE - THIS REQUIRES ONE EXTRA XC FUNCTION EVALUATION. THE CURRENT FVECC IS STORED XC IN WV3, THEN REPLACED. XC X IF(BOUNDU(J)-BOUNDL(J).GE.DELTAJ) THEN X CALL BNDDIF(OVERFL,J ,N ,EPSMCH,BOUNDL, X $ BOUNDU,FVECC ,FVECJ1,JACFDM,WV3 , X $ XC ,FVECEV) X IF(OUTPUT.GT.2.AND.(.NOT.WRNSUP).AND. X $ (.NOT.OVERFL)) THEN X WRITE(NUNIT,1) X1 FORMAT(T3,'*',T74,'*') X WRITE(NUNIT,2) X2 FORMAT(T3,'*',4X,'WARNING: BOUNDS TOO CLOSE', X $ ' FOR 1-SIDED FINITE-DIFFERENCES',T74,'*') X WRITE(NUNIT,3) J X3 FORMAT(T3,'*',13X,'LOWER AND UPPER BOUNDS', X $ ' USED FOR JACOBIAN COLUMN: ',I3,T74,'*') X WRITE(NUNIT,4) X4 FORMAT(T3,'*',13X,'THIS REQUIRED ONE EXTRA', X $ ' FUNCTION EVALUATION',T74,'*') X END IF X ELSE XC XC BOUNDS ARE EXTREMELY CLOSE (BUT NOT EQUAL OR XC THE PROGRAM WOULD HAVE STOPPED IN INITCH). XC X IF(OUTPUT.GT.2.AND.(.NOT.WRNSUP).AND. X $ (.NOT.OVERFL)) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,2) X WRITE(NUNIT,5) J X5 FORMAT(T3,'*',13X,'BOUNDS ARE EXTREMELY', X $ ' CLOSE FOR COMPONENT: ',I3,T74,'*') X WRITE(NUNIT,6) X6 FORMAT(T3,'*',13X,'FINITE DIFFERENCE', X $ ' JACOBIAN IS UNRELIABLE',T74,'*') X END IF X CALL BNDDIF(OVERFL,J ,N ,EPSMCH,BOUNDL, X $ BOUNDU,FVECC ,FVECJ1,JACFDM,WV3 , X $ XC ,FVECEV) X END IF X END IF X END IF X ELSE X IF(XC(J)-DELTAJ.GE.BOUNDL(J)) THEN X XC(J)=XC(J)-DELTAJ X CALL BAKDIF(OVERFL,J ,N ,DELTAJ,TEMPJ ,FVECC , X $ FVECJ1,JACFDM,XC ,FVECEV) X ELSE X IF(XC(J)+DELTAJ.LE.BOUNDU(J)) THEN X XC(J)=XC(J)+DELTAJ X CALL FORDIF(OVERFL,J ,N ,DELTAJ, X $ FVECC ,FVECJ1,JACFDM,XC ,FVECEV) X ELSE X IF(BOUNDU(J)-BOUNDL(J).GE.DELTAJ) THEN X CALL BNDDIF(OVERFL,J ,N ,EPSMCH,BOUNDL, X $ BOUNDU,FVECC ,FVECJ1,JACFDM,WV3 , X $ XC ,FVECEV) X IF(OUTPUT.GT.2.AND.(.NOT.WRNSUP).AND. X $ (.NOT.OVERFL)) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,2) X WRITE(NUNIT,3) J X WRITE(NUNIT,4) X END IF X ELSE X CALL BNDDIF(OVERFL,J ,N ,EPSMCH,BOUNDL, X $ BOUNDU,FVECC ,FVECJ1,JACFDM,WV3 , X $ XC ,FVECEV) X DO 300 I=1,N X JACFDM(I,J)=ZERO X300 CONTINUE X IF(OUTPUT.GT.2.AND.(.NOT.WRNSUP).AND. X $ (.NOT.OVERFL)) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,2) X WRITE(NUNIT,5) J X WRITE(NUNIT,6) X END IF X END IF X END IF X END IF X END IF X IF(OVERFL.AND.OUTPUT.GT.2.AND.(.NOT.WRNSUP)) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,7) X7 FORMAT(T3,'*',4X,'WARNING: OVERFLOW IN FUNCTION', X $ ' VECTOR IN SUBROUTINE JACFD',T74,'*') X WRITE(NUNIT,5) J X DO 400 I=1,N X JACFDM(I,J)=ZERO X400 CONTINUE X END IF X XC(J)=TEMPJ X100 CONTINUE X RETURN XC XC LAST CARD OF SUBROUTINE JACFD. XC X END END_OF_FILE if test 6257 -ne `wc -c <'jacfd.f'`; then echo shar: \"'jacfd.f'\" unpacked with wrong size! fi # end of 'jacfd.f' fi if test -f 'jacobi.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'jacobi.f'\" else echo shar: Extracting \"'jacobi.f'\" \(3594 characters\) sed "s/^X//" >'jacobi.f' <<'END_OF_FILE' X SUBROUTINE JACOBI(CHECKJ,JACERR,OVERFL,JACTYP,N , X $ NUNIT ,OUTPUT,EPSMCH,FDTOLJ,BOUNDL, X $ BOUNDU,FVECC ,FVECJ1,FVECJ2,JAC , X $ JACFDM,SCALEX,WV3 ,XC ,FVECEV, X $ JACEV ) XC XC APR. 13, 1991 XC XC THIS SUBROUTINE EVALUATES THE JACOBIAN. IF CHECKJ IS TRUE XC THEN THE ANALYTICAL JACOBIAN IS CHECKED NUMERICALLY. XC XC JACEV IS A USER-SUPPLIED ANALYTICAL JACOBIAN USED ONLY IF XC JACTYP=0. THE JACOBIAN NAME MAY BE CHANGED BY USING THE XC EXTERNAL STATEMENT IN THE MAIN DRIVER. XC XC JACFD ESTIMATES THE JACOBIAN USING FINITE DIFFERENCES: XC FORWARD IF JACTYP=1 OR BACKWARD IF JACTYP=2. XC XC JACCD ESTIMATES THE JACOBIAN USING CENTRAL DIFFERENCES. XC XC IF THE ANALYTICAL JACOBIAN IS CHECKED THE FINITE DIFFERENCE XC JACOBIAN IS STORED IN "JACFDM" AND THEN COMPARED. XC XC FRSTER INDICATES FIRST ERROR - USED ONLY TO SET BORDERS XC FOR OUTPUT XC JACERR FLAG TO INDICATE TO THE CALLING PROGRAM AN ERROR XC IN THE ANALYTICAL JACOBIAN XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION JAC(N,N) ,JACFDM(N,N) X INTEGER OUTPUT X DIMENSION BOUNDL(N) ,BOUNDU(N) ,FVECC(N) ,FVECJ1(N) , X $ FVECJ2(N) ,SCALEX(N) ,WV3(N) ,XC(N) X LOGICAL CHECKJ ,FRSTER ,JACERR ,OVERFL X EXTERNAL FVECEV,JACEV X DATA ONE /1.0D0/ XC X FRSTER=.TRUE. X JACERR=.FALSE. X OVERFL=.FALSE. XC X IF(JACTYP.EQ.0) THEN X CALL JACEV(OVERFL,N,JAC,XC) X ELSEIF(JACTYP.EQ.1.OR.JACTYP.EQ.2) THEN X CALL JACFD(JACTYP,N ,NUNIT ,OUTPUT,EPSMCH,BOUNDL,BOUNDU, X $ FVECC ,FVECJ1,JAC ,SCALEX,WV3 ,XC ,FVECEV) X ELSE X CALL JACCD(N ,NUNIT ,OUTPUT,EPSMCH,FVECJ1, X $ FVECJ2,JAC ,SCALEX,XC ,FVECEV) X END IF XC X IF(JACTYP.EQ.0.AND.CHECKJ) THEN XC XC NOTE: JACTYP=0 SENT TO JACFD PRODUCES A FORWARD XC DIFFERENCE ESTIMATE OF THE JACOBIAN. XC X CALL JACFD(JACTYP,N ,NUNIT ,OUTPUT,EPSMCH,BOUNDL, X $ BOUNDU,FVECC ,FVECJ1,JACFDM,SCALEX,WV3 , X $ XC ,FVECEV) X DO 100 J=1,N X DO 200 I=1,N X IF(ABS((JACFDM(I,J)-JAC(I,J))/MAX(ABS(JAC(I,J)), X $ ABS(JACFDM(I,J)),ONE)).GT.FDTOLJ) THEN X JACERR=.TRUE. X IF(OUTPUT.GE.0) THEN X IF(FRSTER) THEN X FRSTER=.FALSE. X WRITE(NUNIT,1) X1 FORMAT(T3,72('*')) X END IF X WRITE(NUNIT,2) X2 FORMAT(T3,'*',T74,'*') X WRITE(NUNIT,3) I,J X3 FORMAT(T3,'*',4X,'CHECK JACOBIAN TERM (',I3, X $ ',',I3,')',T74,'*') X WRITE(NUNIT,2) X WRITE(NUNIT,4) JAC(I,J) X4 FORMAT(T3,'*',4X,'ANALYTICAL DERIVATIVE IS ', X $ 1PD12.3,T74,'*') X WRITE(NUNIT,5) JACFDM(I,J) X5 FORMAT(T3,'*',4X,' NUMERICAL DERIVATIVE IS ', X $ 1PD12.3,T74,'*') X WRITE(NUNIT,2) X WRITE(NUNIT,1) X END IF X END IF X200 CONTINUE X100 CONTINUE X END IF X RETURN XC XC LAST CARD OF SUBROUTINE JACOBI. XC X END END_OF_FILE if test 3594 -ne `wc -c <'jacobi.f'`; then echo shar: \"'jacobi.f'\" unpacked with wrong size! fi # end of 'jacobi.f' fi if test -f 'jacrot.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'jacrot.f'\" else echo shar: Extracting \"'jacrot.f'\" \(953 characters\) sed "s/^X//" >'jacrot.f' <<'END_OF_FILE' X SUBROUTINE JACROT(OVERFL,I,MAXEXP,N,AROT,BROT,EPSMCH,A,JAC) XC XC FEB. 11, 1991 XC XC JACOBI (OR GIVENS) ROTATION. XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION JAC(N,N) X DIMENSION A(N,N) ,HOLD(2) X LOGICAL OVERFL X DATA ZERO,ONE /0.0D0,1.0D0/ X IF(AROT.EQ.ZERO) THEN X C=ZERO X S=-SIGN(ONE,BROT) X ELSE X HOLD(1)=AROT X HOLD(2)=BROT X LDHOLD=2 X CALL TWONRM(OVERFL,MAXEXP,LDHOLD,EPSMCH,DENOM,HOLD) X C=AROT/DENOM X S=-BROT/DENOM X END IF X DO 100 J=I,N X Y=A(I,J) X W=A(I+1,J) X A(I,J)=C*Y-S*W X A(I+1,J)=S*Y+C*W X100 CONTINUE X DO 200 J=1,N X Y=JAC(I,J) X W=JAC(I+1,J) X JAC(I,J)=C*Y-S*W X JAC(I+1,J)=S*Y+C*W X200 CONTINUE X RETURN XC XC LAST CARD OF SUBROUTINE JACROT. XC X END END_OF_FILE if test 953 -ne `wc -c <'jacrot.f'`; then echo shar: \"'jacrot.f'\" unpacked with wrong size! fi # end of 'jacrot.f' fi if test -f 'line.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'line.f'\" else echo shar: Extracting \"'line.f'\" \(9689 characters\) sed "s/^X//" >'line.f' <<'END_OF_FILE' X SUBROUTINE LINE(ABORT ,ABSNEW,DEUFLH,GEOMS ,NEWTON, X $ OVERCH,OVERFL,QNFAIL,QRSING,RESTRT, X $ SCLFCH,SCLXCH,ACPCOD,ACPTCR,CONTYP, X $ ISEJAC,ITNUM ,JUPDM ,MAXEXP,MAXLIN, X $ MGLL ,MNEW ,N ,NARMIJ,NFUNC , X $ NUNIT ,OUTPUT,QNUPDM,STOPCR,TRMCOD, X $ ALPHA ,CONFAC,EPSMCH,FCNMAX,FCNNEW, X $ FCNOLD,LAM0 ,MAXSTP,NEWLEN,SBRNRM, X $ SIGMA ,A ,BOUNDL,BOUNDU,DELF , X $ FTRACK,FVEC ,H ,HHPI ,JAC , X $ RDIAG ,RHS ,S ,SBAR ,SCALEF, X $ SCALEX,SN ,STRACK,WV2 ,XC , X $ XPLUS ,FVECEV) XC XC SEPT. 9, 1991 XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION JAC(N,N) ,LAM0 ,LAMBDA ,MAXSTP , X $ MU ,NEWLEN ,NEWMAX ,NORM , X $ NRMPRE X INTEGER ACPTCR ,CONTYP ,OUTPUT ,QNUPDM , X $ STOPCR ,TRMCOD X DIMENSION A(N,N) ,BOUNDL(N),BOUNDU(N) ,DELF(N) , X $ FTRACK(0:MGLL-1) ,FVEC(N) ,H(N,N) , X $ HHPI(N) ,RDIAG(N) ,RHS(N) ,S(N) , X $ SBAR(N) ,SCALEF(N),SCALEX(N) ,SN(N) , X $ STRACK(0:MGLL-1) ,WV2(N) ,XC(N) , X $ XPLUS(N) X LOGICAL ABORT ,ABSNEW ,CONVIO ,DEUFLH , X $ GEOMS ,NEWTON ,OVERCH ,OVERFL , X $ QNFAIL ,QRSING ,RESTRT ,SCLFCH , X $ SCLXCH ,WRNSUP X COMMON/NNES_2/WRNSUP X EXTERNAL FVECEV X DATA ZERO,TWO,TEN /0.0D0,2.0D0,10.0D0/ X SAVE XC X CONVIO=.FALSE. X OVERFL=.FALSE. X IF(NEWTON.OR.ABSNEW) THEN X IF(NEWTON) THEN XC XC FIND NEXT ITERATE FOR PURE NEWTON'S METHOD. XC X DO 100 I=1,N X XPLUS(I)=XC(I)+SN(I) X100 CONTINUE X ELSE XC XC FIND NEXT ITERATE FOR "ABSOLUTE" NEWTON'S METHOD. XC IF COMPONENT I WOULD BE OUTSIDE ITS BOUND THEN TAKE XC ABSOLUTE VALUE OF THE VIOLATION AND GO THIS DISTANCE XC INTO THE FEASIBLE REGION. ENSURE THAT THIS REFLECTION XC OFF ONE BOUND DOES NOT VIOLATE THE OTHER. XC X DO 200 I=1,N X WV2(I)=ZERO X IF(SN(I).GE.ZERO) THEN X IF(XC(I)+SN(I).GT.BOUNDU(I)) THEN X CONVIO=.TRUE. X WV2(I)=TWO X XPLUS(I)=MAX(TWO*BOUNDU(I)-XC(I)-SN(I), X $ BOUNDL(I)) X ELSE X XPLUS(I)=XC(I)+SN(I) X END IF X ELSE X IF(XC(I)+SN(I).LT.BOUNDL(I)) THEN X CONVIO=.TRUE. X WV2(I)=-TWO X XPLUS(I)=MIN(TWO*BOUNDL(I)-XC(I)-SN(I), X $ BOUNDU(I)) X ELSE X XPLUS(I)=XC(I)+SN(I) X END IF X END IF X200 CONTINUE X END IF X IF(CONVIO.AND.OUTPUT.GT.4) THEN X WRITE(NUNIT,1) X1 FORMAT(T3,'*',T74,'*') X WRITE(NUNIT,2) X2 FORMAT(T3,'*',7X,'CONSTRAINT VIOLATORS IN ABSOLUTE', X $ ' NEWTON''','S METHOD',T74,'*',/T3,'*',T74,'*') X WRITE(NUNIT,3) X3 FORMAT(T3,'*',7X,'COMPONENT',2X,'PROPOSED POINT',2X, X $ 'VIOLATED BOUND',2X,'FEASIBLE VALUE',T74,'*',/T3,'*', X $ T74,'*') X DO 300 I=1,N X IF(WV2(I).GT.ZERO) THEN X WRITE(NUNIT,4) I,XC(I)+SN(I),BOUNDU(I),XPLUS(I) X ELSEIF(WV2(I).LT.ZERO) THEN X WRITE(NUNIT,4) I,XC(I)+SN(I),BOUNDL(I),XPLUS(I) X END IF X4 FORMAT(T3,'*',7X,I6,5X,1PD12.3,4X,1PD12.3,4X,1PD12.3, X $ T74,'*') X300 CONTINUE X END IF X CALL FVECEV(OVERFL,N,FVEC,XPLUS) X NFUNC=NFUNC+1 X IF(OVERFL) THEN X OVERFL=.FALSE. X FCNNEW=10.0**MAXEXP X IF(OUTPUT.GT.2) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,5) X5 FORMAT(T3,'*',7X,'POTENTIAL OVERFLOW DETECTED', X $ ' IN FUNCTION EVALUATION',T74,'*') X END IF X GO TO 101 X END IF X CALL FCNEVL(OVERFL,MAXEXP,N ,NUNIT ,OUTPUT, X $ EPSMCH,FCNNEW,FVEC ,SCALEF,WV2 ) X101 CONTINUE XC XC RETURN FROM PURE NEWTON'S METHOD - OTHERWISE CONDUCT XC LINE SEARCH. XC X RETURN X END IF X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,1) X WRITE(NUNIT,6) X6 FORMAT(T3,'*',4X,'SUMMARY OF LINE SEARCH',T74,'*') X WRITE(NUNIT,1) X END IF XC XC SHORTEN NEWTON STEP IF LENGTH IS GREATER THAN MAXSTP. XC X IF(NEWLEN.GT.MAXSTP) THEN X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,7) X7 FORMAT(T3,'*',7X,'LENGTH OF NEWTON STEP SHORTENED TO', X $ ' MAXSTP',T74,'*') X END IF X DO 400 I=1,N X SN(I)=SN(I)*MAXSTP/NEWLEN X400 CONTINUE X END IF XC XC CHECK DIRECTIONAL DERIVATIVE (MAGNITUDE AND SIGN). XC X CALL INNERP(OVERCH,OVERFL,MAXEXP,N ,N ,N , X $ NUNIT ,OUTPUT,DELFTS,DELF ,SN ) X IF(OVERFL) THEN X OVERFL=.FALSE. X IF(OUTPUT.GT.2.AND.(.NOT.WRNSUP)) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,8) DELFTS X8 FORMAT(T3,'*',4X,'WARNING: DIRECTIONAL DERIVATIVE', X $ ', DELFTS, SET TO ',1PD12.3,T74,'*') X END IF X END IF XC XC REVERSE SEARCH DIRECTION IF DIRECTIONAL DERIVATIVE IS XC POSITIVE. XC X IF(DELFTS.GT.ZERO) THEN X DO 500 I=1,N X SN(I)=-SN(I) X500 CONTINUE X DELFTS=-DELFTS X IF(OUTPUT.GT.2.AND.(.NOT.WRNSUP)) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,9) X9 FORMAT(T3,'*',4X,'WARNING: DIRECTIONAL DERIVATIVE IS' X $ ' POSITIVE: DIRECTION REVERSED',T74,'*') X END IF X END IF XC XC OUTPUT INFORMATION. XC X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,10) DELFTS X10 FORMAT(T3,'*',7X,'INNER PRODUCT OF DELF AND SN, DELFTS: ' X $ ,'.......',1PD12.3,T74,'*') X IF(.NOT.SCLXCH) THEN X WRITE(NUNIT,11) NEWLEN X11 FORMAT(T3,'*',7X,'LENGTH OF NEWTON STEP, NEWLEN: ' X $ ,'..............',1PD12.3,T74,'*') X ELSE X WRITE(NUNIT,12) NEWLEN X12 FORMAT(T3,'*',7X,'LENGTH OF SCALED NEWTON STEP, NEWLEN: ' X $ ,'.......',1PD12.3,T74,'*') X END IF X WRITE(NUNIT,13) MAXSTP X13 FORMAT(T3,'*',7X,'MAXIMUM STEP LENGTH ALLOWED, MAXSTP: ' X $ ,'........',1PD12.3,T74,'*') X END IF XC XC ESTABLISH INITIAL RELAXATION FACTOR. XC X IF(DEUFLH) THEN XC XC AT FIRST STEP IN DAMPED NEWTON OR AFTER EXPLICIT XC JACOBIAN EVALUATION IN QUASI-NEWTON OR IF THE STEP XC SIZE IS WITHIN STOPPING TOLERANCE BUT STOPCR=3 THE XC LINE SEARCH IS STARTED AT LAMBDA=1. XC X IF(ISEJAC.EQ.1.OR.(TRMCOD.EQ.1.AND.STOPCR.EQ.3)) THEN X LAMBDA=LAM0 X ELSE X DO 600 I=1,N X WV2(I)=(SBAR(I)-SN(I))*SCALEX(I) X600 CONTINUE X CALL TWONRM(OVERFL,MAXEXP,N,EPSMCH,NORM,WV2) XC XC PREVENT DIVIDE BY ZERO IF NORM IS ZERO (UNDERFLOWS). XC X IF(NORM.LT.EPSMCH) THEN XC XC START LINE SEARCH AT LAMBDA=LAM0, USE DUMMY MU. XC X MU=TEN X ELSE X MU=NRMPRE*LAMBDA/NORM X END IF X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,14) MU X14 FORMAT(T3,'*',7X,'DEUFLHARD TEST RATIO, MU: ', X $ ' ',1PD11.3,T74,'*') X END IF XC XC SET INITIAL LAMBDA DEPENDING ON MU. THIS IS A XC MODIFICATION OF DEUFLHARD'S METHOD WHERE THE CUTOFF XC VALUE WOULD BE 0.7 FOR LAM0=1.0. XC X IF(MU.GT.LAM0/TEN) THEN X LAMBDA=LAM0 X ELSE X LAMBDA=LAM0/TEN X END IF X END IF X ELSE X LAMBDA=LAM0 X END IF XC XC STORE LENGTH OF NEWTON STEP. IF NEWTON STEP LENGTH WAS XC GREATER THAN MAXSTP IT WAS SHORTENED TO MAXSTP. XC X NRMPRE=MIN(MAXSTP,NEWLEN) XC XC ESTABLISH FCNMAX AND NEWMAX FOR NONMONOTONIC LINE SEARCH. XC X NEWMAX=NEWLEN X FCNMAX=FCNOLD X IF(ISEJAC.GT.NARMIJ) THEN X IF(ISEJAC.LT.NARMIJ+MGLL) THEN X DO 700 J=1,MNEW X FCNMAX=MAX(FCNMAX,FTRACK(J-1)) X NEWMAX=MAX(NEWMAX,STRACK(J-1)) X700 CONTINUE X ELSE X DO 800 J=0,MNEW X FCNMAX=MAX(FCNMAX,FTRACK(J)) X NEWMAX=MAX(NEWMAX,STRACK(J)) X800 CONTINUE X END IF X END IF XC X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,1) X IF(.NOT.SCLXCH) THEN X WRITE(NUNIT,15) X15 FORMAT(T3,'*',7X,'LINE SEARCH',T74,'*') X ELSE X WRITE(NUNIT,16) X16 FORMAT(T3,'*',7X,'LINE SEARCH (X''','S GIVEN IN', X $ ' UNSCALED UNITS)',T74,'*') X END IF X END IF XC XC CONDUCT LINE SEARCH. XC X CALL DEUFLS(ABORT ,DEUFLH,GEOMS ,OVERCH,OVERFL, X $ QNFAIL,QRSING,RESTRT,SCLFCH,SCLXCH, X $ ACPCOD,ACPTCR,CONTYP,ITNUM ,JUPDM , X $ MAXEXP,MAXLIN,N ,NFUNC ,NUNIT , X $ OUTPUT,QNUPDM,STOPCR,ALPHA ,CONFAC, X $ DELFTS,EPSMCH,FCNMAX,FCNNEW,FCNOLD, X $ LAMBDA,NEWMAX,SBRNRM,SIGMA ,A , X $ H ,BOUNDL,BOUNDU,DELF ,FVEC , X $ HHPI ,JAC ,RDIAG ,RHS ,S , X $ SBAR ,SCALEF,SCALEX,SN ,WV2 , X $ XC ,XPLUS ,FVECEV) X RETURN XC XC LAST CARD OF SUBROUTINE LINE. XC X END X END_OF_FILE if test 9689 -ne `wc -c <'line.f'`; then echo shar: \"'line.f'\" unpacked with wrong size! fi # end of 'line.f' fi if test -f 'llfa.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'llfa.f'\" else echo shar: Extracting \"'llfa.f'\" \(4203 characters\) sed "s/^X//" >'llfa.f' <<'END_OF_FILE' X SUBROUTINE LLFA(OVERCH,OVERFL,SCLFCH,SCLXCH,ISEJAC, X $ MAXEXP,N ,NUNIT ,OUTPUT,EPSMCH, X $ OMEGA ,A ,DELF ,FVEC ,FVECC , X $ JAC ,PLEE ,RDIAG ,S ,SCALEF, X $ SCALEX,T ,W ,WV3 ,XC , X $ XPLUS ) XC XC FEB. 23, 1991 XC XC THE LEE AND LEE QUASI-NEWTON METHOD IS APPLIED TO XC THE FACTORED FORM OF THE JACOBIAN. XC XC NOTE: T AND W ARE TEMPORARY WORKING VECTORS ONLY. XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION JAC(N,N) X INTEGER OUTPUT X DIMENSION A(N,N) ,DELF(N) ,FVEC(N) ,FVECC(N) , X $ PLEE(N,N),RDIAG(N),S(N) ,SCALEF(N), X $ SCALEX(N),T(N) ,W(N) ,WV3(N) , X $ XC(N) ,XPLUS(N) X LOGICAL OVERCH ,OVERFL ,SCLFCH ,SCLXCH , X $ SKIPUP X DATA ZERO /0.0D0/ XC X OVERFL=.FALSE. X SQRTEP=SQRT(EPSMCH) X SKIPUP=.TRUE. XC X DO 100 I=1,N X A(I,I)=RDIAG(I) X S(I)=XPLUS(I)-XC(I) X100 CONTINUE XC XC R IS IN THE UPPER TRIANGLE OF A. XC XC T=RS XC X CALL UVMUL(N,N,N,N,A,S,T) XC XC FORM PART OF NUMERATOR AND CHECK TO SEE IF A SIGNIFICANT XC CHANGE WOULD BE MADE TO THE JACOBIAN. XC X DO 200 I=1,N X CALL INNERP(OVERCH,OVERFL,MAXEXP,N,N,N,NUNIT,OUTPUT,SUM, X $ JAC(N*(I-1)+1,1),T) X W(I)=SCALEF(I)*(FVEC(I)-FVECC(I))-SUM XC XC TEST TO ENSURE VECTOR W IS NONZERO. IF W(I)=0 FOR XC ALL I THEN THE UPDATE IS SKIPPED - SKIPUP IS TRUE. XC X IF(ABS(W(I)).GT.SQRTEP*SCALEF(I)*(ABS(FVEC(I))+ X $ ABS(FVECC(I)))) THEN X SKIPUP=.FALSE. ! UPDATE TO BE PERFORMED X ELSE X W(I)=ZERO X END IF X200 CONTINUE X IF(.NOT.SKIPUP) THEN XC XC T=Q^W Q^ IS STORED IN JAC. XC X CALL AVMUL(N,N,N,N,JAC,W,T) XC XC FIND DENOMINATOR; FORM W=S^P (P IS SYMMETRIC SO PS IS FOUND). XC X CALL AVMUL(N,N,N,N,PLEE,S,W) X IF(SCLXCH) THEN XC XC SCALE W TO FIND DENOMINATOR. XC X DO 300 I=1,N X WV3(I)=W(I)*SCALEX(I)*SCALEX(I) X300 CONTINUE X ELSE X CALL MATCOP(N,N,1,1,N,1,W,WV3) X END IF X CALL INNERP(OVERCH,OVERFL,MAXEXP,N ,N ,N , X $ NUNIT ,OUTPUT,DENOM ,WV3 ,S ) XC XC IF OVERFLOW WOULD OCCUR MAKE NO CHANGE TO JACOBIAN. XC X IF(OVERFL) THEN X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X1 FORMAT(T3,'*',T74,'*') X WRITE(NUNIT,2) X2 FORMAT(T3,'*',4X,'WARNING: JACOBIAN NOT UPDATED', X $ ' TO AVOID OVERFLOW IN DENOMINATOR OF',T74,'*', X $ /T3,'*',4X,'LEE AND LEE UPDATE',T74,'*') X END IF X RETURN X END IF XC XC IF DENOM IS ZERO THE SOLVER IS PROBABLY NEAR SOLUTION - XC AVOID OVERFLOW AND CONTINUE WITH SAME JACOBIAN. XC X IF(DENOM.EQ.ZERO) RETURN XC XC THE SCALED VERSION OF S IS TAKEN TO THE UPDATE. XC X DO 400 I=1,N X W(I)=W(I)*SCALEX(I)*SCALEX(I)/DENOM X400 CONTINUE XC XC UPDATE THE QR DECOMPOSITION USING A SERIES OF GIVENS XC (JACOBI) ROTATIONS. XC X CALL QRUPDA(OVERFL,MAXEXP,N,EPSMCH,A,JAC,T,W) XC XC RESET RDIAG AS DIAGONAL OF CURRENT R WHICH IS IN XC THE UPPER TRIANGLE OF A. XC X DO 500 I=1,N X RDIAG(I)=A(I,I) X500 CONTINUE XC XC UPDATE P MATRIX XC X DENOM=OMEGA**(ISEJAC+2)+DENOM X PLEE(1,1)=PLEE(1,1)-WV3(1)*WV3(1)/DENOM X DO 600 J=2,N X DO 700 I=1,J-1 X PLEE(I,J)=PLEE(I,J)-WV3(I)*WV3(J)/DENOM X PLEE(J,I)=PLEE(I,J) X700 CONTINUE X PLEE(J,J)=PLEE(J,J)-WV3(J)*WV3(J)/DENOM X600 CONTINUE X END IF XC XC UPDATE THE GRADIENT VECTOR, DELF. XC XC DELF = (QR)^F = R^Q^F = R^JAC F XC X IF(SCLFCH) THEN X DO 800 I=1,N X W(I)=FVEC(I)*SCALEF(I) X800 CONTINUE X ELSE X CALL MATCOP(N,N,1,1,N,1,FVEC,W) X END IF X CALL AVMUL(N,N,N,N,JAC,W,T) X CALL UTBMUL(N,N,1,1,N,N,A,T,DELF) X RETURN XC XC LAST CARD OF SUBROUTINE LLFA. XC X END X END_OF_FILE if test 4203 -ne `wc -c <'llfa.f'`; then echo shar: \"'llfa.f'\" unpacked with wrong size! fi # end of 'llfa.f' fi if test -f 'llun.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'llun.f'\" else echo shar: Extracting \"'llun.f'\" \(2516 characters\) sed "s/^X//" >'llun.f' <<'END_OF_FILE' X SUBROUTINE LLUN(OVERCH,OVERFL,ISEJAC,MAXEXP,N , X $ NUNIT ,OUTPUT,EPSMCH,OMEGA ,FVEC , X $ FVECC ,JAC ,PLEE ,S ,SCALEX, X $ WV1 ,XC ,XPLUS) XC XC FEB. 13, 1991 XC XC UPDATE THE JACOBIAN USING THE LEE AND LEE METHOD. XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION JAC(N,N) X INTEGER OUTPUT X DIMENSION FVEC(N) ,FVECC(N) ,PLEE(N,N) ,S(N) , X $ SCALEX(N),WV1(N) ,XC(N) ,XPLUS(N) X LOGICAL OVERCH ,OVERFL X DATA ZERO /0.0D0/ XC X SQRTEP=SQRT(EPSMCH) XC X DO 100 I=1,N X S(I)=(XPLUS(I)-XC(I))*SCALEX(I) X100 CONTINUE X DO 200 I=1,N X WV1(I)=ZERO X DO 300 J=1,N X WV1(I)=WV1(I)+S(J)*PLEE(J,I) X300 CONTINUE X200 CONTINUE X CALL INNERP(OVERCH,OVERFL,MAXEXP,N ,N ,N , X $ NUNIT ,OUTPUT, DENOM,WV1 ,S ) XC XC IF OVERFLOW WOULD OCCUR MAKE NO CHANGE TO JACOBIAN. XC X IF(OVERFL) THEN X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X1 FORMAT(T3,'*',T74,'*') X WRITE(NUNIT,2) X2 FORMAT(T3,'*',4X,'WARNING: JACOBIAN NOT UPDATED', X $ ' TO AVOID OVERFLOW IN DENOMINATOR OF',T74,'*') X WRITE(NUNIT,3) X3 FORMAT(T3,'*',4X,'LEE AND LEE UPDATE',T74,'*') X END IF X RETURN X END IF XC XC IF DENOM IS ZERO THE SOLVER MUST BE VERY NEAR SOLUTION - XC AVOID OVERFLOW AND CONTINUE WITH SAME JACOBIAN. XC X IF(DENOM.EQ.ZERO) RETURN X DO 400 I=1,N X SUM=ZERO X DO 500 J=1,N X SUM=SUM+JAC(I,J)*(XPLUS(J)-XC(J)) X500 CONTINUE X TEMPI=FVEC(I)-FVECC(I)-SUM X IF(ABS(TEMPI).GE.SQRTEP*(ABS(FVEC(I))+ABS(FVECC(I)))) X $ THEN X TEMPI=TEMPI/DENOM X DO 600 J=1,N X JAC(I,J)=JAC(I,J)+TEMPI*WV1(J)*SCALEX(J) X600 CONTINUE X END IF X400 CONTINUE XC XC UPDATE P MATRIX. XC X DENOM=OMEGA**(ISEJAC+2)+DENOM X PLEE(1,1)=PLEE(1,1)-WV1(1)*WV1(1)/DENOM X DO 700 J=2,N X DO 800 I=1,J-1 X PLEE(I,J)=PLEE(I,J)-WV1(I)*WV1(J)/ X $ (DENOM*SCALEX(I)*SCALEX(J)) X PLEE(J,I)=PLEE(I,J) X800 CONTINUE X PLEE(J,J)=PLEE(J,J)-WV1(J)*WV1(J)/DENOM X700 CONTINUE X RETURN XC XC LAST CARD OF SUBROUTINE LLUN. XC X END END_OF_FILE if test 2516 -ne `wc -c <'llun.f'`; then echo shar: \"'llun.f'\" unpacked with wrong size! fi # end of 'llun.f' fi if test -f 'lsolv.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'lsolv.f'\" else echo shar: Extracting \"'lsolv.f'\" \(3113 characters\) sed "s/^X//" >'lsolv.f' <<'END_OF_FILE' X SUBROUTINE LSOLV(OVERCH,OVERFL,MAXEXP,N,NUNIT,OUTPUT,L,B,RHS) XC XC FEB. 14, 1991 XC XC THIS SUBROUTINE SOLVES: XC XC LB=RHS XC XC WHERE L IS TAKEN FROM THE CHOLESKY DECOMPOSITION XC RHS IS A GIVEN RIGHT HAND SIDE WHICH IS NOT XC OVERWRITTEN XC B IS THE SOLUTION VECTOR XC XC FRSTER IS USED FOR OUTPUT PURPOSES ONLY. XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION L(N,N) ,MAXLOG X INTEGER OUTPUT X DIMENSION B(N) ,RHS(N) X LOGICAL FRSTER ,OVERCH ,OVERFL X DATA ZERO,ONE,TEN /0.0D0,1.0D0,10.0D0/ XC X FRSTER=.TRUE. X OVERFL=.FALSE. X EPS=TEN**(-MAXEXP) XC X IF(OVERCH) THEN X IF(LOG10(ABS(RHS(1))+EPS)-LOG10(ABS(L(1,1))+EPS) X $ .GT.MAXEXP) THEN X OVERFL=.TRUE. X B(1)=SIGN(TEN**MAXEXP,RHS(1))* X $ SIGN(ONE,L(1,1)) X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X1 FORMAT(T3,'*',T74,'*') X WRITE(NUNIT,2) 1,B(1) X2 FORMAT(T3,'*',4X,'WARNING: COMPONENT ',I3, X $ ' SET TO ',1PD11.3,T74,'*') X END IF X GO TO 101 X END IF X END IF X B(1)=RHS(1)/L(1,1) X101 CONTINUE X DO 200 I=2,N X IF(OVERCH) THEN XC XC CHECK TO FIND IF ANY TERMS IN THE EVALUATION WOULD XC OVERFLOW. XC X MAXLOG=LOG10(ABS(RHS(I))+EPS)-LOG10(ABS(L(I,I))+EPS) X JSTAR=0 X DO 300 J=1,I-1 X TMPLOG=LOG10(ABS(L(I,J))+EPS)+LOG10(ABS(B(J))+EPS)- X $ LOG10(ABS(L(I,I))+EPS) X IF(TMPLOG.GT.MAXLOG) THEN X JSTAR=J X MAXLOG=TMPLOG X END IF X300 CONTINUE XC XC IF AN OVERFLOW WOULD OCCUR ASSIGN A VALUE FOR THE XC TERM WITH CORRECT SIGN. XC X IF(MAXLOG.GT.MAXEXP) THEN X OVERFL=.TRUE. X IF(JSTAR.EQ.0) THEN X B(I)=SIGN(TEN**MAXEXP,RHS(I))* X $ SIGN(ONE,L(I,I)) X ELSE X B(I)=-SIGN(TEN**MAXEXP,L(I,JSTAR))* X $ SIGN(ONE,B(JSTAR))* X $ SIGN(ONE,L(I,I)) X END IF X IF(FRSTER) THEN X FRSTER=.FALSE. X WRITE(NUNIT,1) X END IF X IF(OUTPUT.GT.3) WRITE(NUNIT,2) I,B(I) X GO TO 201 X END IF X END IF XC XC SUM FOR EACH TERM, ORDERING OPERATIONS TO MINIMIZE XC POSSIBILITY OF OVERFLOW. XC X SUM=ZERO X DO 400 J=1,I-1 X SUM=SUM+(MIN(ABS(L(I,J)),ABS(B(J)))/L(I,I))* X $ (MAX(ABS(L(I,J)),ABS(B(J))))* X $ SIGN(ONE,L(I,J))*SIGN(ONE,B(J)) X400 CONTINUE X B(I)=RHS(I)/L(I,I)-SUM X201 CONTINUE X200 CONTINUE X RETURN XC XC LAST CARD OF SUBROUTINE LSOLV. XC X END END_OF_FILE if test 3113 -ne `wc -c <'lsolv.f'`; then echo shar: \"'lsolv.f'\" unpacked with wrong size! fi # end of 'lsolv.f' fi if test -f 'ltsolv.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'ltsolv.f'\" else echo shar: Extracting \"'ltsolv.f'\" \(3176 characters\) sed "s/^X//" >'ltsolv.f' <<'END_OF_FILE' X SUBROUTINE LTSOLV(OVERCH,OVERFL,MAXEXP,N ,NUNIT , X $ OUTPUT,L ,Y ,B ) XC XC FEB. 14, 1991 XC XC THIS SUBROUTINE SOLVES: XC XC L^Y=B XC XC WHERE L IS TAKEN FROM THE CHOLESKY DECOMPOSITION XC B IS A GIVEN RIGHT HAND SIDE WHICH IS NOT XC OVERWRITTEN XC Y IS THE SOLUTION VECTOR XC XC FRSTER IS USED FOR OUTPUT PURPOSES ONLY. XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION L(N,N) ,MAXLOG X INTEGER OUTPUT X DIMENSION B(N) ,Y(N) X LOGICAL FRSTER ,OVERCH ,OVERFL X DATA ZERO,ONE,TEN /0.0D0,1.0D0,10.0D0/ XC X FRSTER=.TRUE. X OVERFL=.FALSE. X EPS=TEN**(-MAXEXP) XC X IF(OVERCH) THEN X IF(LOG10(ABS(B(N))+EPS)-LOG10(ABS(L(N,N))+EPS) X $ .GT.MAXEXP) THEN X OVERFL=.TRUE. X Y(N)=SIGN(TEN**MAXEXP,B(N))* X $ SIGN(ONE,L(N,N)) X IF(OUTPUT.GT.3) THEN X FRSTER=.FALSE. X WRITE(NUNIT,1) X1 FORMAT(T3,'*',70X,'*') X WRITE(NUNIT,2) N,Y(N) X2 FORMAT(T3,'*',4X,'WARNING: COMPONENT ',I3, X $ ' SET TO ',1PD11.3,25X,'*') X END IF X GO TO 101 X END IF X END IF X Y(N)=B(N)/L(N,N) X101 CONTINUE X DO 200 I=N-1,1,-1 X IF(OVERCH) THEN XC XC CHECK TO FIND IF ANY TERMS IN THE EVALUATION WOULD XC OVERFLOW. XC X MAXLOG=LOG10(ABS(B(I))+EPS)-LOG10(ABS(L(I,I))+EPS) X JSTAR=0 X DO 300 J=I+1,N X TMPLOG=LOG10(ABS(L(J,I))+EPS)+LOG10(ABS(Y(J))+EPS)- X $ LOG10(ABS(L(I,I))+EPS) X IF(TMPLOG.GT.MAXLOG) THEN X JSTAR=J X MAXLOG=TMPLOG X END IF X300 CONTINUE XC XC IF AN OVERFLOW WOULD OCCUR ASSIGN A VALUE FOR THE XC TERM WITH CORRECT SIGN. XC X IF(MAXLOG.GT.MAXEXP) THEN X OVERFL=.TRUE. X IF(JSTAR.EQ.0) THEN X Y(I)=SIGN(TEN**MAXEXP,B(I))* X $ SIGN(ONE,L(I,I)) X ELSE X Y(I)=-SIGN(TEN**MAXEXP,L(JSTAR,I))* X $ SIGN(ONE,Y(JSTAR))* X $ SIGN(ONE,L(I,I)) X END IF X IF(FRSTER) THEN X FRSTER=.FALSE. X WRITE(NUNIT,1) X END IF X IF(OUTPUT.GT.3) WRITE(NUNIT,2) I,Y(I) X GO TO 201 X END IF X END IF XC XC SUM FOR EACH TERM ORDERING OPERATIONS TO MINIMIZE XC POSSIBILITY OF OVERFLOW. XC X SUM=ZERO X DO 400 J=I+1,N X SUM=SUM+(MIN(ABS(L(J,I)),ABS(Y(J)))/L(I,I))* X $ (MAX(ABS(L(J,I)),ABS(Y(J))))* X $ SIGN(ONE,L(J,I))*SIGN(ONE,Y(J)) X400 CONTINUE X Y(I)=B(I)/L(I,I)-SUM X201 CONTINUE X200 CONTINUE X RETURN XC XC LAST CARD OF SUBROUTINE LTSOLV. XC X END END_OF_FILE if test 3176 -ne `wc -c <'ltsolv.f'`; then echo shar: \"'ltsolv.f'\" unpacked with wrong size! fi # end of 'ltsolv.f' fi if test -f 'machar.f0' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'machar.f0'\" else echo shar: Extracting \"'machar.f0'\" \(10837 characters\) sed "s/^X//" >'machar.f0' <<'END_OF_FILE' X SUBROUTINE MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP, X 1 MAXEXP,EPS,EPSNEG,XMIN,XMAX) XC----------------------------------------------------------------------- XC This Fortran 77 subroutine is intended to determine the parameters XC of the floating-point arithmetic system specified below. The XC determination of the first three uses an extension of an algorithm XC due to M. Malcolm, CACM 15 (1972), pp. 949-951, incorporating some, XC but not all, of the improvements suggested by M. Gentleman and S. XC Marovich, CACM 17 (1974), pp. 276-277. An earlier version of this XC program was published in the book Software Manual for the XC Elementary Functions by W. J. Cody and W. Waite, Prentice-Hall, XC Englewood Cliffs, NJ, 1980. The present version is documented in XC W. J. Cody, "MACHAR: A subroutine to dynamically determine machine XC parameters," TOMS 14, December, 1988. XC XC The program as given here must be modified before compiling. If XC a single (double) precision version is desired, change all XC occurrences of CS (CD) in columns 1 and 2 to blanks. XC XC Parameter values reported are as follows: XC XC IBETA - the radix for the floating-point representation XC IT - the number of base IBETA digits in the floating-point XC significand XC IRND - 0 if floating-point addition chops XC 1 if floating-point addition rounds, but not in the XC IEEE style XC 2 if floating-point addition rounds in the IEEE style XC 3 if floating-point addition chops, and there is XC partial underflow XC 4 if floating-point addition rounds, but not in the XC IEEE style, and there is partial underflow XC 5 if floating-point addition rounds in the IEEE style, XC and there is partial underflow XC NGRD - the number of guard digits for multiplication with XC truncating arithmetic. It is XC 0 if floating-point arithmetic rounds, or if it XC truncates and only IT base IBETA digits XC participate in the post-normalization shift of the XC floating-point significand in multiplication; XC 1 if floating-point arithmetic truncates and more XC than IT base IBETA digits participate in the XC post-normalization shift of the floating-point XC significand in multiplication. XC MACHEP - the largest negative integer such that XC 1.0+FLOAT(IBETA)**MACHEP .NE. 1.0, except that XC MACHEP is bounded below by -(IT+3) XC NEGEPS - the largest negative integer such that XC 1.0-FLOAT(IBETA)**NEGEPS .NE. 1.0, except that XC NEGEPS is bounded below by -(IT+3) XC IEXP - the number of bits (decimal places if IBETA = 10) XC reserved for the representation of the exponent XC (including the bias or sign) of a floating-point XC number XC MINEXP - the largest in magnitude negative integer such that XC FLOAT(IBETA)**MINEXP is positive and normalized XC MAXEXP - the smallest positive power of BETA that overflows XC EPS - the smallest positive floating-point number such XC that 1.0+EPS .NE. 1.0. In particular, if either XC IBETA = 2 or IRND = 0, EPS = FLOAT(IBETA)**MACHEP. XC Otherwise, EPS = (FLOAT(IBETA)**MACHEP)/2 XC EPSNEG - A small positive floating-point number such that XC 1.0-EPSNEG .NE. 1.0. In particular, if IBETA = 2 XC or IRND = 0, EPSNEG = FLOAT(IBETA)**NEGEPS. XC Otherwise, EPSNEG = (IBETA**NEGEPS)/2. Because XC NEGEPS is bounded below by -(IT+3), EPSNEG may not XC be the smallest number that can alter 1.0 by XC subtraction. XC XMIN - the smallest non-vanishing normalized floating-point XC power of the radix, i.e., XMIN = FLOAT(IBETA)**MINEXP XC XMAX - the largest finite floating-point number. In XC particular XMAX = (1.0-EPSNEG)*FLOAT(IBETA)**MAXEXP XC Note - on some machines XMAX will be only the XC second, or perhaps third, largest number, being XC too small by 1 or 2 units in the last digit of XC the significand. XC XC Latest revision - December 4, 1987 XC XC Author - W. J. Cody XC Argonne National Laboratory XC XC----------------------------------------------------------------------- X INTEGER I,IBETA,IEXP,IRND,IT,ITEMP,IZ,J,K,MACHEP,MAXEXP, X 1 MINEXP,MX,NEGEP,NGRD,NXRES X DOUBLE PRECISION X 1 A,B,BETA,BETAIN,BETAH,CONV,EPS,EPSNEG,ONE,T,TEMP,TEMPA, X 2 TEMP1,TWO,XMAX,XMIN,Y,Z,ZERO XC----------------------------------------------------------------------- X CONV(I) = DBLE(I) X ONE = CONV(1) X TWO = ONE + ONE X ZERO = ONE - ONE XC----------------------------------------------------------------------- XC Determine IBETA, BETA ala Malcolm. XC----------------------------------------------------------------------- X A = ONE X 10 A = A + A X TEMP = A+ONE X TEMP1 = TEMP-A X IF (TEMP1-ONE .EQ. ZERO) GO TO 10 X B = ONE X 20 B = B + B X TEMP = A+B X ITEMP = INT(TEMP-A) X IF (ITEMP .EQ. 0) GO TO 20 X IBETA = ITEMP X BETA = CONV(IBETA) XC----------------------------------------------------------------------- XC Determine IT, IRND. XC----------------------------------------------------------------------- X IT = 0 X B = ONE X 100 IT = IT + 1 X B = B * BETA X TEMP = B+ONE X TEMP1 = TEMP-B X IF (TEMP1-ONE .EQ. ZERO) GO TO 100 X IRND = 0 X BETAH = BETA / TWO X TEMP = A+BETAH X IF (TEMP-A .NE. ZERO) IRND = 1 X TEMPA = A + BETA X TEMP = TEMPA+BETAH X IF ((IRND .EQ. 0) .AND. (TEMP-TEMPA .NE. ZERO)) IRND = 2 XC----------------------------------------------------------------------- XC Determine NEGEP, EPSNEG. XC----------------------------------------------------------------------- X NEGEP = IT + 3 X BETAIN = ONE / BETA X A = ONE X DO 200 I = 1, NEGEP X A = A * BETAIN X 200 CONTINUE X B = A X 210 TEMP = ONE-A X IF (TEMP-ONE .NE. ZERO) GO TO 220 X A = A * BETA X NEGEP = NEGEP - 1 X GO TO 210 X 220 NEGEP = -NEGEP X EPSNEG = A XC----------------------------------------------------------------------- XC Determine MACHEP, EPS. XC----------------------------------------------------------------------- X MACHEP = -IT - 3 X A = B X 300 TEMP = ONE+A X IF (TEMP-ONE .NE. ZERO) GO TO 320 X A = A * BETA X MACHEP = MACHEP + 1 X GO TO 300 X 320 EPS = A XC----------------------------------------------------------------------- XC Determine NGRD. XC----------------------------------------------------------------------- X NGRD = 0 X TEMP = ONE+EPS X IF ((IRND .EQ. 0) .AND. (TEMP*ONE-ONE .NE. ZERO)) NGRD = 1 XC----------------------------------------------------------------------- XC Determine IEXP, MINEXP, XMIN. XC XC Loop to determine largest I and K = 2**I such that XC (1/BETA) ** (2**(I)) XC does not underflow. XC Exit from loop is signaled by an underflow. XC----------------------------------------------------------------------- X I = 0 X K = 1 X Z = BETAIN X T = ONE + EPS X NXRES = 0 X 400 Y = Z X Z = Y * Y XC----------------------------------------------------------------------- XC Check for underflow here. XC----------------------------------------------------------------------- X A = Z * ONE X TEMP = Z * T X IF ((A+A .EQ. ZERO) .OR. (ABS(Z) .GE. Y)) GO TO 410 X TEMP1 = TEMP * BETAIN X IF (TEMP1*BETA .EQ. Z) GO TO 410 X I = I + 1 X K = K + K X GO TO 400 X 410 IF (IBETA .EQ. 10) GO TO 420 X IEXP = I + 1 X MX = K + K X GO TO 450 XC----------------------------------------------------------------------- XC This segment is for decimal machines only. XC----------------------------------------------------------------------- X 420 IEXP = 2 X IZ = IBETA X 430 IF (K .LT. IZ) GO TO 440 X IZ = IZ * IBETA X IEXP = IEXP + 1 X GO TO 430 X 440 MX = IZ + IZ - 1 XC----------------------------------------------------------------------- XC Loop to determine MINEXP, XMIN. XC Exit from loop is signaled by an underflow. XC----------------------------------------------------------------------- X 450 XMIN = Y X Y = Y * BETAIN XC----------------------------------------------------------------------- XC Check for underflow here. XC----------------------------------------------------------------------- X A = Y * ONE X TEMP = Y * T X IF (((A+A) .EQ. ZERO) .OR. (ABS(Y) .GE. XMIN)) GO TO 460 X K = K + 1 X TEMP1 = TEMP * BETAIN X IF ((TEMP1*BETA .NE. Y) .OR. (TEMP .EQ. Y)) THEN X GO TO 450 X ELSE X NXRES = 3 X XMIN = Y X END IF X 460 MINEXP = -K XC----------------------------------------------------------------------- XC Determine MAXEXP, XMAX. XC----------------------------------------------------------------------- X IF ((MX .GT. K+K-3) .OR. (IBETA .EQ. 10)) GO TO 500 X MX = MX + MX X IEXP = IEXP + 1 X 500 MAXEXP = MX + MINEXP XC----------------------------------------------------------------- XC Adjust IRND to reflect partial underflow. XC----------------------------------------------------------------- X IRND = IRND + NXRES XC----------------------------------------------------------------- XC Adjust for IEEE-style machines. XC----------------------------------------------------------------- X IF (IRND .GE. 2) MAXEXP = MAXEXP - 2 XC----------------------------------------------------------------- XC Adjust for machines with implicit leading bit in binary XC significand, and machines with radix point at extreme XC right of significand. XC----------------------------------------------------------------- X I = MAXEXP + MINEXP X IF ((IBETA .EQ. 2) .AND. (I .EQ. 0)) MAXEXP = MAXEXP - 1 X IF (I .GT. 20) MAXEXP = MAXEXP - 1 X IF (A .NE. Y) MAXEXP = MAXEXP - 2 X XMAX = ONE - EPSNEG X IF (XMAX*ONE .NE. XMAX) XMAX = ONE - BETA * EPSNEG X XMAX = XMAX / (BETA * BETA * BETA * XMIN) X I = MAXEXP + MINEXP + 3 X IF (I .LE. 0) GO TO 520 X DO 510 J = 1, I X IF (IBETA .EQ. 2) XMAX = XMAX + XMAX X IF (IBETA .NE. 2) XMAX = XMAX * BETA X 510 CONTINUE X 520 RETURN XC---------- LAST CARD OF MACHAR ---------- X END END_OF_FILE if test 10837 -ne `wc -c <'machar.f0'`; then echo shar: \"'machar.f0'\" unpacked with wrong size! fi # end of 'machar.f0' fi if test -f 'matcop.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'matcop.f'\" else echo shar: Extracting \"'matcop.f'\" \(3342 characters\) sed "s/^X//" >'matcop.f' <<'END_OF_FILE' X SUBROUTINE MATCOP(NRADEC,NRAACT,NCADEC,NCAACT,NRBDEC, X $ NCBDEC,AMAT ,BMAT ) XC XC SEPT. 15, 1991 XC XC COPY A CONTINGUOUS RECTANGULAR PORTION OF ONE MATRIX XC INTO ANOTHER (ELEMENT (1,1) MUST BE INCLUDED). XC XC NRADEC IS 1ST DIMENSION OF AMAT, NRAACT IS LIMIT OF 1ST INDEX XC NCADEC IS 2ND DIMENSION OF AMAT, NCAACT IS LIMIT OF 2ND INDEX XC NRBDEC IS 1ST DIMENSION OF BMAT XC NCBDEC IS 2ND DIMENSION OF BMAT XC X IMPLICIT DOUBLE PRECISION(A-H,O-Z) X DIMENSION AMAT(NRADEC,NCADEC) ,BMAT(NRBDEC,NCBDEC) XC XC FIND NUMBER OF GROUPS OF SIZE 32, 16 ... XC X NCC32=NRAACT/32 X NCC32R=NRAACT-32*NCC32 X NCC16=NCC32R/16 X NCC16R=NCC32R-16*NCC16 X NCC8=NCC16R/8 X NCC8R=NCC16R-8*NCC8 X NCC4=NCC8R/4 X NCC4R=NCC8R-4*NCC4 X DO 100 J=1,NCAACT XC XC COPY ENTRIES INTO MATRIX B BY COLUMN. XC X K=0 X IF(NCC32.GT.0) THEN X DO 200 KK=1,NCC32 X K=K+32 X BMAT(K-31,J)=AMAT(K-31,J) X BMAT(K-30,J)=AMAT(K-30,J) X BMAT(K-29,J)=AMAT(K-29,J) X BMAT(K-28,J)=AMAT(K-28,J) X BMAT(K-27,J)=AMAT(K-27,J) X BMAT(K-26,J)=AMAT(K-26,J) X BMAT(K-25,J)=AMAT(K-25,J) X BMAT(K-24,J)=AMAT(K-24,J) X BMAT(K-23,J)=AMAT(K-23,J) X BMAT(K-22,J)=AMAT(K-22,J) X BMAT(K-21,J)=AMAT(K-21,J) X BMAT(K-20,J)=AMAT(K-20,J) X BMAT(K-19,J)=AMAT(K-19,J) X BMAT(K-18,J)=AMAT(K-18,J) X BMAT(K-17,J)=AMAT(K-17,J) X BMAT(K-16,J)=AMAT(K-16,J) X BMAT(K-15,J)=AMAT(K-15,J) X BMAT(K-14,J)=AMAT(K-14,J) X BMAT(K-13,J)=AMAT(K-13,J) X BMAT(K-12,J)=AMAT(K-12,J) X BMAT(K-11,J)=AMAT(K-11,J) X BMAT(K-10,J)=AMAT(K-10,J) X BMAT(K- 9,J)=AMAT(K- 9,J) X BMAT(K- 8,J)=AMAT(K- 8,J) X BMAT(K- 7,J)=AMAT(K- 7,J) X BMAT(K- 6,J)=AMAT(K- 6,J) X BMAT(K- 5,J)=AMAT(K- 5,J) X BMAT(K- 4,J)=AMAT(K- 4,J) X BMAT(K- 3,J)=AMAT(K- 3,J) X BMAT(K- 2,J)=AMAT(K- 2,J) X BMAT(K- 1,J)=AMAT(K- 1,J) X BMAT(K ,J)=AMAT(K ,J) X200 CONTINUE X END IF X IF(NCC16.GT.0) THEN X DO 300 KK=1,NCC16 X K=K+16 X BMAT(K-15,J)=AMAT(K-15,J) X BMAT(K-14,J)=AMAT(K-14,J) X BMAT(K-13,J)=AMAT(K-13,J) X BMAT(K-12,J)=AMAT(K-12,J) X BMAT(K-11,J)=AMAT(K-11,J) X BMAT(K-10,J)=AMAT(K-10,J) X BMAT(K- 9,J)=AMAT(K- 9,J) X BMAT(K- 8,J)=AMAT(K- 8,J) X BMAT(K- 7,J)=AMAT(K- 7,J) X BMAT(K- 6,J)=AMAT(K- 6,J) X BMAT(K- 5,J)=AMAT(K- 5,J) X BMAT(K- 4,J)=AMAT(K- 4,J) X BMAT(K- 3,J)=AMAT(K- 3,J) X BMAT(K- 2,J)=AMAT(K- 2,J) X BMAT(K- 1,J)=AMAT(K- 1,J) X BMAT(K ,J)=AMAT(K ,J) X300 CONTINUE X END IF X IF(NCC8.GT.0) THEN X DO 400 KK=1,NCC8 X K=K+8 X BMAT(K- 7,J)=AMAT(K- 7,J) X BMAT(K- 6,J)=AMAT(K- 6,J) X BMAT(K- 5,J)=AMAT(K- 5,J) X BMAT(K- 4,J)=AMAT(K- 4,J) X BMAT(K- 3,J)=AMAT(K- 3,J) X BMAT(K- 2,J)=AMAT(K- 2,J) X BMAT(K- 1,J)=AMAT(K- 1,J) X BMAT(K ,J)=AMAT(K ,J) X400 CONTINUE X END IF X IF(NCC4.GT.0) THEN X DO 500 KK=1,NCC4 X K=K+4 X BMAT(K- 3,J)=AMAT(K- 3,J) X BMAT(K- 2,J)=AMAT(K- 2,J) X BMAT(K- 1,J)=AMAT(K- 1,J) X BMAT(K ,J)=AMAT(K ,J) X500 CONTINUE X END IF X IF(NCC4R.GT.0) THEN X DO 600 KK=1,NCC4R X K=K+1 X BMAT(K,J)=AMAT(K,J) X600 CONTINUE X END IF X100 CONTINUE X RETURN XC XC LAST CARD OF SUBROUTINE MATCOP. XC X END END_OF_FILE if test 3342 -ne `wc -c <'matcop.f'`; then echo shar: \"'matcop.f'\" unpacked with wrong size! fi # end of 'matcop.f' fi if test -f 'matprt.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'matprt.f'\" else echo shar: Extracting \"'matprt.f'\" \(2188 characters\) sed "s/^X//" >'matprt.f' <<'END_OF_FILE' X SUBROUTINE MATPRT(NROWA,NCOLA,NROWPR,NCOLPR,NUNIT,A) XC XC FEB. 6, 1991 XC XC THIS SUBROUTINE PRINTS RECTANGULAR BLOCKS STARTING WITH XC ELEMENT A(1,1) OF SIZE NROWPR BY NCOLPR FOR MATRIX A XC (WHICH HAS DECLARED SIZE NROWA BY NCOLA). THE MATRIX IS XC PRINTED AS A BLOCK FOR SIZES UP TO 5X5 OR BY COLUMNS IF XC IT IS LARGER. XC XC NROWA IS THE NUMBER OF DECLARED ROWS IN THE MATRIX XC NCOLA IS THE NUMBER OF DECLARED COLUMNS IN THE MATRIX XC XC NROWPR IS THE NUMBER OF ROWS TO BE PRINTED XC NCOLPR IS THE NUMBER OF COLUMNS TO BE PRINTED XC XC IF MATRIX PRINTING IS TO BE SUPPRESSED THEN LOGICAL XC VARIABLE MATSUP MUST BE SET TO TRUE BEFORE THE CALL XC TO NNES. XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION A(NROWA,NCOLA) X LOGICAL MATSUP X COMMON/NNES_1/MATSUP XC X IF(MATSUP) THEN X WRITE(NUNIT,1) X1 FORMAT(T3,'*',T74,'*') X WRITE(NUNIT,2) X2 FORMAT(T3,'*',7X,'MATRIX PRINTING SUPPRESSED',T74,'*') X RETURN X END IF XC XC FOR NCOLPR <= 5 WRITE MATRIX AS A WHOLE. XC X WRITE(NUNIT,1) X IF(NCOLPR.LE.5) THEN X WRITE(NUNIT,3) (K,K=1,NCOLPR) X3 FORMAT(T74,'*',T3,'*',2X,5(I12:)) X WRITE(NUNIT,1) X DO 100 I=1,NROWPR X WRITE(NUNIT,4) I,(A(I,K),K=1,NCOLPR) X4 FORMAT(T74,'*',T3,'*',3X,I3,5(1PD12.3:)) X100 CONTINUE X ELSE XC XC LIMIT IS THE NUMBER OF GROUPS OF 5 COLUMNS. XC X LIMIT=NCOLPR/5 XC XC WRITE COMPLETE BLOCKS FIRST (LEFTOVERS LATER). XC X DO 200 J=1,LIMIT X WRITE(NUNIT,5) (K,K=1+(J-1)*5,5+(J-1)*5) X5 FORMAT(T3,'*',2X,5I12,T74,'*') X WRITE(NUNIT,1) X DO 300 I=1,NROWPR X WRITE(NUNIT,6) I,(A(I,K),K=1+(J-1)*5,5+(J-1)*5) X6 FORMAT(T3,'*',3X,I3,5(1PD12.3),T74,'*') X300 CONTINUE X WRITE(NUNIT,1) X200 CONTINUE XC XC WRITE REMAINING ELEMENTS. XC X WRITE(NUNIT,7) (K,K=5*LIMIT+1,NCOLPR) X7 FORMAT(T74,'*',T3,'*',2X,4(I12:)) X WRITE(NUNIT,1) X DO 400 I=1,NROWPR X WRITE(NUNIT,8) I,(A(I,K),K=5*LIMIT+1,NCOLPR) X8 FORMAT(T74,'*',T3,'*',3X,I3,4(1PD12.3:)) X400 CONTINUE X END IF X RETURN XC XC LAST CARD OF SUBROUTINE MATPRT. XC X END X END_OF_FILE if test 2188 -ne `wc -c <'matprt.f'`; then echo shar: \"'matprt.f'\" unpacked with wrong size! fi # end of 'matprt.f' fi if test -f 'maxst.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'maxst.f'\" else echo shar: Extracting \"'maxst.f'\" \(2128 characters\) sed "s/^X//" >'maxst.f' <<'END_OF_FILE' X SUBROUTINE MAXST(OVERFL,MAXEXP,N ,NUNIT ,OUTPUT,EPSMCH, X $ MAXSTP,MSTPF ,SCALEX,WV1 ,XC ) XC XC FEB. 11, 1991 XC XC THIS SUBROUTINE ESTABLISHES A MAXIMUM STEP LENGTH BASED ON XC THE 2-NORMS OF THE INITIAL ESTIMATES AND THE SCALING FACTORS XC MULTIPLIED BY A FACTOR MSTPF. XC XC MAXSTP=MSTPF*MAX{ NORM1 , NORM2 } XC XC WHERE MSTPF USER-CHOSEN FACTOR (DEFAULT: 1000) XC NORM1 2-NORM OF SCALED STARTING ESTIMATES XC NORM2 2-NORM OF COMPONENT SCALING FACTORS XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION MAXSTP ,MSTPF ,NORM1 ,NORM2 X INTEGER OUTPUT X DIMENSION SCALEX(N),WV1(N) ,XC(N) X LOGICAL OVERFL ,WRNSUP X COMMON/NNES_2/WRNSUP X DATA TEN /10.0D0/ XC X OVERFL=.FALSE. XC X DO 100 I=1,N X WV1(I)=SCALEX(I)*XC(I) X100 CONTINUE X CALL TWONRM(OVERFL,MAXEXP,N,EPSMCH,NORM1,WV1) X IF(OVERFL) THEN X MAXSTP=TEN**MAXEXP X IF(OUTPUT.GT.2.AND.(.NOT.WRNSUP)) THEN X WRITE(NUNIT,1) X1 FORMAT(T3,'*',T74,'*') X WRITE(NUNIT,2) NORM1 X2 FORMAT(T3,'*',4X,'WARNING: NORM OF SCALED INITIAL ', X $ 'ESTIMATE SET TO ',1PD12.3,T74,'*') X WRITE(NUNIT,1) X WRITE(NUNIT,3) MAXSTP X3 FORMAT(T3,'*',7X,'MAXIMUM STEP SIZE, MAXSTP, SET TO ', X $ 1PD12.3,T74,'*') X END IF X RETURN X END IF X CALL TWONRM(OVERFL,MAXEXP,N,EPSMCH,NORM2,SCALEX) X IF(OVERFL) THEN X MAXSTP=TEN**MAXEXP X IF(OUTPUT.GT.2.AND.(.NOT.WRNSUP)) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,4) NORM2 X4 FORMAT(T3,'*',4X,'WARNING: NORM OF SCALING FACTORS ', X $ 'SET TO ',1PD12.3,T74,'*') X WRITE(NUNIT,1) X WRITE(NUNIT,3) MAXSTP X END IF X RETURN X END IF X MAXSTP=MSTPF*MAX(NORM1,NORM2) X RETURN XC XC LAST CARD OF SUBROUTINE MAXST. XC X END END_OF_FILE if test 2128 -ne `wc -c <'maxst.f'`; then echo shar: \"'maxst.f'\" unpacked with wrong size! fi # end of 'maxst.f' fi if test -f 'mdr.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'mdr.f'\" else echo shar: Extracting \"'mdr.f'\" \(22091 characters\) sed "s/^X//" >'mdr.f' <<'END_OF_FILE' X PROGRAM MDR XC XC MASTER DRIVER FOR MORE, GARBOW AND HILLSTROM PROBLEMS XC XC AS GIVEN NOW NTEST RUNS FROM 1 TO 2 THUS TESTING ONLY NEWTON'S XC BASIC PROGRAM. IT CAN BE RUN FROM 1 TO 9 TO TEST DIFFERENT XC ASPECTS. XC XC PROGRAM RUNS QUICKLY EXCEPT FOR WATSON PROBLEM (#6 AND 7). XC XC SUFFIX COMM ON OUTPUT FILES INDICATES FOR COMMUNICATION TO XC COMPUTERS AND CHEM. ENG. XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X PARAMETER ( MGLL= 10, X $ N= 40, X $ NUNIT= 10) X DOUBLE PRECISION X $ JAC(N,N) ,LAM0 ,MSTPF ,NSTTOL X INTEGER ACPTCR ,OUTPUT ,QNUPDM ,STOPCR , X $ SUPPRS ,TRMCOD ,TRUPDM X DIMENSION A(N,N) ,BOUNDL(N) ,BOUNDU(N) ,DELF(N) , X $ FSAVE(N) ,FTRACK(0:MGLL-1) ,FVEC(N) , X $ FVECC(N) ,H(N,N) ,HHPI(N) ,PLEE(N,N), X $ RDIAG(N) ,S(N) ,SBAR(N) ,SCALEF(N), X $ SCALEX(N) ,SN(N) ,SSDHAT(N) , X $ STRACK(0:MGLL-1) ,VHAT(N) ,WV1(N) , X $ WV2(N) ,WV3(N) ,WV4(N) ,XC(N) , X $ XPLUS(N) ,XSAVE(N) X LOGICAL ABSNEW ,BYPASS ,CAUCHY ,DEUFLH , X $ GEOMS ,LINESR ,MATSUP ,NEWTON , X $ OVERCH ,WRNSUP X CHARACTER*6 HELP X CHARACTER*25 NAME X DIMENSION NFE(6),ISUM(6) X EXTERNAL FCN,JACOB X COMMON/NNES_1/MATSUP X COMMON/NNES_2/WRNSUP X COMMON/NNES_3/BYPASS X COMMON/NNES_4/NFETOT X COMMON/PROBN/NPROB X COMMON/H3R/R X DO 10000 NTEST=2,2 X DO 10 I=1,6 X ISUM(I)=0 X 10 CONTINUE X IF(NTEST.EQ.1) THEN X OPEN(UNIT=NUNIT,FILE='T1.OUT',STATUS='UNKNOWN') X ELSEIF(NTEST.EQ.2) THEN X OPEN(UNIT=NUNIT,FILE='T2.OUT',STATUS='UNKNOWN') X ELSEIF(NTEST.EQ.3) THEN X OPEN(UNIT=NUNIT,FILE='T3.OUT',STATUS='UNKNOWN') X ELSEIF(NTEST.EQ.4) THEN X OPEN(UNIT=NUNIT,FILE='T4.OUT',STATUS='UNKNOWN') X ELSEIF(NTEST.EQ.5) THEN X OPEN(UNIT=NUNIT,FILE='T5.OUT',STATUS='UNKNOWN') X ELSEIF(NTEST.EQ.6) THEN X OPEN(UNIT=NUNIT,FILE='T6.OUT',STATUS='UNKNOWN') X ELSEIF(NTEST.EQ.7) THEN X OPEN(UNIT=NUNIT,FILE='T7.OUT',STATUS='UNKNOWN') X ELSEIF(NTEST.EQ.8) THEN X OPEN(UNIT=NUNIT,FILE='T8.OUT',STATUS='UNKNOWN') X ELSEIF(NTEST.EQ.9) THEN X OPEN(UNIT=NUNIT,FILE='T9.OUT',STATUS='UNKNOWN') X ELSEIF(NTEST.EQ.10) THEN X OPEN(UNIT=NUNIT,FILE='T10.OUT',STATUS='UNKNOWN') X END IF X WRITE(NUNIT,1) NTEST X PRINT 1, NTEST X 1 FORMAT(/T2,'NTEST: ',I3/) X WRITE(NUNIT,2) X 2 FORMAT(/,T30,'NEWTON',10X,'BROYDEN',10X,'LEE AND LEE'/) X WRITE(NUNIT,3) X 3 FORMAT(T29,'LS',4X,'TR',9X,'LS',4X,'TR',11X,'LS',4X,'TR'/) X DO 20000 NPROB=20,20 X PRINT 4, NPROB X 4 FORMAT(T2,'NPROB: ',I3) X ICOUNT=1 X DO 30000 NJUPD=0,0 X DO 40000 METHOD=1,1 X IF(NPROB.EQ.1) THEN XC XC ROSENBROCK BANANA XC X NAME='Rosenbrock Banana' X NDIM=2 X XC(1)=-1.2D0 X XC(2)=1.0D0 X ELSEIF(NPROB.EQ.2) THEN XC XC POWELL SINGULAR XC X NAME='Powell Singular ' X NDIM=4 X XC(1)=3.0D0 X XC(2)=-1.0D0 X XC(3)=0.0D0 X XC(4)=1.0D0 XC X ELSEIF(NPROB.EQ.3) THEN XC XC POWELL BADLY-SCALED XC X NAME='Powell Badly-Scaled' X NDIM=2 X XC(1)=0.0D0 X XC(2)=1.0D0 XC X ELSEIF(NPROB.EQ.4) THEN XC XC WOOD XC X NAME='Wood ' X NDIM=4 X XC(1)=-3.0D0 X XC(2)=-1.0D0 X XC(3)=-3.0D0 X XC(4)=-1.0D0 XC X ELSEIF(NPROB.EQ.5) THEN XC XC HELICAL VALLEY XC X NAME='Helical Valley ' X NDIM=3 X XC(1)=-1.0D0 X XC(2)=0.0D0 X XC(3)=0.0D0 XC X ELSEIF(NPROB.EQ.6.OR.NPROB.EQ.7) THEN XC XC WATSON XC X IF(NPROB.EQ.6) THEN X NAME='Watson 6-d' X NDIM=6 X ELSE X NAME='Watson 9-d' X NDIM=9 X END IF X DO 600 I=1,NDIM X XC(I)=0.0D0 X 600 CONTINUE XC X ELSEIF(NPROB.EQ.8.OR.NPROB.EQ.9.OR.NPROB.EQ.10) THEN XC XC CHEBYQUAD XC X IF(NPROB.EQ.8) THEN X NAME='Chebyquad 5-d ' X NDIM=5 X ELSEIF(NPROB.EQ.9) THEN X NAME='Chebyquad 6-d ' X NDIM=6 X ELSE X NAME='Chebyquad 7-d ' X NDIM=7 X END IF X DO 700 I=1,NDIM X XC(I)=DBLE(I)/(DBLE(NDIM)+1.0D0) X 700 CONTINUE XC X ELSEIF(NPROB.EQ.11.OR.NPROB.EQ.12.OR.NPROB.EQ.13) THEN XC XC BROWN ALMOST-LINEAR XC X IF(NPROB.EQ.11) THEN X NAME='Brown Almost-Linear 10-d ' X NDIM=10 X ELSEIF(NPROB.EQ.12) THEN X NAME='Brown Almost-Linear 30-d ' X NDIM=30 X ELSE X NAME='Brown Almost-Linear 40-d ' X NDIM=40 X END IF X DO 800 I=1,NDIM X XC(I)=0.5D0 X 800 CONTINUE XC X ELSEIF(NPROB.EQ.14.OR.NPROB.EQ.15) THEN XC XC DISCRETE BOUNDARY VALUE XC DISCRETE INTEGRAL XC X if(NPROB.EQ.14) THEN X NAME='Discrete Boundary Value ' X ELSE X NAME='Discrete Integral ' X END IF X NDIM=10 X HH=1.0D0/(DBLE(NDIM)+1.0D0) X DO 900 I=1,NDIM X TI=DBLE(I)*HH X XC(I)=TI*(TI-1.0D0) X 900 CONTINUE XC X ELSEIF(NPROB.EQ.16) THEN XC XC TRIGONOMETRIC XC X NAME='Trigonometric ' X NDIM=10 X DO 1000 I=1,NDIM X XC(I)=0.1D0 X 1000 CONTINUE XC X ELSEIF(NPROB.EQ.17) THEN XC XC VARIABLY DIMENSIONED XC X NAME='Variably Dimensioned ' X NDIM=10 X DO 1100 I=1,NDIM X XC(I)=1.0D0-0.1D0*DBLE(I) X 1100 CONTINUE XC X ELSEIF(NPROB.EQ.18.OR.NPROB.EQ.19) THEN XC XC BROYDEN TRIDIAGONAL XC BROYDEN BANDED XC X if(NPROB.EQ.18) THEN X NAME='Broyden Tridiagonal ' X ELSE X NAME='Broyden Banded ' X END IF X NDIM=10 X DO 1200 I=1,NDIM X XC(I)=-1.0D0 X 1200 CONTINUE XC X ELSEIF(NPROB.EQ.20.OR.NPROB.EQ.21) THEN XC XC HIEBERT #1 XC X NAME='Hiebert #1 ' X NDIM=2 X IF(NPROB.EQ.20) THEN X XC(1)=0.0D0 X XC(2)=0.0D0 X ELSE X XC(1)=10.0D0 X XC(2)=10.0D0 X END IF XC X ELSEIF(NPROB.GE.22.AND.NPROB.LE.25) THEN XC XC HIEBERT #2 XC X NAME='Hiebert #2 ' X NDIM=6 X IF(NPROB.NE.24) THEN X DO 1300 I=1,NDIM X IF(NPROB.EQ.22) XC(I)=0.0D0 X IF(NPROB.EQ.23) XC(I)=1.0D0 X IF(NPROB.EQ.25) XC(I)=10.0D0 X 1300 CONTINUE X ELSE X XC(1)=1.0D-04 X XC(2)=1.0D-03 X XC(3)=0.0D0 X XC(4)=1.0D-04 X XC(5)=55.0D0 X XC(6)=1.0D-04 X END IF XC X ELSEIF(NPROB.GE.26) THEN XC XC HIEBERT #3 XC X NAME='Hiebert #3 ' X NDIM=10 X DO 1400 I=1,NDIM X XC(I)=0.0D0 X 1400 CONTINUE X IF(NPROB.EQ.26) THEN X XC(1)=1.0D0 X XC(2)=1.0D0 X XC(3)=10.0D0 X XC(4)=1.0D0 X XC(5)=1.0D0 X XC(6)=1.0D0 X R=10.0D0 X ELSEIF(NPROB.EQ.27) THEN X XC(1)=2.0D0 X XC(2)=2.0D0 X XC(3)=10.0D0 X XC(4)=1.0D0 X XC(5)=1.0D0 X XC(6)=2.0D0 X R=10.0D0 X ELSEIF(NPROB.EQ.28) THEN X XC(1)=2.0D0 X XC(2)=5.0D0 X XC(3)=40.0D0 X XC(4)=1.0D0 X XC(10)=5.0D0 X R=40.0D0 X ELSE X XC(1)=1.0D0 X XC(2)=1.0D0 X XC(3)=20.0D0 X XC(4)=1.0D0 X XC(10)=1.0D0 X R=40.0D0 X END IF X END IF X CALL SETUP(ABSNEW ,CAUCHY ,DEUFLH ,GEOMS ,LINESR , X $ NEWTON ,OVERCH ,ACPTCR ,ITSCLF ,ITSCLX , X $ JACTYP ,JUPDM ,MAXEXP ,MAXIT ,MAXNS , X $ MAXQNS ,MINQNS ,N ,NARMIJ ,NIEJEV , X $ NJACCH ,OUTPUT ,QNUPDM ,STOPCR ,SUPPRS , X $ TRUPDM ,ALPHA ,CONFAC ,DELTA ,DELFAC , X $ EPSMCH ,ETAFAC ,FDTOLJ ,FTOL ,LAM0 , X $ MSTPF ,NSTTOL ,OMEGA ,RATIOF ,SIGMA , X $ STPTOL ,BOUNDL ,BOUNDU ,SCALEF ,SCALEX , X $ HELP) XC BUG FIX 7 MAR 1998 X JUPDM=NJUPD X OUTPUT=5 X write(10,77) njupd,method X77 format(' njupd = ',i4,' method = ',i4) X IF(NPROB.EQ.20) THEN X STOPCR=2 X ELSEIF(NPROB.GE.22.AND.NPROB.LE.25) THEN X NSTTOL=1.0D-16 X STPTOL=1.0D-16 X BOUNDL(3)=0.0D0 X BOUNDL(4)=0.0D0 X BOUNDL(6)=0.0D0 X BYPASS=.TRUE. X ELSEIF(NPROB.GE.26) THEN X BOUNDL(1)=0.0D0 X BOUNDL(2)=0.0D0 X BOUNDL(3)=0.0D0 X BOUNDL(4)=0.0D0 X END IF X IF(METHOD.EQ.1) THEN X linesr=.true. X else X linesr=.false. X END IF X if(ntest.eq.1) then X newton=.true. X GO TO 501 X ELSEIF(NTEST.EQ.2) THEN X GO TO 501 X ELSEIF(NTEST.EQ.3) THEN X ITSCLF=1 X GO TO 501 X ELSEIF(NTEST.EQ.4) THEN X ACPTCR=1 X NARMIJ=MAXIT X DEUFLH=.FALSE. X GO TO 501 X ELSEIF(NTEST.EQ.5) THEN X TRUPDM=1 X DEUFLH=.FALSE. X GO TO 501 X ELSEIF(NTEST.EQ.6) THEN X GEOMS=.FALSE. X GO TO 501 X ELSEIF(NTEST.EQ.7) THEN X ACPTCR=1 X GO TO 501 X ELSEIF(NTEST.EQ.8) THEN X NARMIJ=MAXIT X GO TO 501 X ELSEIF(NTEST.EQ.9) THEN X QNUPDM=0 X ELSEIF(NTEST.EQ.10) THEN X NARMIJ=MAXIT X ACPTCR=1 X GO TO 501 X END IF X 501 CONTINUE X CALL NNES(ABSNEW ,CAUCHY ,DEUFLH ,GEOMS ,LINESR , X $ NEWTON ,OVERCH ,ACPTCR ,ITSCLF ,ITSCLX , X $ JACTYP ,JUPDM ,MAXEXP ,MAXIT ,MAXNS , X $ MAXQNS ,MGLL ,MINQNS ,NDIM ,NARMIJ , X $ NIEJEV ,NJACCH ,NJETOT ,NUNIT ,OUTPUT , X $ QNUPDM ,STOPCR ,SUPPRS ,TRMCOD ,TRUPDM , X $ ALPHA ,CONFAC ,DELTA ,DELFAC ,EPSMCH , X $ ETAFAC ,FCNNEW ,FDTOLJ ,FTOL ,LAM0 , X $ MSTPF ,NSTTOL ,OMEGA ,RATIOF ,SIGMA , X $ STPTOL ,A ,BOUNDL ,BOUNDU ,DELF , X $ FSAVE ,FTRACK ,FVEC ,FVECC ,H , X $ HHPI ,JAC ,PLEE ,RDIAG ,S , X $ SBAR ,SCALEF ,SCALEX ,SN ,SSDHAT , X $ STRACK ,VHAT ,WV1 ,WV2 ,WV3 , X $ WV4 ,XC ,XPLUS ,XSAVE ,HELP , X $ FCN ,JACOB ) X NFE(ICOUNT)=NFETOT X IF(TRMCOD.GT.0) ISUM(ICOUNT)=ISUM(ICOUNT)+NFETOT X ICOUNT=ICOUNT+1 X40000 CONTINUE X30000 CONTINUE X PRINT 5, NAME,(NFE(I),I=1,6) X WRITE(NUNIT,5) NAME,(NFE(I),I=1,6) X 5 FORMAT(T2,A,I4,3X,I3,8X,I3,3X,I3,10X,I3,3X,I3) X20000 CONTINUE X WRITE(NUNIT,6) X 6 FORMAT(T28,'---',3X,'---',8X,'---',3X,'---',10X,'---', X $ 3X,'---') X WRITE(NUNIT,7) (ISUM(I),I=1,6) X 7 FORMAT(T27,I4,2X,I4,7X,I4,2X,I4,9X,I4,2X,I4) X10000 CONTINUE X STOP X END X SUBROUTINE FCN(OVERFL,N,FVEC,XC) X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DIMENSION FVEC(N),XC(N) X COMMON/NNES_4/NFETOT X COMMON/PROBN/NPROB X DIMENSION T(0:9,9) X DOUBLE PRECISION K1,K2,K3 X INTEGER R1,R2 X COMMON/H3R/R X LOGICAL OVERFL X OVERFL=.FALSE. X NFETOT=NFETOT+1 X IF(NPROB.EQ.1) THEN Xc Xc Rosenbrock Banana Function Xc X FVEC(1)=10.0D0*(XC(2)-XC(1)**2) X FVEC(2)=1.0D0-XC(1) X ELSEIF(NPROB.EQ.2) THEN Xc Xc Powell Singular Function Xc X FVEC(1)=XC(1)+10.0D0*XC(2) X FVEC(2)=SQRT(5.0D0)*(XC(3)-XC(4)) X FVEC(3)=(XC(2)-2.0D0*XC(3))**2 X FVEC(4)=SQRT(10.0D0)*(XC(1)-XC(4))**2 X ELSEIF(NPROB.EQ.3) THEN Xc Xc Powell Badly-Scaled Function Xc X FVEC(1)=1.0D04*XC(1)*XC(2)-1.0D0 X FVEC(2)=EXP(-XC(1))+EXP(-XC(2))-1.0001D0 X ELSEIF(NPROB.EQ.4) THEN Xc Xc Wood Function Xc Xc X FVEC(1)=-200.0D0*XC(1)*(XC(2)-XC(1)**2)-(1.0D0-XC(1)) X FVEC(2)=100.0D0*(XC(2)-XC(1)**2)+10.0D0*(XC(2)+XC(4)-2.0D0) X $ +0.1D0*(XC(2)-XC(4)) X FVEC(3)=-180.0D0*XC(3)*(XC(4)-XC(3)**2)-(1.0D0-XC(3)) X FVEC(4)=90.0D0*(XC(4)-XC(3)**2)+10.0D0*(XC(2)+XC(4)-2.0D0) X $ -0.1D0*(XC(2)-XC(4)) X ELSEIF(NPROB.EQ.5) THEN Xc Xc Helical Valley Function Xc X PI=3.14159265D0 X IF(XC(1).GT.0.0D0) THEN X THETA=(1.0D0/(2.0D0*PI))*ATAN(XC(2)/XC(1)) X ELSE X THETA=(1.0D0/(2.0D0*PI))*ATAN(XC(2)/XC(1))+0.5D0 X END IF X FVEC(1)=10.0D0*(XC(3)-10.0D0*THETA) X FVEC(2)=10.0D0*(SQRT((XC(1)**2+XC(2)**2))-1.0D0) X FVEC(3)=XC(3) X ELSEIF(NPROB.EQ.6.OR.NPROB.EQ.7) THEN Xc Xc Watson Function Xc X DO 100 J=1,N X FVEC(J)=0.0D0 X DO 200 I=1,29 X TI=DBLE(I)/29.0D0 X SUM=0.0D0 X DO 300 K=1,N X SUM=SUM+XC(K)*TI**(K-1) X 300 CONTINUE X DFIDXJ=(DBLE(J)-1.0D0)*TI**(J-2)-2.0D0*SUM*TI**(J-1) X SUM=0.0D0 X DO 400 K=2,N X SUM=SUM+(DBLE(K)-1.0D0)*XC(K)*TI**(K-2) X 400 CONTINUE X SUM2=0.0D0 X DO 500 K=1,N X SUM2=SUM2+XC(K)*TI**(K-1) X 500 CONTINUE X SUM2=SUM2**2+1.0D0 X FI=SUM-SUM2 X FVEC(J)=FVEC(J)+DFIDXJ*FI X 200 CONTINUE X 100 CONTINUE X FVEC(1)=FVEC(1)+XC(1)-2.0D0*XC(1)*(XC(2)-XC(1)**2-1.0D0) X FVEC(2)=FVEC(2)+XC(2)-XC(1)**2-1.0D0 X ELSEIF(NPROB.GE.8.AND.NPROB.LE.10) THEN Xc Xc Chebyquad Function Xc X DO 600 K=1,N X DO 700 J=1,N X T(0,J)=1.0D0 X T(1,J)=2.0D0*XC(J)-1.0D0 X DO 800 I=2,N X T(I,J)=(4.0D0*XC(J)-2.0D0)*T(I-1,J)-T(I-2,J) X 800 CONTINUE X 700 CONTINUE X FVEC(K)=0.0D0 X DO 900 I=1,N X FVEC(K)=FVEC(K)+T(K,I) X 900 CONTINUE X FVEC(K)=FVEC(K)/DBLE(N) X IF(MOD(K,2).EQ.0) THEN X FVEC(K)=FVEC(K)+1.0D0/(DBLE(K)**2-1.0D0) X END IF X 600 CONTINUE X ELSEIF(NPROB.GE.11.AND.NPROB.LE.13) THEN Xc Xc Brown Almost-Linear Function Xc X SUM=0.0D0 X PROD=1.0D0 X DO 1000 J=1,N X SUM=SUM+XC(J) X PROD=PROD*XC(J) X 1000 CONTINUE X SUM=SUM-(DBLE(N)+1.0D0) X DO 1100 I=2,N X FVEC(I)=XC(I)+SUM X 1100 CONTINUE X FVEC(1)=PROD-1.0D0 X ELSEIF(NPROB.EQ.14) THEN Xc Xc Discrete Boundary Value Function Xc X H=1.0D0/(DBLE(N)+1.0D0) X DO 1200 I=2,N-1 X TI=DBLE(I)*H X FVEC(I)=2.0D0*XC(I)-XC(I-1)-XC(I+1)+ X $ ((H**2)*(XC(I)+TI+1.0D0)**3)/2.0D0 X 1200 CONTINUE X T1=H X FVEC(1)=2.0D0*XC(1)-XC(1+1)+ X $ ((H**2)*(XC(1)+T1+1.0D0)**3)/2.0D0 X TN=DBLE(N)*H X FVEC(N)=2.0D0*XC(N)-XC(N-1)+ X $ ((H**2)*(XC(N)+TN+1.0D0)**3)/2.0D0 X ELSEIF(NPROB.EQ.15) THEN Xc Xc Discrete Integral Equation Xc X H=1.0D0/(DBLE(N)+1.0D0) X DO 1300 I=1,N X TI=DBLE(I)*H X SUM=0.0D0 X DO 1400 J=1,I X TJ=DBLE(J)*H X SUM=SUM+TJ*(XC(J)+TJ+1.0D0)**3 X 1400 CONTINUE X SUM=SUM*(1.0D0-TI) X SUM2=0.0D0 X DO 1500 J=I+1,N X TJ=DBLE(J)*H X SUM2=SUM2+(1.0D0-TJ)*(XC(J)+TJ+1.0D0)**3 X 1500 CONTINUE X SUM2=SUM2*TI X FVEC(I)=XC(I)+(H/2.0D0)*(SUM+SUM2) X 1300 CONTINUE X ELSEIF(NPROB.EQ.16) THEN Xc Xc Trigonometric Function Xc X DO 1600 I=1,N X SUM=0.0D0 X DO 1700 J=1,N X SUM=SUM+COS(XC(J)) X 1700 CONTINUE X FVEC(I)=DBLE(N)-SUM+DBLE(I)*(1.0D0-COS(XC(I))) X $ -SIN(XC(I)) X 1600 CONTINUE X ELSEIF(NPROB.EQ.17) THEN Xc Xc Variably Dimensioned Function Xc X SUM=0.0D0 X DO 1800 J=1,N X SUM=SUM+DBLE(J)*(XC(J)-1.0D0) X 1800 CONTINUE X DO 1900 I=1,N X FVEC(I)=(XC(I)-1.0D0)+DBLE(I)*SUM+2.0D0 X $ *DBLE(I)*SUM**3 X 1900 CONTINUE X ELSEIF(NPROB.EQ.18) THEN Xc Xc Broyden Tridiagonal Function Xc X DO 2000 I=2,N-1 X FVEC(I)=(3.0D0-2.0D0*XC(I))*XC(I)-XC(I-1) X $ -2.0D0*XC(I+1)+1.0D0 X 2000 CONTINUE X FVEC(1)=(3.0D0-2.0D0*XC(1))*XC(1) -2.0D0*XC(2)+1.0D0 X FVEC(N)=(3.0D0-2.0D0*XC(N))*XC(N)-XC(N-1) +1.0D0 X ELSEIF(NPROB.EQ.19) THEN Xc Xc Broyden Banded Function Xc X K1=2.0D0 X K2=5.0D0 X K3=1.0D0 X R1=5 X R2=1 Xc X DO 2100 I=1,N X SUM=0.0D0 X DO 2200 J=MAX(1,I-R1),MIN(N,I+R2) X IF(J.NE.I) SUM=SUM+XC(J)*(1.0D0+XC(J)) X 2200 CONTINUE X FVEC(I)=(K1+K2*XC(I)**2)*XC(I)+1.0D0-K3*SUM X 2100 CONTINUE X ELSEIF(NPROB.EQ.20.OR.NPROB.EQ.21) THEN Xc Xc Hiebert's 1st Chemical Engineering Problem Xc X FVEC(1)=XC(2)-10.0D0 X FVEC(2)=XC(1)*XC(2)-5.0D04 X ELSEIF(NPROB.GE.22.AND.NPROB.LE.25) THEN Xc Xc Hiebert's 2nd Chemical Engineering Problem Xc X FVEC(1)=XC(1)+XC(2)+XC(4)-0.001D0 X FVEC(2)=XC(5)+XC(6)-55.0D0 X FVEC(3)=XC(1)+XC(2)+XC(3)+2.0D0*XC(5)+XC(6)-110.001D0 X FVEC(4)=XC(1)-0.1D0*XC(2) X FVEC(5)=XC(1)-1.0D04*XC(3)*XC(4) X FVEC(6)=XC(5)-5.5D15*XC(3)*XC(6) X ELSEIF(NPROB.GE.26) THEN Xc Xc Hiebert's 3rd Chemical Reaction Problem (uncorrected) Xc X TOT=0.0D0 X DO 2300 I=1,N X TOT=TOT+XC(I) X 2300 CONTINUE X IF(TOT.LT.0.0D0) THEN X OVERFL=.TRUE. X RETURN X END IF X FVEC(1)=XC(1)+XC(4)-3.0D0 X FVEC(2)=2.0D0*XC(1)+XC(2)+XC(4)+XC(7)+XC(8)+XC(9) X $ +2.0D0*XC(10)-R X FVEC(3)=2.0D0*XC(2)+2.0D0*XC(5)+XC(6)+XC(7)-8.0D0 X FVEC(4)=2.0D0*XC(3)+XC(9)-4.0D0*R X FVEC(5)=XC(1)*XC(5)-1.93D-01*XC(2)*XC(4) X FVEC(6)=XC(6)*SQRT(XC(2))-2.597D-03*SQRT(XC(2)*XC(4)*TOT) X FVEC(7)=XC(7)*SQRT(XC(4))-3.448D-03*SQRT(XC(1)*XC(2)*TOT) X FVEC(8)=XC(8)*XC(4)-1.799D-05*XC(2)*TOT X FVEC(9)=XC(9)*XC(4)-2.155D-04*XC(1)*SQRT(XC(3)*TOT) X FVEC(10)=XC(10)*XC(4)**2-3.846D-05*XC(4)**2*TOT X END IF X RETURN X END X SUBROUTINE JACOB(OVERFL,N,JAC,XC) X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION JAC(N,N) X DIMENSION XC(N) X LOGICAL OVERFL X OVERFL=.FALSE. X******************************************************************** X* * X* INSERT ANALYTICAL JACOBIAN IF DESIRED * X* * X******************************************************************** X RETURN X END END_OF_FILE if test 22091 -ne `wc -c <'mdr.f'`; then echo shar: \"'mdr.f'\" unpacked with wrong size! fi # end of 'mdr.f' fi if test -f 'nersl.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'nersl.f'\" else echo shar: Extracting \"'nersl.f'\" \(1827 characters\) sed "s/^X//" >'nersl.f' <<'END_OF_FILE' X SUBROUTINE NERSL(NEWTON,RESTRT,SCLFCH,SCLXCH,ACPCOD,JUPDM , X $ N ,NUNIT ,OUTPUT,FCNNEW,FVEC ,XPLUS ) XC XC SEPT. 2, 1991 XC XC THE RESULTS OF EACH ITERATION ARE PRINTED. XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X INTEGER ACPCOD ,OUTPUT X DIMENSION FVEC(N) ,XPLUS(N) X LOGICAL NEWTON ,RESTRT ,SCLFCH ,SCLXCH XC X WRITE(NUNIT,1) X1 FORMAT(T3,'*',T74,'*') X WRITE(NUNIT,1) X IF(.NOT.SCLXCH) THEN X WRITE(NUNIT,2) X2 FORMAT(T3,'*',4X,'SUMMARY OF ITERATION RESULTS',T74,'*') X ELSE X WRITE(NUNIT,3) X3 FORMAT(T3,'*',4X,'SUMMARY OF ITERATION RESULTS (X''','S', X $ ' GIVEN IN UNSCALED UNITS)',T74,'*') X END IF X WRITE(NUNIT,1) X WRITE(NUNIT,4) X4 FORMAT(T3,'*',8X,'UPDATED ESTIMATES',16X, X $ 'UPDATED FUNCTION VALUES',T74,'*') X WRITE(NUNIT,1) X DO 100 I=1,N X WRITE(NUNIT,5) I,XPLUS(I),I,FVEC(I) X5 FORMAT(T3,'*',6X,'X(',I3,') = ',1PD12.3,15X, X $ 'F(',I3,') = ',1PD12.3,T74,'*') X100 CONTINUE X WRITE(NUNIT,1) X IF(.NOT.SCLFCH) THEN X WRITE(NUNIT,6) FCNNEW X6 FORMAT(T3,'*',6X,'OBJECTIVE FUNCTION VALUE: ',1PD12.3, X $ T74,'*') X ELSE X WRITE(NUNIT,7) FCNNEW X7 FORMAT(T3,'*',6X,'SCALED OBJECTIVE FUNCTION VALUE: ', X $ 1PD12.3,T74,'*') X END IF X WRITE(NUNIT,1) X IF(OUTPUT.GT.3.AND.(.NOT.NEWTON)) THEN X WRITE(NUNIT,8) ACPCOD X8 FORMAT(T3,'*',6X,'STEP ACCEPTANCE CODE, ACPCOD:',I9, X $ T74,'*') X END IF X IF(RESTRT.AND.OUTPUT.GE.3.AND.JUPDM.NE.0) THEN X IF(OUTPUT.GT.3) WRITE(NUNIT,1) X WRITE(NUNIT,9) X9 FORMAT(T3,'*',6X,'NOTE: JACOBIAN EVALUATED EXPLICITLY', X $ ' AT THIS STEP',T74,'*') X WRITE(NUNIT,1) X END IF X RETURN XC XC LAST CARD OF SUBROUTINE NERSL. XC X END END_OF_FILE if test 1827 -ne `wc -c <'nersl.f'`; then echo shar: \"'nersl.f'\" unpacked with wrong size! fi # end of 'nersl.f' fi if test -f 'nestop.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'nestop.f'\" else echo shar: Extracting \"'nestop.f'\" \(8740 characters\) sed "s/^X//" >'nestop.f' <<'END_OF_FILE' X SUBROUTINE NESTOP(ABSNEW,LINESR,NEWTON,SCLFCH,SCLXCH, X $ ACPTCR,ITNUM ,N ,NAC1 ,NAC2 , X $ NAC12 ,NFUNC ,NJETOT,NUNIT ,OUTPUT, X $ STOPCR,TRMCOD,FCNNEW,FTOL ,NSTTOL, X $ STPMAX,STPTOL,FVEC ,SCALEF,SCALEX, X $ XC ,XPLUS) XC XC FEB. 23, 1992 XC XC THIS SUBROUTINE CHECKS TO SEE IF THE CONVERGENCE CRITERIA XC HAVE BEEN MET. XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION MAX1 ,MAX2 ,NSTTOL X INTEGER ACPTCR ,OUTPUT ,STOPCR ,TRMCOD X DIMENSION FVEC(N) ,SCALEF(N) ,SCALEX(N) ,XC(N) , X $ XPLUS(N) X LOGICAL ABSNEW ,LINESR ,NEWTON ,SCLFCH , X $ SCLXCH X COMMON/NNES_4/NFETOT X DATA ZERO,ONE,TWO /0.0D0,1.0D0,2.0D0/ XC X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X1 FORMAT(T3,'*',T74,'*') X WRITE(NUNIT,2) X2 FORMAT(T3,'*',4X,'CONVERGENCE TESTING',T74,'*') X WRITE(NUNIT,1) X END IF XC XC IF THE NEWTON STEP WAS WITHIN TOLERANCE THEN TRMCOD IS 1. XC X IF(TRMCOD.EQ.1) THEN X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X IF(.NOT.SCLXCH) THEN X WRITE(NUNIT,3) STPMAX X3 FORMAT(T3,'*',6X,'MAXIMUM NEWTON STEP LENGTH', X $ ' STPMAX:',1PD12.3,T74,'*') X ELSE X WRITE(NUNIT,4) STPMAX X4 FORMAT(T3,'*',6X,'MAXIMUM SCALED NEWTON STEP', X $ ' LENGTH STPMAX:',1PD12.3,T74,'*') X END IF X WRITE(NUNIT,5) NSTTOL X5 FORMAT(T3,'*',6X,'FIRST CONVERGENCE CRITERION MET; ', X $ ' NSTTOL IS:',1PD12.3,T74,'*') X WRITE(NUNIT,1) XC XC SKIP CHECKING OTHER STEP SIZE CRITERION AS TRMCOD IS XC ALREADY 1. XC X GO TO 101 X END IF X END IF XC XC IF THE NEWTON STEP WAS NOT WITHIN TOLERANCE THEN, IF XC STOPCR IS NOT EQUAL TO 2, THE SECOND STEP SIZE STOPPING XC CRITERION MUST BE CHECKED. XC X IF(STOPCR.NE.2.AND.TRMCOD.NE.1) THEN X MAX1=ZERO X DO 100 I=1,N X RATIO1=(ABS(XPLUS(I)-XC(I)))/MAX(ABS(XPLUS(I)), X $ ONE/SCALEX(I)) X MAX1=MAX(MAX1,RATIO1) X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,6) I,RATIO1 X6 FORMAT(T3,'*',6X,'RELATIVE STEP SIZE (',I3,') = ', X $ 1PD12.3,T74,'*') X END IF X100 CONTINUE X IF(OUTPUT.GT.4) WRITE(NUNIT,1) X IF(OUTPUT.GT.3) THEN X IF(.NOT.SCLXCH) THEN X WRITE(NUNIT,7) MAX1,STPTOL X7 FORMAT(T3,'*',6X,'MAXIMUM STEP SIZE:', X $ 1PD12.3,3X,'STPTOL:',1PD11.3,T74,'*') X ELSE X WRITE(NUNIT,8) MAX1,STPTOL X8 FORMAT(T3,'*',6X,'MAXIMUM RELATIVE STEP SIZE:', X $ 1PD12.3,3X,'STPTOL:',1PD11.3,T74,'*') X END IF X WRITE(NUNIT,1) X END IF X IF(MAX1.LT.STPTOL) THEN X TRMCOD=1 X END IF X END IF XC XC NOTE: CONTINUATION AT 101 MEANS THAT TRMCOD WAS 1 ON ENTRY XC SO THE STEP SIZE CRITERION ABOVE DID NOT NEED TO BE XC CHECKED. XC X101 CONTINUE XC XC THE SECOND STOPPING CRITERION IS CHECKED IF NEEDED. XC X IF(STOPCR.EQ.2.OR.STOPCR.EQ.12.OR. X $ (STOPCR.EQ.3.AND.TRMCOD.EQ.1)) THEN X MAX2=ZERO X DO 200 I=1,N X MAX2=MAX(MAX2,SCALEF(I)*ABS(FVEC(I))) X IF(OUTPUT.GT.4) THEN X IF(.NOT.SCLFCH) THEN X WRITE(NUNIT,9) I,ABS(FVEC(I)) X9 FORMAT(T3,'*',6X,'ABSOLUTE FUNCTION VECTOR (',I3, X $ ') = ',1PD12.3,T74,'*') X ELSE X WRITE(NUNIT,10) I,SCALEF(I)*ABS(FVEC(I)) X10 FORMAT(T3,'*',6X,'ABSOLUTE SCALED FUNCTION', X $ ' VECTOR (',I3,') = ',1PD12.3,T74,'*') X END IF X END IF X200 CONTINUE X IF(OUTPUT.GT.4) WRITE(NUNIT,1) X IF(OUTPUT.GT.3) THEN X IF(.NOT.SCLFCH) THEN X WRITE(NUNIT,11) MAX2,FTOL X11 FORMAT(T3,'*',6X,'MAXIMUM ABSOLUTE FUNCTION:', X $ 1PD12.3,5X,'FTOL:',1PD11.3,T74,'*') X ELSE X WRITE(NUNIT,12) MAX2,FTOL X12 FORMAT(T3,'*',6X,'MAX ABSOLUTE SCALED', X $ ' FUNCTION:',1PD12.3,5X,'FTOL:',1PD11.3,T74,'*') X END IF X WRITE(NUNIT,1) X END IF X IF(MAX2.LT.FTOL) THEN X IF(STOPCR.EQ.3.AND.TRMCOD.EQ.1) THEN XC XC BOTH NEEDED STOPPING CRITERIA HAVE BEEN MET. XC X TRMCOD=3 X ELSEIF(STOPCR.EQ.12.AND.TRMCOD.EQ.1) THEN XC XC BOTH STOPPING CRITERIA HAVE BEEN MET ALTHOUGH XC EITHER ONE WOULD BE SATISFACTORY. XC X TRMCOD=12 X ELSEIF(STOPCR.EQ.2.OR.STOPCR.EQ.12) THEN X TRMCOD=2 X END IF X ELSEIF(STOPCR.EQ.3) THEN XC XC ONLY THE FIRST STOPPING CRITERION WAS MET - TRMCOD XC MUST BE RESET FROM 1 BACK TO 0. XC X TRMCOD=0 X END IF X END IF XC XC PRINT FINAL RESULTS IF CONVERGENCE REACHED. XC X IF(TRMCOD.GT.0) THEN X IF(OUTPUT.GT.0) THEN X IF(OUTPUT.EQ.1) WRITE(NUNIT,13) X13 FORMAT(T3,72('*')) X WRITE(NUNIT,1) X WRITE(NUNIT,14) TRMCOD X14 FORMAT(T3,'*',6X,'CONVERGENCE REACHED;', X $ ' TERMINATION CODE: ...............',I6,T74,'*') XC XC ITERATION RESULTS NOT PRINTED IN NERSL. XC X WRITE(NUNIT,1) X WRITE(NUNIT,1) X IF(SCLFCH.OR.SCLXCH) THEN X WRITE(NUNIT,15) X15 FORMAT(T3,'*',29X,'UNSCALED RESULTS',T74,'*') X WRITE(NUNIT,1) X END IF X WRITE(NUNIT,16) X16 FORMAT(T3,'*',10X,'FINAL ESTIMATES',19X,'FINAL', X $ ' FUNCTION VALUES',T74,'*') X WRITE(NUNIT,1) X DO 300 I=1,N X WRITE(NUNIT,17) I,XPLUS(I),I,FVEC(I) X17 FORMAT(T3,'*',6X,'X(',I3,') = ',1PD14.5,14X, X $ 'F(',I3,') = ',1PD14.5,T74,'*') X300 CONTINUE X WRITE(NUNIT,1) X IF(SCLFCH) THEN XC XC NEED UNSCALED OBJECTIVE FUNCTION. XC X SUM=ZERO X DO 400 I=1,N X SUM=SUM+FVEC(I)*FVEC(I) X400 CONTINUE X WRITE(NUNIT,18) SUM/TWO X ELSE X WRITE(NUNIT,18) FCNNEW X END IF X18 FORMAT(T3,'*',6X,'FINAL OBJECTIVE FUNCTION VALUE:', X $ 1PD12.3,T74,'*') X IF(SCLFCH.OR.SCLXCH) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,1) X WRITE(NUNIT,19) X19 FORMAT(T3,'*',30X,'SCALED RESULTS',T74,'*',/T3,'*', X $ T74,'*',/T3,'*',10X,'FINAL ESTIMATES',19X,'FINAL', X $ ' FUNCTION VALUES',T74,'*') X WRITE(NUNIT,1) X DO 500 I=1,N X WRITE(NUNIT,17) I,SCALEX(I)*XPLUS(I), X $ I,SCALEF(I)*FVEC(I) X500 CONTINUE X WRITE(NUNIT,1) X WRITE(NUNIT,18) FCNNEW X END IF X END IF X ELSE X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,20) X20 FORMAT(T3,'*',6X,'CONVERGENCE NOT REACHED',T74,'*') X WRITE(NUNIT,1) X END IF X RETURN X END IF XC XC TERMINATION HAS BEEN REACHED. XC X IF(OUTPUT.GT.0) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,1) X WRITE(NUNIT,21) ITNUM X21 FORMAT(T3,'*',6X,'TOTAL NUMBER OF ITERATIONS', X $ ': ..........................',I6,T74,'*') X IF(.NOT.NEWTON.AND.(.NOT.ABSNEW)) THEN X IF(LINESR) THEN X WRITE(NUNIT,22) NFUNC X22 FORMAT(T3,'*',6X,'TOTAL NUMBER OF LINE SEARCH ', X $ 'FUNCTION EVALUATIONS: ....',I6,T74,'*') X ELSE X WRITE(NUNIT,23) NFUNC X23 FORMAT(T3,'*',6X,'TOTAL NUMBER OF TRUST REGION', X $ ' FUNCTION EVALUATIONS: ...',I6,T74,'*') X END IF X END IF X WRITE(NUNIT,24) NJETOT X24 FORMAT(T3,'*',6X,'TOTAL NUMBER OF EXPLICIT JACOBIAN', X $ ' EVALUATIONS: .......',I6,T74,'*') X WRITE(NUNIT,25) NFETOT X25 FORMAT(T3,'*',6X,'TOTAL NUMBER OF FUNCTION', X $ ' EVALUATIONS: ................',I6,T74,'*') X WRITE(NUNIT,1) X IF(.NOT.NEWTON.AND.(.NOT.ABSNEW).AND.ACPTCR.NE.1. X $ AND.OUTPUT.GT.2) THEN X WRITE(NUNIT,26) NAC1 X26 FORMAT(T3,'*',6X,'NUMBER OF STEPS ACCEPTED', X $ ' BY FUNCTION VALUE ONLY: .....',I6,T74,'*') X WRITE(NUNIT,27) NAC2 X27 FORMAT(T3,'*',6X,'NUMBER OF STEPS ACCEPTED', X $ ' BY STEP SIZE VALUE ONLY: ....',I6,T74,'*') X WRITE(NUNIT,28) NAC12 X28 FORMAT(T3,'*',6X,'NUMBER OF STEPS ACCEPTED', X $ ' BY EITHER CRITERION: ........',I6,T74,'*') X WRITE(NUNIT,1) X END IF X WRITE(NUNIT,13) X END IF X RETURN XC XC LAST CARD OF SUBROUTINE NESTOP. XC X END END_OF_FILE if test 8740 -ne `wc -c <'nestop.f'`; then echo shar: \"'nestop.f'\" unpacked with wrong size! fi # end of 'nestop.f' fi if test -f 'nnes.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'nnes.f'\" else echo shar: Extracting \"'nnes.f'\" \(36626 characters\) sed "s/^X//" >'nnes.f' <<'END_OF_FILE' X SUBROUTINE NNES(ABSNEW ,CAUCHY ,DEUFLH ,GEOMS ,LINESR , X $ NEWTON ,OVERCH ,ACPTCR ,ITSCLF ,ITSCLX , X $ JACTYP ,JUPDM ,MAXEXP ,MAXIT ,MAXNS , X $ MAXQNS ,MGLL ,MINQNS ,N ,NARMIJ , X $ NIEJEV ,NJACCH ,NJETOT ,NUNIT ,OUTPUT , X $ QNUPDM ,STOPCR ,SUPPRS ,TRMCOD ,TRUPDM , X $ ALPHA ,CONFAC ,DELTA ,DELFAC ,EPSMCH , X $ ETAFAC ,FCNNEW ,FDTOLJ ,FTOL ,LAM0 , X $ MSTPF ,NSTTOL ,OMEGA ,RATIOF ,SIGMA , X $ STPTOL ,A ,BOUNDL ,BOUNDU ,DELF , X $ FSAVE ,FTRACK ,FVEC ,FVECC ,H , X $ HHPI ,JAC ,PLEE ,RDIAG ,S , X $ SBAR ,SCALEF ,SCALEX ,SN ,SSDHAT , X $ STRACK ,VHAT ,WV1 ,WV2 ,WV3 , X $ WV4 ,XC ,XPLUS ,XSAVE ,HELP , X $ FVECEV ,JACEV ) XC XC FEB. 28, 1992 XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION JAC(N,N) ,LAM0 ,MAXSTP ,MSTPF , X $ NEWLEN ,NEWMAX ,NSTTOL X INTEGER ACPCOD ,ACPSTR ,ACPTCR ,CONTYP , X $ COUNTR ,OUTPUT ,OUTTMP ,QNUPDM , X $ RETCOD ,STOPCR ,SUPPRS ,TRMCOD , X $ TRUPDM X DIMENSION A(N,N) ,BOUNDL(N) ,BOUNDU(N) ,DELF(N) , X $ FSAVE(N) ,FTRACK(0:MGLL-1 ) ,FVEC(N) , X $ FVECC(N) ,H(N,N) ,HHPI(N) ,PLEE(N,N), X $ RDIAG(N) ,S(N) ,SBAR(N) ,SCALEF(N), X $ SCALEX(N) ,SN(N) ,SSDHAT(N) , X $ STRACK(0:MGLL-1) ,VHAT(N) ,WV1(N) , X $ WV2(N) ,WV3(N) ,WV4(N) ,XC(N) , X $ XPLUS(N) ,XSAVE(N) X LOGICAL ABORT ,ABSNEW ,CAUCHY ,CHECKJ , X $ DEUFLH ,FRSTDG ,GEOMS ,INSTOP , X $ JACERR ,LINESR ,MATSUP ,NEWTON , X $ NEWTKN ,OVERCH ,OVERFL ,QNFAIL , X $ QRSING ,RESTRT ,SAVEST ,SCLFCH , X $ SCLXCH ,WRNSUP X CHARACTER*6 HELP X COMMON/NNES_1/MATSUP X COMMON/NNES_2/WRNSUP X COMMON/NNES_6/ITNUM,NFUNC X EXTERNAL FVECEV,JACEV X DATA ZERO,PT01,ONE /0.0D0,0.01D0,1.0D0/ XC XC PRINT HELP IF REQUESTED. XC X IF(HELP(1:4).NE.'NONE') THEN X CALL OLHELP(NUNIT,HELP) X RETURN X END IF X QNFAIL=.FALSE. X RESTRT=.TRUE. X SAVEST=.FALSE. X COUNTR=0 X ISEJAC=0 X MNEW=0 X NAC1=0 X NAC2=0 X NAC12=0 X NFUNC=1 X NJETOT=0 X OUTTMP=OUTPUT X TRMCOD=0 XC XC ESTABLISH INITIAL FUNCTION VALUE AND CHECK FOR STARTING XC ESTIMATE WHICH IS A SOLUTION. ALSO, CHECK FOR INCOMPAT- XC IBILITIES IN INPUT PARAMETERS. XC X CALL INITCH(INSTOP,LINESR,NEWTON,OVERFL,SCLFCH, X $ SCLXCH,ACPTCR,CONTYP,JACTYP,JUPDM , X $ MAXEXP,N ,NUNIT ,OUTPUT,QNUPDM, X $ STOPCR,TRUPDM,EPSMCH,FCNOLD,FTOL , X $ BOUNDL,BOUNDU,FVECC ,SCALEF,SCALEX, X $ WV1 ,XC ,FVECEV) XC XC IF A FATAL ERROR IS DETECTED IN INITCH RETURN TO MAIN XC PROGRAM. NOTE: SOME INCOMPATIBILITIES ARE CORRECTED XC WITHIN INITCH AND EXECUTION CONTINUES. WARNINGS ARE XC GENERATED WITHIN INITCH. XC X IF(INSTOP) RETURN XC XC ESTABLISH MAXIMUM STEP LENGTH ALLOWED (USUALLY THIS IS MUCH XC LARGER THAN ACTUAL STEP SIZES - IT IS ONLY TO PREVENT XC EXCESSIVELY LARGE STEPS). THE FACTOR MSTPF CONTROLS THE XC MAGNITUDE OF MAXSTP AND IS SET BY THE USER (DEFAULT=1000). XC X CALL MAXST(OVERFL,MAXEXP,N ,NUNIT ,OUTPUT,EPSMCH, X $ MAXSTP,MSTPF ,SCALEX,WV1 ,XC ) XC XC WRITE TITLE AND RECORD PARAMETERS. XC X CALL TITLE(CAUCHY,DEUFLH,GEOMS ,LINESR,NEWTON, X $ OVERCH,ACPTCR,CONTYP,ITSCLF,ITSCLX, X $ JACTYP,JUPDM ,MAXIT ,MAXNS ,MAXQNS, X $ MGLL ,MINQNS,N ,NARMIJ,NIEJEV, X $ NJACCH,NUNIT ,OUTPUT,QNUPDM,STOPCR, X $ TRUPDM,ALPHA ,CONFAC,DELFAC,DELTA , X $ EPSMCH,ETAFAC,FCNOLD,FTOL ,LAM0 , X $ MAXSTP,MSTPF ,NSTTOL,OMEGA ,RATIOF, X $ SIGMA ,STPTOL,BOUNDL,BOUNDU,FVECC , X $ SCALEF,SCALEX,XC ) XC XC INITIALIZE FTRACK AND STRACK VECTORS (FTRACK STORES XC (TRACKS) THE FUNCTION VALUES FOR THE NONMONOTONIC XC COMPARISON AND STRACK, SIMILARLY, STORES THE LENGTH XC OF THE NEWTON STEPS - WHICH ARE USED IN CONJUNCTION XC WITH DEUFLHARD'S SECOND ACCEPTANCE CRITERION). XC X DO 100 J=0,MGLL-1 X FTRACK(J)=ZERO X STRACK(J)=ZERO X100 CONTINUE XC XC MAIN ITERATIVE LOOP - MAXIT IS SPECIFIED BY USER. XC XC ITNUM COUNTS OVERALL ITERATIONS. XC ISEJAC COUNTS ITERATIONS SINCE LAST EXPLICIT JACOBIAN XC EVALUATION IF A QUASI-NEWTON METHOD IS BEING USED. XC X DO 200 ITNUM=1,MAXIT XC XC SUPPRESS OUTPUT IF DESIRED - USED IF DETAILED OUTPUT XC IS DESIRED FOR LATER ITERATIONS ONLY (DEFAULT VALUE XC FOR SUPPRS IS 0 - I.E. NO SUPPRESSION). XC X IF(ITNUM.LT.SUPPRS) THEN X OUTPUT=3 X ELSE X OUTPUT=OUTTMP X END IF XC X IF(OUTPUT.GT.2) THEN X WRITE(NUNIT,1) X1 FORMAT(T3,72('*')) X WRITE(NUNIT,2) X2 FORMAT(T3,'*',T74,'*') X WRITE(NUNIT,3) ITNUM X3 FORMAT(T3,'*',2X,'ITERATION NUMBER: ',I5,T74,'*') X END IF XC XC UPDATE ITERATION COUNTER, ISEJAC, FOR QUASI-NEWTON METHODS XC ONLY (I.E. JUPDM > 0). XC X IF(JUPDM.GT.0.AND.RESTRT.AND.(.NOT.NEWTON)) THEN X ISEJAC=1 X ELSE X ISEJAC=ISEJAC+1 X END IF X IF(OUTPUT.GT.4.AND.JUPDM.GT.0.AND.(.NOT.NEWTON)) THEN X WRITE(NUNIT,2) X IF(RESTRT) THEN X IF(ITNUM.GT.NIEJEV) THEN X WRITE(NUNIT,4) X4 FORMAT(T3,'*',4X,'RESTRT IS TRUE, ISEJAC SET', X $ ' TO 1',T74,'*') X END IF X ELSE X WRITE(NUNIT,5) ISEJAC X5 FORMAT(T3,'*',4X,'# OF ITERATIONS SINCE EXPLICIT', X $ ' JACOBIAN, ISEJAC, INCREASED TO',I4,T74,'*') X END IF X END IF XC XC WHEN AN EXPLICIT JACOBIAN IS BEING USED IN QUASI-NEWTON XC METHODS THEN MAXNS STEPS ARE ALLOWED IN THE LINE SEARCH. XC FOR STEPS BASED ON A QUASI-NEWTON APPROXIMATION MAXQNS XC ARE ALLOWED. SIMILARLY MAXNS AND MAXQNS STEPS ARE ALLOWED XC IN TRUST REGION METHODS RESPECTIVELY. THIS IS AN ATTEMPT TO XC AVOID AN EXCESSIVE NUMBER OF FUNCTION EVALUATIONS IN A XC DIRECTION WHICH WOULD NOT LEAD TO A SIGNIFICANT REDUCTION. XC X IF(.NOT.NEWTON) THEN X IF(LINESR) THEN X IF(JUPDM.GT.0) THEN X IF(ISEJAC.EQ.1) THEN XC XC JACOBIAN UPDATED EXPLICITLY. XC X MAXLIN=MAXNS X ELSE XC XC QUASI-NEWTON UPDATE. XC X MAXLIN=MAXQNS X END IF X ELSE X MAXLIN=MAXNS X END IF X ELSE X IF(JUPDM.GT.0) THEN X IF(ISEJAC.EQ.1) THEN XC XC JACOBIAN UPDATED EXPLICITLY. XC X MAXTRS=MAXNS X ELSE XC XC QUASI-NEWTON UPDATE. XC X MAXTRS=MAXQNS X END IF X ELSE X MAXTRS=MAXNS X END IF X END IF X IF(JUPDM.GT.0.AND.OUTPUT.GT.4) THEN X WRITE(NUNIT,2) X IF(LINESR) THEN X WRITE(NUNIT,6) MAXLIN X6 FORMAT(T3,'*',4X,'MAXLIN SET TO:',I5,T74,'*') X ELSE X WRITE(NUNIT,7) MAXTRS X7 FORMAT(T3,'*',4X,'MAXTRS SET TO:',I5,T74,'*') X END IF X END IF X END IF XC XC ESTABLISH WHETHER JACOBIAN IS TO BE CHECKED NUMERICALLY - XC NJACCH ESTABLISHES THE NUMBER OF ITERATIONS FOR WHICH XC JACOBIAN CHECKING IS DESIRED. IF CHECKJ IS TRUE A FORWARD XC DIFFERENCE NUMERICAL APPROXIMATION OF THE JACOBIAN IS XC COMPARED TO THE ANALYTICAL VERSION. STORE THE NUMBER XC OF FUNCTION EVALUATIONS SO THAT THESE "EXTRA" ARE NOT XC INCLUDED IN OVERALL STATISTICS. XC X IF(JACTYP.EQ.0) THEN X IF(ITNUM.GT.NJACCH) THEN X CHECKJ=.FALSE. X ELSE X CHECKJ=.TRUE. X NFESTR=NFETOT X END IF X END IF XC XC EVALUATE JACOBIAN AT FIRST STEP OR IF NO QUASI-NEWTON XC UPDATE IS BEING USED (RESTRT IS FALSE ONLY IN QUASI- XC NEWTON METHODS WHEN THE QUASI-NEWTON UPDATE IS BEING XC USED). XC X IF(RESTRT.OR.JUPDM.EQ.0) THEN XC XC IF MORE THAN ONE DAMPED NEWTON STEP HAS BEEN REQUESTED XC AT THE START, IDENTIFY THIS AS THE REASON FOR EXPLICIT XC JACOBIAN EVALUATION. XC X IF(JUPDM.GT.0.AND.(ITNUM.LE.NIEJEV.AND.ITNUM.GT.1) X $ .AND.OUTPUT.GT.4) THEN X WRITE(NUNIT,2) X WRITE(NUNIT,8) X8 FORMAT(T3,'*',4X,'AS ITNUM <= NIEJEV', X $ ' JACOBIAN EVALUATED EXPLICITLY',T74,'*') X END IF XC XC OTHERWISE JUPDM IS 0 OR RESTRT IS TRUE AND ITNUM IS XC GREATER THEN NIEJEV. XC X IF(JUPDM.GT.0.AND.ITNUM.GT.1.AND.OUTPUT.GT.4. X $ AND.ITNUM.GT.NIEJEV) THEN X WRITE(NUNIT,2) X WRITE(NUNIT,9) X9 FORMAT(T3,'*',4X,'RESTRT IS TRUE - JACOBIAN', X $ ' EVALUATED EXPLICITLY',T74,'*') X END IF XC XC NOTE: MATRIX H IS USED HERE TO HOLD THE FINITE XC DIFFERENCE ESTIMATION USED IN CHECKING THE XC ANALYTICAL JACOBIAN IF CHECKJ IS TRUE. XC VECTORS WV1 AND, FOR CENTRAL DIFFERENCES, XC WV2 TEMPORARILY HOLD THE FINITE DIFFERENCE XC FUNCTION EVALUATIONS. XC X CALL JACOBI(CHECKJ,JACERR,OVERFL,JACTYP,N , X $ NUNIT ,OUTPUT,EPSMCH,FDTOLJ,BOUNDL, X $ BOUNDU,FVECC ,WV1 ,WV2 ,JAC , X $ H ,SCALEX,WV3 ,XC ,FVECEV, X $ JACEV ) X NJETOT=NJETOT+1 XC XC RETURN IF ANALYTICAL AND NUMERICAL JACOBIANS DON'T XC AGREE (APPLICABLE ONLY IF CHECKJ IS TRUE AND A DIS- XC CREPANCY IS FOUND WITHIN SUBROUTINE JACOBI). A XC WARNING IS GIVEN FROM WITHIN JACOBI. XC X IF(JACERR) RETURN XC XC RESET TOTAL NUMBER OF FUNCTION EVALUATIONS TO NEGLECT XC THOSE USED IN CHECKING ANALYTICAL JACOBIAN. XC X IF(CHECKJ) NFETOT=NFESTR XC X IF(JUPDM.GT.0) THEN XC XC FCNMIN IS THE MINIMUM OF THE OBJECTIVE FUNCTION FOUND XC SINCE THE LAST EXPLICIT JACOBIAN EVALUATION. IT IS XC USED TO ESTABLISH WHICH STEP THE PROGRAM RETURNS TO XC WHEN A QUASI-NEWTON STEP FAILS. XC X FCNMIN=FCNOLD XC XC POWTAU IS THE TAU FROM POWELL'S TRUST REGION UPDATING XC SCHEME (USED WHEN JUPDM=1). iT IS RESET TO 1.0 AT XC EVERY EXPLICIT JACOBIAN EVALUATION IN QUASI-NEWTON XC METHODS. XC X POWTAU=ONE XC XC AT EVERY EXPLICIT JACOBIAN EVALUATION EXCEPT XC POSSIBLY THE FIRST, IN QUASI-NEWTON METHODS, A XC NEW TRUST REGION IS CALCULATED INTERNALLY USING XC EITHER THE NEWTON STEP OR THE CAUCHY STEP AS XC SPECIFIED BY THE USER IN LOGICAL VARIABLE "CAUCHY" XC IN SUBROUTINE DELCAU. THIS IS FORCED BY SETTING XC DELTA TO A NEGATIVE NUMBER. XC X IF(ITNUM.GT.1) DELTA=-ONE XC XC RESET COUNTER FOR NUMBER OF FAILURES OF RATIO XC TEST (IS FCNNEW/FCNOLD LESS THAN RATIOF?) SINCE XC LAST EXPLICIT JACOBIAN UPDATE. XC X NFAIL=0 X IF(OUTPUT.GT.4.AND.ITNUM.GT.NIEJEV) THEN X WRITE(NUNIT,2) X WRITE(NUNIT,10) X10 FORMAT(T3,'*',4X,'NUMBER OF FAILURES OF RATIO', X $ ' TEST, NFAIL, SET BACK TO 0',T74,'*') X END IF XC XC ESTABLISH A NEW MAXIMUM STEP LENGTH ALLOWED. XC X IF(ITNUM.GT.1) CALL MAXST(OVERFL,MAXEXP,N ,NUNIT, X $ OUTPUT,EPSMCH,MAXSTP,MSTPF , X $ SCALEX,WV1 ,XC ) XC XC SET "P" MATRIX TO IDENTITY FOR LEE AND LEE UPDATE XC (JUPDM=2). XC X IF(JUPDM.EQ.2.AND.ITNUM.GE.NIEJEV) THEN X DO 300 J=1,N X DO 400 I=1,N X PLEE(I,J)=ZERO X400 CONTINUE X PLEE(J,J)=ONE X300 CONTINUE X END IF X END IF X END IF X IF((RESTRT.OR.QNUPDM.EQ.0).AND.OUTPUT.GT.4.AND. X $ (.NOT.MATSUP)) THEN XC XC WRITE JACOBIAN MATRIX. XC X WRITE(NUNIT,2) X WRITE(NUNIT,11) X11 FORMAT(T3,'*',4X,'JACOBIAN MATRIX',T74,'*') X CALL MATPRT(N,N,N,N,NUNIT,JAC) X END IF XC XC ESTABLISH SCALING MATRICES IF DESIRED (ITSCLF=0 => NO XC ADAPTIVE SCALING, WHILE ITSCLF > 0 MEANS ADAPTIVE SCALING XC STARTS AFTER THE (ITSCLF)TH ITERATION). SIMILARLY FOR XC COMPONENT SCALING ... . NOTE: SCALING FACTORS ARE UPDATED XC ONLY WHEN THE JACOBIAN IS UPDATED EXPLICITLY IN QUASI-NEWTON XC METHODS. XC XC FUNCTION SCALING. XC X IF(RESTRT.AND.ITSCLF.GT.0.AND.ITSCLF.LE.ITNUM) THEN XC X CALL ASCALF(N,EPSMCH,FVECC,JAC,SCALEF) XC X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,2) X WRITE(NUNIT,12) X12 FORMAT(T3,'*',4X,'FUNCTION SCALING MATRIX', X $ T74,'*') X WRITE(NUNIT,2) X DO 500 I=1,N X WRITE(NUNIT,13) I,SCALEF(I) X13 FORMAT(T3,'*',7X,'SCALEF(',I3,') = ',1PD12.3, X $ T74,'*') X500 CONTINUE X END IF XC XC RECALCULATE OBJECTIVE FUNCTION WITH NEW SCALING XC FACTORS. THIS AVOIDS PREMATURE FAILURES IF THE XC CHANGE IS SCALING FACTORS WOULD MAKE THE PREVIOUS XC OBJECTIVE FUNCTION VALUE SMALLER. XC X CALL FCNEVL(OVERFL,MAXEXP,N ,NUNIT ,OUTPUT, X $ EPSMCH,FCNOLD,FVECC ,SCALEF,WV1 ) X END IF XC XC COMPONENT SCALING. XC X IF(RESTRT.AND.ITSCLX.GT.0.AND.ITSCLX.LE.ITNUM) THEN XC X CALL ASCALX(N,EPSMCH,JAC,SCALEX) XC X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,2) X WRITE(NUNIT,14) X14 FORMAT(T3,'*',7X,'COMPONENT SCALING MATRIX', X $ T74,'*') X WRITE(NUNIT,2) X DO 600 I=1,N X WRITE(NUNIT,15) I,SCALEX(I) X15 FORMAT(T3,'*',10X,'SCALEX(',I3,') = ',1PD12.3, X $ T74,'*') X600 CONTINUE X END IF X END IF XC XC FIND GRADIENT OF 1/2 FVECC^FVECC (NOT USED IF DECOMPOSED XC MATRIX IS UPDATED IN WHICH CASE THE GRADIENT IS FOUND XC WITHIN THAT SUBROUTINE - CALL IS MADE FOR OUTPUT ONLY). XC XC X CALL GRADF(OVERCH,OVERFL,RESTRT,SCLFCH,SCLXCH,JUPDM , X $ MAXEXP,N ,NUNIT ,OUTPUT,QNUPDM,DELF , X $ FVECC ,JAC ,SCALEF,SCALEX,WV1 ) XC XC FIND NEWTON STEP USING QR DECOMPOSITION. XC XC IF JUPDM = 0 OR QNUPDM = 0 THEN THE UNFACTORED FORM XC FOR CALCULATING THE NEWTON STEP IS USED. XC X IF(JUPDM.EQ.0.OR.QNUPDM.EQ.0) THEN XC XC NEWTON STEP - UNFACTORED FORM BEING UPDATED. XC X CALL NSTPUN(ABORT ,LINESR,OVERCH,OVERFL,QRSING, X $ SCLFCH,SCLXCH,ITNUM ,MAXEXP,N , X $ NUNIT ,OUTPUT,EPSMCH,A ,DELF , X $ FVECC ,H ,HHPI ,JAC ,RDIAG , X $ SCALEF,SCALEX,SN ,WV1 ,WV2 , X $ WV3 ) X ELSE XC XC NEWTON STEP - FACTORED FORM BEING UPDATED. XC X CALL NSTPFA(ABORT ,LINESR,OVERCH,OVERFL,QRSING, X $ RESTRT,SCLFCH,SCLXCH,ITNUM ,MAXEXP, X $ N ,NEWSTM,NUNIT ,OUTPUT,EPSMCH, X $ A ,DELF ,FVECC ,H ,HHPI , X $ JAC ,RDIAG ,SCALEF,SCALEX,SN , X $ WV1 ,WV2 ,WV3) XC X END IF XC XC RUN IS ABORTED IF THE JACOBIAN BECOMES ESSENTIALLY XC ALL ZEROS. NOTE: 203 FOLLOWS END OF MAIN 200 LOOP. XC X IF(ABORT) GO TO 203 XC XC CHECK FOR CONVERGENCE ON LENGTH OF NEWTON STEP IF XC STOPCR = 1, 12 OR 3. XC X IF(STOPCR.NE.2) THEN X STPMAX=ZERO X DO 700 I=1,N X STPMAX=MAX(STPMAX,ABS(SN(I))/MAX(XC(I),SCALEX(I))) X WV1(I)=SCALEX(I)*XC(I) X700 CONTINUE X CALL TWONRM(OVERFL,MAXEXP,N,EPSMCH,XNORM,WV1) X IF(STPMAX.LE.NSTTOL*(ONE+XNORM)) THEN X TRMCOD=1 XC XC IF STOPCR=3 THEN OBJECTIVE FUNCTION VALUE MUST XC BE DETERMINED AS WELL - OTHERWISE A SOLUTION XC HAS BEEN FOUND. XC X IF(STOPCR.NE.3) THEN X GO TO 202 XC XC NOTE: STATEMENT 202 PRECEDES CONVERGENCE XC CHECKING SUBROUTINE. XC X END IF X END IF X END IF XC XC FIND LENGTH OF (SCALED) NEWTON STEP, NEWLEN. XC X DO 800 I=1,N X WV1(I)=SCALEX(I)*SN(I) X800 CONTINUE X CALL TWONRM(OVERFL,MAXEXP,N,EPSMCH,NEWLEN,WV1) XC XC FOR ITERATIONS AFTER THE ARMIJO STEPS HAVE BEEN COMPLETED XC AT THE BEGINNING (IN OTHER WORDS THE MONOTONIC STEPS) XC STORE THE FUNCTION AND, POSSIBLY, THE NEWTON STEP LENGTHS XC IN THE FTRACK AND STRACK VECTORS, RESPECTIVELY. XC X IF(ISEJAC.GE.NARMIJ) THEN X IF(ISEJAC.EQ.1) THEN X STRACK(0)=NEWLEN XC XC NEWMAX IS USED TO KEEP A BOUND ON THE ENTRIES IN XC THE STRACK VECTOR. XC X NEWMAX=NEWLEN X ELSE X STRACK(COUNTR)=MIN(NEWMAX,NEWLEN) X END IF XC XC THE OBJECTIVE FUNCTION VALUE IS STORED EVEN IF IT IS XC GREATER THAN ANY PRECEEDING FUNCTION VALUE. XC X FTRACK(COUNTR)=FCNOLD XC XC WRITE FTRACK AND STRACK VECTORS IF DESIRED. SINCE ONLY XC THE LAST MGLL VALUES ARE NEEDED THE COUNTER CIRCULATES XC THROUGH THE VECTOR CAUSING ONLY THE MGLL MOST RECENT XC VALUES TO BE KEPT. NOTE: THESE VECTORS ARE NOT APPLI- XC CABLE IF NEWTON'S METHOD IS BEING USED. XC X IF(.NOT.NEWTON.AND.OUTPUT.GT.4) THEN X WRITE(NUNIT,2) X WRITE(NUNIT,2) XC XC IF ONLY THE FUNCTION VALUE ACCEPTANCE TEST IS BEING XC USED, THUS ACPTCR=1, THEN ONLY THE FTRACK VECTOR XC IS APPLICABLE. XC X IF(ACPTCR.EQ.1) THEN X WRITE(NUNIT,16) COUNTR X16 FORMAT(T3,'*',4X,'CURRENT FTRACK VECTOR;', X $ 2X,'LATEST CHANGE: ELEMENT',I4,T74,'*') X WRITE(NUNIT,2) X DO 900 J=0,MGLL-1 X WRITE(NUNIT,17) J,FTRACK(J) X17 FORMAT(T3,'*',7X,'FTRACK(',I3,') = ',1PD11.3, X $ T74,'*') X900 CONTINUE XC X ELSE XC XC BOTH THE FUNCTION VALUE AND THE STEP SIZE XC ACCEPTANCE TESTS ARE BEING USED, ACPTCR=12. XC X WRITE(NUNIT,18) COUNTR X18 FORMAT(T3,'*',4X,'CURRENT FTRACK AND STRACK', X $ ' VECTORS;',2X,'LATEST CHANGE: ELEMENT',I4, X $ T74,'*') X WRITE(NUNIT,2) X DO 1000 J=0,MGLL-1 X WRITE(NUNIT,19) J,FTRACK(J),J,STRACK(J) X19 FORMAT(T3,'*',7X,'FTRACK(',I3,') = ', X $ 1PD11.3,' STRACK(',I3,') = ',1PD11.3, X $ T74,'*') X1000 CONTINUE X END IF X END IF XC XC UPDATE COUNTING INTEGER, COUNTR. RECYCLE IF COUNTR XC HAS REACHED MGLL-1. XC X IF(COUNTR.EQ.MGLL-1) THEN X COUNTR=0 X ELSE X COUNTR=COUNTR+1 X END IF X END IF XC XC RESET STEP ACCEPTANCE CODE AND DELSTR. XC X ACPCOD=0 X IF(.NOT.LINESR) DELSTR=ZERO XC XC RESET QNFAIL TO FALSE TO AVOID PREMATURE STOPPING. XC X QNFAIL=.FALSE. XC X IF(LINESR) THEN XC XC THE MAIN LINE SEARCH IS CALLED IN SUBROUTINE LINE. XC X CALL LINE(ABORT ,ABSNEW,DEUFLH,GEOMS ,NEWTON, X $ OVERCH,OVERFL,QNFAIL,QRSING,RESTRT, X $ SCLFCH,SCLXCH,ACPCOD,ACPTCR,CONTYP, X $ ISEJAC,ITNUM ,JUPDM ,MAXEXP,MAXLIN, X $ MGLL ,MNEW ,N ,NARMIJ,NFUNC , X $ NUNIT ,OUTPUT,QNUPDM,STOPCR,TRMCOD, X $ ALPHA ,CONFAC,EPSMCH,FCNMAX,FCNNEW, X $ FCNOLD,LAM0 ,MAXSTP,NEWLEN,SBRNRM, X $ SIGMA ,A ,BOUNDL,BOUNDU,DELF , X $ FTRACK,FVEC ,H ,HHPI ,JAC , X $ RDIAG ,WV1 ,S ,SBAR ,SCALEF, X $ SCALEX,SN ,STRACK,WV2 ,XC , X $ XPLUS ,FVECEV) X IF(ABORT) THEN X IF(OUTPUT.GT.0) THEN X WRITE(NUNIT,2) X WRITE(NUNIT,1) X END IF X RETURN X END IF XC XC NOTE: 201 PRECEDES PRINTING OF ITERATION RESULTS. XC X IF(NEWTON) GO TO 201 XC X ELSE XC XC TRUST REGION METHOD XC XC ESTABLISH INITIAL TRUST REGION SIZE, DELTA, AND/OR XC FIND LENGTH OF SCALED DESCENT STEP, CAULEN. XC X CALL DELCAU(CAUCHY,OVERCH,OVERFL,ISEJAC,MAXEXP, X $ N ,NUNIT ,OUTPUT,BETA ,CAULEN, X $ DELTA ,EPSMCH,MAXSTP,NEWLEN,SQRTZ , X $ A ,DELF ,SCALEX,WV1 ) XC X FRSTDG=.TRUE. XC X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,2) X WRITE(NUNIT,2) X WRITE(NUNIT,20) X20 FORMAT(T3,'*',4X,'SUMMARY OF TRUST REGION', X $ ' METHOD USING (DOUBLE) DOGLEG STEP',T74,'*') X END IF XC XC MAIN INTERNAL LOOP FOR TRUST REGION METHOD. XC XC THE TRUST REGION SIZE IS STORED FOR COMPARISON XC LATER TO SET THE PARAMETER POWTAU USED IN POWELL'S XC TRUST REGION UPDATING SCHEME (QUASI-NEWTON, TRUPDM=1). XC X DELTA0=DELTA XC X DO 1100 NOTRST=1,MAXTRS XC X CALL DOGLEG(FRSTDG,NEWTKN,OVERCH,OVERFL,MAXEXP, X $ N ,NOTRST,NUNIT ,OUTPUT,BETA , X $ CAULEN,DELTA ,ETAFAC,NEWLEN,SQRTZ , X $ DELF ,S ,SCALEX,SN ,SSDHAT, X $ VHAT ) XC XC NOTE: WV1 AND WV4 HOLD THE COMPONENT AND RESIDUAL XC VECTOR RESPECTIVELY FOR A TRIAL POINT WHICH XC HAS BEEN FOUND TO BE ACCEPTABLE WHILE THE XC TRUST REGION IS EXPANDED AND A NEW TRIAL XC POINT TESTED. WV2 AND WV3 ARE WORK VECTORS. XC H IS CALLED ASTORE INSIDE TRSTUP. XC X CALL TRSTUP(GEOMS ,NEWTKN,OVERCH,OVERFL,QRSING, X $ SCLFCH,SCLXCH,ACPCOD,ACPSTR,ACPTCR, X $ CONTYP,ISEJAC,JUPDM ,MAXEXP,MGLL , X $ MNEW ,N ,NARMIJ,NFUNC ,NOTRST, X $ NUNIT ,OUTPUT,QNUPDM,RETCOD,TRUPDM, X $ ALPHA ,CONFAC,DELFAC,DELSTR,DELTA , X $ EPSMCH,FCNMAX,FCNNEW,FCNOLD,FCNPRE, X $ MAXSTP,NEWLEN,NEWMAX,POWTAU,RELLEN, X $ STPTOL,A ,H ,BOUNDL,BOUNDU, X $ DELF ,WV1 ,FTRACK,FVEC ,FVECC , X $ HHPI ,JAC ,RDIAG ,WV2 ,S , X $ SBAR ,SCALEF,SCALEX,STRACK,WV3 , X $ XC ,WV4 ,XPLUS ,FVECEV) XC X IF(OUTPUT.GT.4.OR.(RETCOD.EQ.7.AND.OUTPUT.GT.2)) X $ CALL RCDPRT(NUNIT,RETCOD,DELTA,RELLEN,STPTOL) XC XC IF NO PROGRESS WAS BEING MADE (RETCOD=7) IN A XC QUASI-NEWTON STEP RETRY WITH AN EXPLICIT JACOBIAN XC EVALUATION. XC X IF(RETCOD.EQ.7.AND.(.NOT.RESTRT)) QNFAIL=.TRUE. XC XC RETURN CODE LESS THAN 8 EXITS FROM TRUST REGION XC LOOP. XC X IF(RETCOD.LT.8) GO TO 1101 XC X1100 CONTINUE XC XC IF NO SUCCESSFUL STEP FOUND IN A QUASI-NEWTON STEP XC RETRY WITN AN EXPLICIT JACOBIAN EVALUATION. XC X IF(.NOT.RESTRT) QNFAIL=.TRUE. XC X END IF XC X1101 CONTINUE XC X IF(.NOT.LINESR) THEN X IF(DELTA.LT.DELTA0) POWTAU=ONE X DELTA=MAX(DELTA,1.0D-10) X END IF XC XC IF RETCOD=7 AND STOPCR=2 RESET STOPPING CRITERION TO XC AVOID HANGING IN TRUST REGION METHOD. (RETCOD=7 MEANS XC THE RELATIVE STEP LENGTH WAS LESS THAN STPTOL). XC X IF(.NOT.LINESR.AND.RETCOD.EQ.7.AND.STOPCR.EQ.2.AND. X $ (.NOT.QNFAIL)) THEN X STOPCR=12 X END IF XC XC RETAIN NUMBER OF STEPS ACCEPTED BY EACH CRITERION XC FOR PERFORMANCE EVALUATION. XC X IF(.NOT.NEWTON) THEN X IF(ACPCOD.EQ.1) THEN X NAC1=NAC1+1 X ELSEIF(ACPCOD.EQ.2) THEN X NAC2=NAC2+1 X ELSEIF(ACPCOD.EQ.12) THEN X NAC12=NAC12+1 X END IF X END IF XC X201 CONTINUE XC XC PRINT RESULTS OF ITERATION. XC X IF(OUTPUT.GT.2) THEN XC X CALL NERSL(NEWTON,RESTRT,SCLFCH,SCLXCH,ACPCOD,JUPDM , X $ N ,NUNIT ,OUTPUT,FCNNEW,FVEC ,XPLUS ) XC X END IF XC XC CHECK FOR CONVERGENCE. STATEMENT 202 IS USED IF THE XC STEP SIZE OF THE NEWTON STEP IS FOUND TO BE WITHIN XC THE SPECIFIED TOLERANCE AND STOPCR IS 1 OR 12. XC X202 CONTINUE XC X IF(.NOT.QNFAIL) THEN XC XC IF QNFAIL IS TRUE THE QUASI-NEWTON SEARCH FAILED TO XC FIND A SATISFACTORY STEP - SINCE THE JACOBIAN IS TO XC BE RE-EVALUATED AVOID PREMATURE STOPPAGES IN NESTOP. XC X CALL NESTOP(ABSNEW,LINESR,NEWTON,SCLFCH,SCLXCH, X $ ACPTCR,ITNUM ,N ,NAC1 ,NAC2 , X $ NAC12 ,NFUNC ,NJETOT,NUNIT ,OUTPUT, X $ STOPCR,TRMCOD,FCNNEW,FTOL ,NSTTOL, X $ STPMAX,STPTOL,FVEC ,SCALEF,SCALEX, X $ XC ,XPLUS ) X END IF XC XC IF THE TERMINATION CODE, TRMCOD, IS GREATER THAN 0 THEN XC CONVERGANCE HAS BEEN REACHED. XC X IF(TRMCOD.GT.0) RETURN XC XC QUASI-NEWTON UPDATING - JUPDM > 0. XC X IF(JUPDM.GT.0) THEN XC XC QNFAIL MEANS A FAILURE IN THE QUASI-NEWTON SEARCH. XC RE-EVALUATE JACOBIAN AND TRY A DAMPED NEWTON STEP. XC MAXLIN IS CHANGED FROM MAXQNS TO MAXNS OR MAXTRS IS XC CHANGED, SIMILARLY, AT THE START OF THE LOOP. XC X IF(QNFAIL) THEN X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,2) X WRITE(NUNIT,21) X21 FORMAT(T3,'*',7X,'FAILURE IN QUASI-NEWTON', X $ ' SEARCH: QNFAIL IS TRUE',T74,'*') X END IF XC X ELSEIF(.NOT.NEWTON) THEN XC XC QNFAIL IS FALSE - THE STEP HAS BEEN ACCEPTED. XC X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,2) X WRITE(NUNIT,22) FCNNEW,FCNOLD,FCNNEW/FCNOLD X22 FORMAT(T3,'*',7X,'FCNNEW= ',1PD11.3,2X, X $ 'FCNOLD= ',1PD11.3,2X,'RATIO= ',1PD11.3,T74,'*') X END IF X IF(FCNNEW/FCNOLD.GT.RATIOF) THEN XC XC STEP ACCEPTED BUT NOT A SIGNIFICANT IMPROVEMENT. XC X NFAIL=NFAIL+1 X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,2) X WRITE(NUNIT,23) NFAIL X23 FORMAT(T3,'*',7X,'RATIO > RATIOF SO', X $ ' NFAIL INCREASED TO: ',I5,T74,'*') X WRITE(NUNIT,2) X END IF X ELSE XC XC STEP ACCEPTED WITH A SIGNIFICANT IMPROVEMENT. XC X IF(FCNNEW/FCNOLD.GT.PT01) THEN X NOSUBT=0 X ELSE X NOSUBT=1 X END IF XC XC ITEMPT IS USED LOCALLY FOR OUTPUT CONTROL. XC X ITEMP=NFAIL X NFAIL=MAX(NFAIL-NOSUBT,0) X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,2) X IF(ITEMP.EQ.NFAIL) THEN X WRITE(NUNIT,24) NFAIL X24 FORMAT(T3,'*',7X,'NFAIL STAYS AT: ',I5, X $ T74,'*') X ELSE X WRITE(NUNIT,25) NFAIL X25 FORMAT(T3,'*',7X,'NFAIL CHANGED TO: ', X $ I5,T74,'*') X END IF X END IF X END IF XC XC SAVE THE RESULTS FOR RESTART IF A FAILURE IN THE XC QUASI-NEWTON METHOD OCCURS - ESSENTIALLY THIS XC FINDS THE BEST POINT SO FAR. XC X IF(ISEJAC.EQ.1.OR.NFAIL.EQ.1.OR.(NFAIL.LE.MINQNS X $ .AND.FCNNEW/FCNMIN.LT.ONE)) THEN X SAVEST=.TRUE. X FCNMIN=FCNNEW X END IF X IF(SAVEST) THEN X SAVEST=.FALSE. X FSTORE=FCNNEW X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,2) X WRITE(NUNIT,26) X26 FORMAT(T3,'*',7X,'STEP IS SAVED',T74,'*') X WRITE(NUNIT,2) X WRITE(NUNIT,27) X27 FORMAT(T3,'*',10X,'SAVED COMPONENT AND', X $ ' FUNCTION VALUES',T74,'*') X WRITE(NUNIT,2) X END IF X DO 1200 I=1,N X XSAVE(I)=XPLUS(I) X FSAVE(I)=FVEC(I) X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,28) I,XSAVE(I),I,FSAVE(I) X28 FORMAT(T3,'*',7X,'XSAVE(',I3,') = ', X $ 1PD12.3,6X,'FSAVE(',I3,') = ',1PD12.3, X $ T74,'*') X END IF X1200 CONTINUE X IF(OUTPUT.GT.4) WRITE(NUNIT,2) X ITSTR=ITNUM X END IF X END IF XC XC NOTE: IF QNFAIL IS TRUE THEN NFAIL CANNOT HAVE XC INCREASED IMPLYING THAT NFAIL CANNOT NOW XC BE GREATER THAN MINQNS. XC X IF(QNFAIL.OR.NFAIL.GT.MINQNS) THEN XC XC RESTART FROM BEST POINT FOUND SO FAR. XC X RESTRT=.TRUE. X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,2) X WRITE(NUNIT,2) X WRITE(NUNIT,29) X29 FORMAT(T3,'*',7X,'RESTRT IS TRUE',T74,'*') X END IF X DO 1300 J=0,MGLL-1 X FTRACK(J)=ZERO X1300 CONTINUE X IF(ACPTCR.EQ.12) THEN X DO 1400 J=0,MGLL-1 X STRACK(J)=ZERO X1400 CONTINUE X END IF X COUNTR=0 X ISEJAC=0 X MNEW=0 X TRMCOD=0 X FCNOLD=FSTORE X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,2) X WRITE(NUNIT,30) ITSTR X30 FORMAT(T3,'*',7X,'RETURN TO ITERATION:', X $ I5,3X,'WHERE',T74,'*') X WRITE(NUNIT,2) X END IF X DO 1500 I=1,N X XC(I)=XSAVE(I) X FVECC(I)=FSAVE(I) X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,31) I,XC(I),I,FVECC(I) X31 FORMAT(T3,'*',7X,'XC(',I3,') = ', X $ 1PD12.3,3X,'FVECC(',I3,') = ',1PD12.3, X $ T74,'*') X END IF X1500 CONTINUE X IF(OUTPUT.GT.4) WRITE(NUNIT,2) X ELSE X IF(ITNUM.GE.NIEJEV) RESTRT=.FALSE. X END IF X END IF XC XC UPDATE JACOBIAN IF DESIRED: XC QNUPDM = 0 => ACTUAL JACOBIAN BEING UPDATED XC QNUPDM = 1 => FACTORED JACOBIAN BEING UPDATED XC X IF(.NOT.RESTRT) THEN XC X IF(QNUPDM.EQ.0) THEN XC X IF(JUPDM.EQ.1) THEN XC XC USE BROYDEN UPDATE. XC X CALL BROYUN(OVERFL,MAXEXP,N ,NUNIT ,OUTPUT, X $ EPSMCH,FVEC ,FVECC ,JAC ,SCALEX, X $ WV1 ,XC ,XPLUS) XC X ELSEIF(JUPDM.EQ.2) THEN XC XC USE LEE AND LEE UPDATE. XC X CALL LLUN(OVERCH,OVERFL,ISEJAC,MAXEXP,N , X $ NUNIT ,OUTPUT,EPSMCH,OMEGA ,FVEC , X $ FVECC ,JAC ,PLEE ,S ,SCALEX, X $ WV1 ,XC ,XPLUS) XC X END IF XC X ELSE XC XC THE FACTORED FORM OF THE JACOBIAN IS UPDATED. XC X IF(JUPDM.EQ.1) THEN XC X CALL BROYFA(OVERCH,OVERFL,SCLFCH,SCLXCH,MAXEXP, X $ N ,NUNIT ,OUTPUT,EPSMCH,A , X $ DELF ,FVEC ,FVECC ,JAC ,RDIAG , X $ S ,SCALEF,SCALEX,WV1 ,WV2 , X $ XC ,XPLUS ) XC X ELSEIF(JUPDM.EQ.2) THEN XC X CALL LLFA(OVERCH,OVERFL,SCLFCH,SCLXCH,ISEJAC, X $ MAXEXP,N ,NUNIT ,OUTPUT,EPSMCH, X $ OMEGA ,A ,DELF ,FVEC ,FVECC , X $ JAC ,PLEE ,RDIAG ,S ,SCALEF, X $ SCALEX,WV1 ,WV2 ,WV3 ,XC , X $ XPLUS ) XC X END IF XC X END IF XC X END IF XC XC UPDATE CURRENT VALUES - RESET TRMCOD TO ZERO. XC XC UPDATE M "VECTOR" (ACTUALLY ONLY THE LATEST VALUE IS XC NEEDED). XC X MOLD=MNEW X IF(ISEJAC.LT.NARMIJ) THEN X MNEW=0 X ELSE X MNEW=MIN(MOLD+1,MGLL-1) X END IF X IF(JUPDM.EQ.0.OR.(JUPDM.GT.0.AND.(.NOT.RESTRT))) THEN XC X CALL UPDATE(MNEW ,MOLD ,N ,TRMCOD,FCNNEW, X $ FCNOLD,FVEC ,FVECC ,XC ,XPLUS ) X END IF XC X200 CONTINUE X203 CONTINUE XC X IF(OUTPUT.GT.0) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,2) X WRITE(NUNIT,32) ITNUM-1 X32 FORMAT(T3,'*',2X,'NO SOLUTION FOUND AFTER',I6, X $ ' ITERATION(S)',T74,'*') X WRITE(NUNIT,2) X WRITE(NUNIT,33) X33 FORMAT(T3,'*',9X,'FINAL ESTIMATES',15X, X $ 'FINAL FUNCTION VALUES',T74,'*') X WRITE(NUNIT,2) X DO 1600 I=1,N X WRITE(NUNIT,34) I,XPLUS(I),I,FVEC(I) X34 FORMAT(T3,'*',6X,'X(',I3,') = ',1PD12.3,12X, X $ 'F(',I3,') = ',1PD12.3,T74,'*') X1600 CONTINUE X WRITE(NUNIT,2) X WRITE(NUNIT,36) FCNNEW X36 FORMAT(T3,'*',2X,'FINAL OBJECTIVE FUNCTION VALUE = ', X $ 1PD12.3,T74,'*') X WRITE(NUNIT,2) X WRITE(NUNIT,1) X END IF X RETURN XC XC LAST CARD OF SUBROUTINE NNES. XC X END X X END_OF_FILE if test 36626 -ne `wc -c <'nnes.f'`; then echo shar: \"'nnes.f'\" unpacked with wrong size! fi # end of 'nnes.f' fi if test -f 'nnesdr.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'nnesdr.f'\" else echo shar: Extracting \"'nnesdr.f'\" \(5036 characters\) sed "s/^X//" >'nnesdr.f' <<'END_OF_FILE' X PROGRAM NNESDR X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X PARAMETER ( MGLL= 10, X $ N= ?, X $ NUNIT= ?) X DOUBLE PRECISION X $ JAC(N,N) ,LAM0 ,MCHEPS ,MSTPF , X $ NSTTOL X INTEGER ACPTCR ,OUTPUT ,QNUPDM ,STOPCR , X $ SUPPRS ,TRMCOD ,TRUPDM X DIMENSION A(N,N) ,BOUNDL(N) ,BOUNDU(N) ,DELF(N) , X $ FSAVE(N) ,FTRACK(0:MGLL-1) ,FVEC(N) , X $ FVECC(N) ,H(N,N) ,HHPI(N) ,PLEE(N,N), X $ RDIAG(N) ,S(N) ,SBAR(N) ,SCALEF(N), X $ SCALEX(N) ,SN(N) ,SSDHAT(N) , X $ STRACK(0:MGLL-1) ,VHAT(N) ,WV1(N) , X $ WV2(N) ,WV3(N) ,WV4(N) ,XC(N) , X $ XPLUS(N) ,XSAVE(N) X LOGICAL ABSNEW ,BYPASS ,CAUCHY ,DEUFLH , X $ GEOMS ,LINESR ,MATSUP ,NEWTON , X $ OVERCH ,WRNSUP X CHARACTER*6 HELP X******************************************************************** X* * X* RENAME FUNCTION AND/OR JACOBIAN * X* * X******************************************************************** X EXTERNAL FCN,JACOB X COMMON/NNES_1/MATSUP X COMMON/NNES_2/WRNSUP X COMMON/NNES_3/BYPASS X COMMON/NNES_4/NFETOT X OPEN(UNIT=NUNIT,FILE='NNESDR.OUT',STATUS='UNKNOWN') X******************************************************************** X* * X* INSERT INITIAL ESTIMATES * X* * X******************************************************************** X CALL SETUP(ABSNEW ,CAUCHY ,DEUFLH ,GEOMS ,LINESR , X $ NEWTON ,OVERCH ,ACPTCR ,ITSCLF ,ITSCLX , X $ JACTYP ,JUPDM ,MAXEXP ,MAXIT ,MAXNS , X $ MAXQNS ,MINQNS ,N ,NARMIJ ,NIEJEV , X $ NJACCH ,OUTPUT ,QNUPDM ,STOPCR ,SUPPRS , X $ TRUPDM ,ALPHA ,CONFAC ,DELTA ,DELFAC , X $ EPSMCH ,ETAFAC ,FDTOLJ ,FTOL ,LAM0 , X $ MSTPF ,NSTTOL ,OMEGA ,RATIOF ,SIGMA , X $ STPTOL ,BOUNDL ,BOUNDU ,SCALEF ,SCALEX , X $ HELP) X******************************************************************** X* * X* INSERT CHANGES TO DEFAULT SETTINGS * X* * X******************************************************************** X CALL NNES(ABSNEW ,CAUCHY ,DEUFLH ,GEOMS ,LINESR , X $ NEWTON ,OVERCH ,ACPTCR ,ITSCLF ,ITSCLX , X $ JACTYP ,JUPDM ,MAXEXP ,MAXIT ,MAXNS , X $ MAXQNS ,MGLL ,MINQNS ,N ,NARMIJ , X $ NIEJEV ,NJACCH ,NJETOT ,NUNIT ,OUTPUT , X $ QNUPDM ,STOPCR ,SUPPRS ,TRMCOD ,TRUPDM , X $ ALPHA ,CONFAC ,DELTA ,DELFAC ,EPSMCH , X $ ETAFAC ,FCNNEW ,FDTOLJ ,FTOL ,LAM0 , X $ MSTPF ,NSTTOL ,OMEGA ,RATIOF ,SIGMA , X $ STPTOL ,A ,BOUNDL ,BOUNDU ,DELF , X $ FSAVE ,FTRACK ,FVEC ,FVECC ,H , X $ HHPI ,JAC ,PLEE ,RDIAG ,S , X $ SBAR ,SCALEF ,SCALEX ,SN ,SSDHAT , X $ STRACK ,VHAT ,WV1 ,WV2 ,WV3 , X $ WV4 ,XC ,XPLUS ,XSAVE ,HELP , X $ FCN ,JACOB ) X STOP X END X SUBROUTINE FCN(OVERFL,N,FVEC,XC) X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DIMENSION FVEC(N),XC(N) X COMMON/NNES_4/NFETOT X COMMON/EXPON/IEXPON X LOGICAL OVERFL X OVERFL=.FALSE. X NFETOT=NFETOT+1 X******************************************************************** X* * X* INSERT FUNCTIONS * X* * X******************************************************************** X RETURN X END X SUBROUTINE JACOB(OVERFL,N,JAC,XC) X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION JAC(N,N) X DIMENSION XC(N) X LOGICAL OVERFL X OVERFL=.FALSE. X******************************************************************** X* * X* INSERT ANALYTICAL JACOBIAN IF DESIRED * X* * X******************************************************************** X RETURN X END X END_OF_FILE if test 5036 -ne `wc -c <'nnesdr.f'`; then echo shar: \"'nnesdr.f'\" unpacked with wrong size! fi # end of 'nnesdr.f' fi if test -f 'nstpfa.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'nstpfa.f'\" else echo shar: Extracting \"'nstpfa.f'\" \(12581 characters\) sed "s/^X//" >'nstpfa.f' <<'END_OF_FILE' X SUBROUTINE NSTPFA(ABORT ,LINESR,OVERCH,OVERFL,QRSING, X $ RESTRT,SCLFCH,SCLXCH,ITNUM ,MAXEXP, X $ N ,NEWSTM,NUNIT ,OUTPUT,EPSMCH, X $ A ,DELF ,FVECC ,H ,HHPI , X $ JAC ,RDIAG ,SCALEF,SCALEX,SN , X $ WV1 ,WV2 ,WV3) XC XC FEB. 23, 1992 XC XC THIS SUBROUTINE FINDS THE NEWTON STEP. XC XC IF THE JACOBIAN IS DETECTED AS SINGULAR OR IF THE ESTIMATED XC CONDITION NUMBER IS TOO HIGH (GREATER THAN EPSMCH**(-2/3)) XC THEN H:=J^J IS FORMED AND THE DIAGONAL IS PERTURBED BY ADDING XC SQRT(N*EPSMCH)*H1NORM*SCALEX(I)**2 TO THE CORRESPONDING XC ELEMENT. A CHOLESKY DECOMPOSITION IS PERFORMED ON THIS XC MODIFIED MATRIX PRODUCING A PSEUDO-NEWTON STEP. XC XC IF THE CONDITION NUMBER IS SMALL THEN THE NEWTON STEP, SN, XC IS FOUND DIRECTLY BY BACK SUBSTITUTION. XC XC ABORT IF THE 1-NORM OF MATRIX H BECOMES TOO SMALL XC ALTHOUGH BUT NOT AT A SOLUTION XC BYPASS ALLOWS BYPASSING OF THE SPECIAL TREATMENT FOR XC BADLY CONDITIONED JACOBIANS XC QRSING INDICATES SINGULAR JACOBIAN DETECTED XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION MAXADD ,MAXFFL ,JAC(N,N) X INTEGER OUTPUT X DIMENSION A(N,N) ,DELF(N) ,FVECC(N) ,H(N,N) , X $ HHPI(N) ,RDIAG(N) ,SCALEF(N),SCALEX(N), X $ SN(N) ,WV1(N) ,WV2(N) ,WV3(N) X LOGICAL ABORT ,BYPASS ,LINESR ,MATSUP , X $ OVERCH ,OVERFL ,PERTRB ,QRSING , X $ RESTRT ,SCLFCH ,SCLXCH ,WRNSUP X COMMON/NNES_1/MATSUP X COMMON/NNES_2/WRNSUP X COMMON/NNES_3/BYPASS X DATA ZERO,ONE /0.0D0,1.0D0/ XC X ABORT=.FALSE. X OVERFL=.FALSE. X SQRTEP=SQRT(EPSMCH) XC X IF(RESTRT) THEN X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X1 FORMAT(T3,'*',T74,'*') X WRITE(NUNIT,1) X WRITE(NUNIT,2) X2 FORMAT(T3,'*',4X,'SOLUTION OF LINEAR SYSTEM FOR', X $ ' NEWTON STEP, SN',T74,'*') X END IF XC XC STORE (POSSIBLY SCALED) JACOBIAN IN MATRIX A. XC X IF(.NOT.SCLFCH) THEN X CALL MATCOP(N,N,N,N,N,N,JAC,A) X ELSE X DO 100 I=1,N X IF(SCALEF(I).NE.ONE) THEN X SCALFI=SCALEF(I) X DO 200 J=1,N X A(I,J)=JAC(I,J)*SCALFI X200 CONTINUE X ELSE X DO 300 J=1,N X A(I,J)=JAC(I,J) X300 CONTINUE X END IF X100 CONTINUE X END IF XC XC SCALED JACOBIAN IS PRINTED ONLY IF AT LEAST ONE SCALING XC FACTOR IS NOT 1.0. XC X IF(OUTPUT.GT.4.AND.SCLFCH) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,1) X WRITE(NUNIT,3) X3 FORMAT(T3,'*',7X,'SCALED JACOBIAN MATRIX',T74,'*') X CALL MATPRT(N,N,N,N,NUNIT,A) X END IF XC XC QR DECOMPOSITION OF (POSSIBLY SCALED) JACOBIAN. XC X CALL QRDCOM(QRSING,N,EPSMCH,A,HHPI,RDIAG) XC X IF(OUTPUT.GT.4.AND.N.GT.1.AND.(.NOT.MATSUP)) THEN X WRITE(NUNIT,1) X IF(.NOT.SCLFCH) THEN X WRITE(NUNIT,4) X4 FORMAT(T3,'*',7X,'QR DECOMPOSITION OF JACOBIAN', X $ ' MATRIX',T74,'*') X ELSE X WRITE(NUNIT,5) X5 FORMAT(T3,'*',7X,'QR DECOMPOSITION OF SCALED', X $ ' JACOBIAN MATRIX',T74,'*') X END IF X CALL MATPRT(N,N,N,N,NUNIT,A) X WRITE(NUNIT,1) X WRITE(NUNIT,6) X6 FORMAT(T3,'*',12X,'DIAGONAL OF R',10X,'PI FACTORS', X $ ' FROM QR DECOMPOSITION',T74,'*') X WRITE(NUNIT,1) X DO 400 I=1,N-1 X WRITE(NUNIT,7) I,RDIAG(I),I,HHPI(I) X7 FORMAT(T3,'*',7X,'RDIAG(',I3,') = ',1PD11.3, X $ 8X,'HHPI(',I3,') = ',1PD12.3,T74,'*') X400 CONTINUE X WRITE(NUNIT,8) N,RDIAG(N) X8 FORMAT(T3,'*',7X,'RDIAG(',I3,') = ',1PD11.3, X $ T74,'*') X WRITE(NUNIT,1) X IF(ITNUM.EQ.1) THEN X WRITE(NUNIT,9) X9 FORMAT(T3,'*',7X,'NOTE: R IS IN STRICT UPPER', X $ ' TRIANGLE OF MATRIX A PLUS RDIAG',T74,'*') X WRITE(NUNIT,1) X WRITE(NUNIT,10) X10 FORMAT(T3,'*',13X,'THE COLUMNS OF THE LOWER', X $ ' TRIANGLE OF MATRIX A PLUS',T74,'*') X WRITE(NUNIT,11) X11 FORMAT(T3,'*',13X,'THE ELEMENTS OF VECTOR HHPI', X $ ' FORM THE HOUSEHOLDER',T74,'*') X WRITE(NUNIT,12) X12 FORMAT(T3,'*',13X,'MATRICES WHICH, WHEN', X $ ' MULTIPLIED TOGETHER, FORM Q',T74,'*') X END IF X END IF XC XC FORM THE ACTUAL Q^ MATRIX FROM THE HOUSEHOLDER XC TRANSFORMATIONS STORED IN THE LOWER TRIANGLE OF A XC AND THE FACTORS IN HHPI: STORE IT IN JAC. XC X CALL QFORM(N,A,HHPI,JAC) XC XC COMPLETE THE UPPER TRIANGULAR R MATRIX BY REPLACING THE XC DIAGONAL OF A. THE QR DECOMPOSITION IS NOW AVAILABLE. XC X DO 500 I=1,N X A(I,I)=RDIAG(I) X500 CONTINUE XC X ELSE XC XC USING UPDATED FACTORED FORM OF JACOBIAN - CHECK FOR XC SINGULARITY. XC X QRSING=.FALSE. X DO 600 I=1,N X IF(A(I,I).EQ.ZERO) QRSING=.TRUE. X600 CONTINUE XC X END IF XC XC ESTIMATE CONDITION NUMBER IF JACOBIAN IS NOT SINGULAR. XC X IF(.NOT.BYPASS.AND.(.NOT.QRSING).AND.N.GT.1) THEN X IF(SCLXCH) THEN XC XC SET UP FOR CONDITION NUMBER ESTIMATION - SCALE R WRT X'S. XC X DO 700 J=1,N X IF(SCALEX(J).NE.ONE) THEN X SCALXJ=SCALEX(J) X RDIAG(J)=RDIAG(J)/SCALXJ X DO 800 I=1,J-1 X A(I,J)=A(I,J)/SCALXJ X800 CONTINUE X END IF X700 CONTINUE X END IF XC X CALL CONDNO(OVERCH,OVERFL,MAXEXP,N ,NUNIT ,OUTPUT, X $ CONNUM,A ,WV1 ,WV2 ,WV3 ,RDIAG ) XC XC UNSCALE R IF IT WAS SCALED BEFORE THE CALL TO CONDNO. XC X IF(SCLXCH) THEN X DO 900 J=1,N X IF(SCALEX(J).NE.ONE) THEN X SCALXJ=SCALEX(J) X RDIAG(J)=RDIAG(J)*SCALXJ X DO 1000 I=1,J-1 X A(I,J)=A(I,J)*SCALXJ X1000 CONTINUE X END IF X900 CONTINUE X END IF XC XC IF OVERFLOW DETECTED IN CONDITION NUMBER ESTIMATOR ASSIGN XC QRSING AS TRUE SO THAT THE JACOBIAN WILL BE PERTURBED. XC X IF(OVERFL) QRSING=.TRUE. XC XC NOTE: OVERFL SWITCHED TO FALSE BEFORE FORMATION OF H. XC X ELSE X IF(N.EQ.1) THEN X CONNUM=ONE X ELSE X CONNUM=ZERO X END IF X END IF XC XC MATRIX H=JAC^JAC IS FORMED IN TWO CASES: XC 1) THE (SCALED) JACOBIAN IS SINGULAR XC 2) THE CONDITION NUMBER IS TOO HIGH AND THE XC OPTION TO BYPASS THE PERTURBATION OF THE XC JACOBIAN IS NOT BEING USED XC 3) REQUESTED BY THE USER THROUGH NEWSTM. XC X IF(QRSING.OR.((.NOT.BYPASS).AND.CONNUM.GT. X $ ONE/SQRTEP**1.333).OR.NEWSTM.EQ.77) THEN XC XC FORM H:=(DF*JAC)^(DF*JAC) WHERE DF=DIAG(SCALEF). USE XC PREVIOUSLY COMPUTED QR DECOMPOSITION OF (SCALED) JACOBIAN XC WHERE R IS STORED IN THE UPPER TRIANGLE OF A AND RDIAG. XC X OVERFL=.FALSE. X IF(OVERCH) THEN X CALL ATAOV(OVERFL,MAXEXP,N,NUNIT,OUTPUT,JAC,H,SCALEF) X ELSE X CALL RTRMUL(N,A,H,RDIAG,WV1) X END IF X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X IF(QRSING.AND.(.NOT.OVERFL)) THEN X WRITE(NUNIT,13) X13 FORMAT(T3,'*',7X,'SINGULAR JACOBIAN DETECTED:', X $ ' JACOBIAN PERTURBED',T74,'*') X ELSE X IF(OVERFL) THEN X WRITE(NUNIT,14) X14 FORMAT(T3,'*',7X,'POTENTIAL OVERFLOW DETECTED', X $ ' IN CONDITION NUMBER ESTIMATOR',T74,'*') X WRITE(NUNIT,15) X15 FORMAT(T3,'*',7X,'MATRIX "ASSIGNED" AS ', X $ 'SINGULAR AND JACOBIAN PERTURBED',T74,'*') X ELSE X WRITE(NUNIT,16) CONNUM X16 FORMAT(T3,'*',7X,'CONDITION NUMBER TOO HIGH: ', X $ 1PD12.3,', JACOBIAN PERTURBED',T74,'*') X END IF X END IF X END IF X OVERFL=.FALSE. X IF(NEWSTM.NE.77) THEN XC XC FIND 1-NORM OF H MATRIX AND PERTURB DIAGONAL. XC X CALL ONENRM(ABORT ,PERTRB,N ,NUNIT ,OUTPUT,EPSMCH, X $ H1NORM,H ,SCALEX) X END IF XC XC CHOLESKY DECOMPOSITION OF H MATRIX - MAXFFL=0 INDICATES XC THAT H IS KNOWNTO BE POSITIVE DEFINITE. XC X MAXFFL=ZERO X CALL CHOLDE(N,MAXADD,MAXFFL,SQRTEP,H,A) X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,1) X WRITE(NUNIT,17) X17 FORMAT(T3,'*',5X,'CHOLESKY DECOMPOSITION OF H MATRIX', X $ T74,'*') X CALL MATPRT(N,N,N,N,NUNIT,A) X END IF XC XC FIND NEWTON STEP FROM CHOLESKY DECOMPOSITION. IF THE XC DIAGONAL HAS BEEN PERTURBED THEN THIS IS NOT THE ACTUAL XC NEWTON STEP BUT ONLY AN APPROXIMATION THEREOF. XC X DO 1100 I=1,N X WV1(I)=-DELF(I) X1100 CONTINUE X CALL CHSOLV(OVERCH,OVERFL,MAXEXP,N ,NUNIT , X $ OUTPUT,A ,WV1 ,SN ,WV2) X OVERFL=.FALSE. X IF(OUTPUT.GT.3) THEN X IF(.NOT.SCLXCH) THEN X IF(.NOT.PERTRB) THEN X WRITE(NUNIT,18) X18 FORMAT(T3,'*',5X,'NEWTON STEP FROM CHOLESKY', X $ ' DECOMPOSITION',T74,'*') X ELSE X WRITE(NUNIT,19) X19 FORMAT(T3,'*',5X,'APPROXIMATE NEWTON STEP FROM', X $ ' PERTURBED JACOBIAN',T74,'*') X END IF X WRITE(NUNIT,1) X DO 1200 I=1,N X WRITE(NUNIT,20) I,SN(I) X20 FORMAT(T3,'*',7X,'SN(',I3,') = ',1PD12.3, X $ T74,'*') X1200 CONTINUE X ELSE X WRITE(NUNIT,1) X IF(.NOT.PERTRB) THEN X WRITE(NUNIT,21) X21 FORMAT(T3,'*',5X,'NEWTON STEP FROM CHOLESKY', X $ ' DECOMPOSITION',3X,' IN SCALED UNITS',T74,'*') X ELSE X WRITE(NUNIT,22) X22 FORMAT(T3,'*',5X,'APPROXIMATE NEWTON STEP FROM', X $ ' PERTURBED JACOBIAN',3X,'IN SCALED UNITS',T74,'*') X END IF X WRITE(NUNIT,1) X DO 1300 I=1,N X WRITE(NUNIT,23) I,SN(I),I,SCALEX(I)*SN(I) X23 FORMAT(T3,'*',7X,'SN(',I3,') = ',1PD12.3, X $ 15X,'SN(',I3,') = ',1PD12.3,T74,'*') X1300 CONTINUE X END IF X END IF XC XC SET QRSING TO TRUE SO THAT THE CORRECT MATRIX FACTORIZATION XC IS USED IN THE BACK-CALCULATION OF SBAR FOR DEUFLHARD XC RELAXATION FACTOR INITIALIZATION. XC X QRSING=.TRUE. X ELSE X IF(OUTPUT.GT.3.AND.N.GT.1) THEN X IF(.NOT.BYPASS.AND.CONNUM.LE.ONE/SQRTEP**1.33) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,24) CONNUM X24 FORMAT(T3,'*',7X,'CONDITION NUMBER ACCEPTABLE, ', X $ 1PD9.2,', JACOBIAN NOT PERTURBED',T74,'*') X END IF X IF(BYPASS.AND.CONNUM.GT.ONE/SQRTEP**1.33) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,25) CONNUM X25 FORMAT(T3,'*',7X,'CONDITION NUMBER HIGH, ', X $ 1PD9.2,', JACOBIAN NOT PERTURBED AS',T74,'*') X WRITE(NUNIT,26) X26 FORMAT(T3,'*',7X,'BYPASS IS TRUE',T74,'*') X END IF X END IF X DO 1400 I=1,N X SUM=ZERO X DO 1500 J=1,N X SUM=SUM-JAC(I,J)*SCALEF(J)*FVECC(J) X1500 CONTINUE X SN(I)=SUM X1400 CONTINUE X CALL RSOLV(OVERCH,OVERFL,MAXEXP,N,NUNIT,OUTPUT,A,RDIAG,SN) X OVERFL=.FALSE. X IF(OUTPUT.GT.3) THEN X IF(.NOT.SCLXCH) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,27) X27 FORMAT(T3,'*',7X,'NEWTON STEP FROM QR DECOMPOSITION ' X $ ,T74,'*') X WRITE(NUNIT,1) X DO 1600 I=1,N X WRITE(NUNIT,20) I,SN(I) X1600 CONTINUE X ELSE X WRITE(NUNIT,1) X WRITE(NUNIT,28) X28 FORMAT(T3,'*',7X,'NEWTON STEP FROM QR DECOMPOSITION ' X $ ,7X,'IN SCALED UNITS',T74,'*') X WRITE(NUNIT,1) X DO 1700 I=1,N X WRITE(NUNIT,23) I,SN(I),I,SCALEX(I)*SN(I) X1700 CONTINUE X END IF X END IF XC XC TRANSFORM MATRICES FOR SUBSEQUENT CALCULATIONS IN TRUST XC REGION METHOD. XC X IF(.NOT.LINESR) THEN X DO 1800 I=2,N X DO 1900 J=1,I-1 X A(I,J)=A(J,I) X1900 CONTINUE X1800 CONTINUE X END IF X END IF X RETURN XC XC LAST CARD OF SUBROUTINE NSTPFA. XC X END X END_OF_FILE if test 12581 -ne `wc -c <'nstpfa.f'`; then echo shar: \"'nstpfa.f'\" unpacked with wrong size! fi # end of 'nstpfa.f' fi if test -f 'nstpun.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'nstpun.f'\" else echo shar: Extracting \"'nstpun.f'\" \(12509 characters\) sed "s/^X//" >'nstpun.f' <<'END_OF_FILE' X SUBROUTINE NSTPUN(ABORT ,LINESR,OVERCH,OVERFL,QRSING, X $ SCLFCH,SCLXCH,ITNUM ,MAXEXP,N , X $ NUNIT ,OUTPUT,EPSMCH,A ,DELF , X $ FVECC ,H ,HHPI ,JAC ,RDIAG , X $ SCALEF,SCALEX,SN ,WV1 ,WV2 , X $ WV3 ) XC XC FEB. 23, 1992 XC XC THIS SUBROUTINE FINDS THE NEWTON STEP. XC XC IF THE JACOBIAN IS DETECTED AS SINGULAR OR IF THE ESTIMATED XC CONDITION NUMBER IS TOO HIGH (GREATER THAN EPSMCH**(-2/3)) XC THEN H:=J^J IS FORMED AND THE DIAGONAL IS PERTURBED BY ADDING XC SQRT(N*EPSMCH)*H1NORM*SCALEX(I)**2 TO THE CORRESPONDING XC ELEMENT. A CHOLESKY DECOMPOSITION IS PERFORMED ON THIS XC MODIFIED MATRIX PRODUCING A PSEUDO-NEWTON STEP. XC NOTE: THIS PROCEDURE MAY BE BE BYPASSED FOR ILL-CONDITIONED XC JACOBIANS BY SETTING THE LOGICAL VARIABLE BYPASS TO TRUE XC IN THE DRIVER. XC XC ABORT IF THE 1-NORM OF MATRIX H BECOMES TOO SMALL XC ALTHOUGH BUT NOT AT A SOLUTION XC BYPASS ALLOWS BYPASSING OF THE SPECIAL TREATMENT FOR XC BADLY CONDITIONED JACOBIANS XC QRSING INDICATES SINGULAR JACOBIAN DETECTED XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION JAC(N,N) ,MAXADD ,MAXFFL X INTEGER OUTPUT X DIMENSION A(N,N) ,DELF(N) ,FVECC(N) ,H(N,N) , X $ HHPI(N) ,RDIAG(N) ,SCALEF(N) ,SCALEX(N), X $ SN(N) ,WV1(N) ,WV2(N) ,WV3(N) X LOGICAL ABORT ,BYPASS ,LINESR ,MATSUP , X $ OVERCH ,OVERFL ,PERTRB ,QRSING , X $ SCLFCH ,SCLXCH ,WRNSUP X COMMON/NNES_1/MATSUP X COMMON/NNES_2/WRNSUP X COMMON/NNES_3/BYPASS X COMMON/ILL/NEWSTM X DATA ZERO,ONE /0.0D0,1.0D0/ XC X ABORT=.FALSE. X OVERFL=.FALSE. X PERTRB=.FALSE. X SQRTEP=SQRT(EPSMCH) XC X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X1 FORMAT(T3,'*',T74,'*') X WRITE(NUNIT,1) X WRITE(NUNIT,2) X2 FORMAT(T3,'*',4X,'SOLUTION OF LINEAR SYSTEM FOR', X $ ' NEWTON STEP, SN',T74,'*') X END IF XC XC STORE (POSSIBLY SCALED) JACOBIAN IN MATRIX A. XC X IF(.NOT.SCLFCH) THEN X CALL MATCOP(N,N,N,N,N,N,JAC,A) X ELSE X DO 100 I=1,N X IF(SCALEF(I).NE.ONE) THEN X SCALFI=SCALEF(I) X DO 200 J=1,N X A(I,J)=JAC(I,J)*SCALFI X200 CONTINUE X ELSE X DO 300 J=1,N X A(I,J)=JAC(I,J) X300 CONTINUE X END IF X100 CONTINUE X END IF XC XC SCALED JACOBIAN IS PRINTED ONLY IF AT LEAST ONE SCALING XC FACTOR IS NOT 1.0. XC X IF(OUTPUT.GT.4.AND.SCLFCH) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,1) X WRITE(NUNIT,3) X3 FORMAT(T3,'*',7X,'SCALED JACOBIAN MATRIX',T74,'*') X CALL MATPRT(N,N,N,N,NUNIT,A) X END IF XC XC QR DECOMPOSITION OF (POSSIBLY SCALED) JACOBIAN. XC X CALL QRDCOM(QRSING,N,EPSMCH,A,HHPI,RDIAG) XC XC SAVE MATRIX A FOR BACK SUBSTITUTION TO CHECK DEUFLHARDS'S XC SECOND STEP ACCEPTANCE CRITERION IN LINE SEARCH OR TRUST XC REGION METHOD. XC X CALL MATCOP(N,N,N,N,N,N,A,H) XC X IF(OUTPUT.GT.4.AND.N.GT.1.AND.(.NOT.MATSUP)) THEN X WRITE(NUNIT,1) X IF(.NOT.SCLFCH) THEN X WRITE(NUNIT,4) X4 FORMAT(T3,'*',7X,'QR DECOMPOSITION OF JACOBIAN', X $ ' MATRIX',T74,'*') X ELSE X WRITE(NUNIT,5) X5 FORMAT(T3,'*',7X,'QR DECOMPOSITION OF SCALED JACOBIAN', X $ ' MATRIX',T74,'*') X END IF X CALL MATPRT(N,N,N,N,NUNIT,A) X WRITE(NUNIT,1) X WRITE(NUNIT,6) X6 FORMAT(T3,'*',12X,'DIAGONAL OF R',10X,'PI FACTORS', X $ ' FROM QR DECOMPOSITION',T74,'*') X WRITE(NUNIT,1) X DO 400 I=1,N-1 X WRITE(NUNIT,7) I,RDIAG(I),I,HHPI(I) X7 FORMAT(T3,'*',7X,'RDIAG(',I3,') = ',1PD11.3, X $ 8X,'HHPI(',I3,') = ',1PD12.3,T74,'*') X400 CONTINUE X WRITE(NUNIT,8) N,RDIAG(N) X8 FORMAT(T3,'*',7X,'RDIAG(',I3,') = ',1PD11.3, X $ T74,'*') X WRITE(NUNIT,1) X IF(ITNUM.EQ.1) THEN X WRITE(NUNIT,9) X9 FORMAT(T3,'*',7X,'NOTE: R IS IN STRICT UPPER TRIANGLE', X $ ' OF MATRIX A PLUS RDIAG',T74,'*') X WRITE(NUNIT,1) X WRITE(NUNIT,10) X10 FORMAT(T3,'*',13X,'THE COLUMNS OF THE LOWER TRIANGLE', X $ ' OF MATRIX A PLUS',T74,'*',/T3,'*',13X,'THE ELEMENTS', X $ ' OF VECTOR HHPI FORM THE HOUSEHOLDER',T74,'*') X WRITE(NUNIT,11) X11 FORMAT(T3,'*',13X,'MATRICES WHICH, WHEN MULTIPLIED', X $ ' TOGETHER, FORM Q',T74,'*') X END IF X END IF XC XC ESTIMATE CONDITION NUMBER IF (SCALED) JACOBIAN IS NOT SINGULAR. XC X IF(.NOT.BYPASS.AND.(.NOT.QRSING).AND.N.GT.1) THEN X IF(SCLXCH) THEN XC XC SET UP FOR CONDITION NUMBER ESTIMATOR - SCALE R WRT X'S. XC X DO 500 J=1,N X IF(SCALEX(J).NE.ONE) THEN X SCALXJ=SCALEX(J) X RDIAG(J)=RDIAG(J)/SCALXJ X DO 600 I=1,J-1 X A(I,J)=A(I,J)/SCALXJ X600 CONTINUE X END IF X500 CONTINUE X END IF XC X CALL CONDNO(OVERCH,OVERFL,MAXEXP,N ,NUNIT ,OUTPUT, X $ CONNUM,A ,WV1 ,WV2 ,WV3 ,RDIAG ) XC XC IF OVERFLOW DETECTED IN CONDITION NUMBER ESTIMATOR ASSIGN XC QRSING AS TRUE. XC X IF(OVERFL) QRSING=.TRUE. XC XC NOTE: OVERFL SWITCHED TO FALSE BEFORE FORMATION OF H LATER. XC X ELSE XC XC ASSIGN DUMMY TO CONNUM FOR SINGULAR JACOBIAN UNLESS N=1. XC X IF(N.EQ.1) THEN X CONNUM=ONE X ELSE X CONNUM=ZERO X END IF X END IF XC XC MATRIX H=JAC^JAC IS FORMED IN THREE CASES: XC 1) THE (SCALED) JACOBIAN IS SINGULAR XC 2) THE CONDITION NUMBER IS TOO HIGH AND THE XC OPTION TO BYPASS THE PERTURBATION OF THE XC JACOBIAN IS NOT BEING USED. XC 3) REQUESTED BY USER THROUGH NEWSTM. XC X IF(QRSING.OR.((.NOT.BYPASS).AND.CONNUM.GT. X $ ONE/SQRTEP**1.333).OR.NEWSTM.EQ.77) THEN XC XC FORM H:=(DF*JAC)^(DF*JAC) WHERE DF=DIAG(SCALEF). USE XC PREVIOUSLY COMPUTED QR DECOMPOSITION OF (SCALED) JACOBIAN XC WHERE R IS STORED IN THE UPPER TRIANGLE OF A AND RDIAG. XC X IF(OVERCH) THEN X OVERFL=.FALSE. X CALL ATAOV(OVERFL,MAXEXP,N,NUNIT,OUTPUT,JAC,H,SCALEF) X ELSE X CALL RTRMUL(N,A,H,RDIAG,WV1) X END IF X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X IF(QRSING.AND.(.NOT.OVERFL)) THEN X WRITE(NUNIT,12) X12 FORMAT(T3,'*',7X,'SINGULAR JACOBIAN DETECTED:', X $ ' JACOBIAN PERTURBED',T74,'*') X ELSE XC XC NOTE: IF OVERFL IS TRUE THEN QRSING MUST BE TRUE. XC X IF(OVERFL) THEN X WRITE(NUNIT,13) X13 FORMAT(T3,'*',7X,'POTENTIAL OVERFLOW DETECTED', X $ ' IN CONDITION NUMBER ESTIMATOR',T74,'*') X WRITE(NUNIT,14) X14 FORMAT(T3,'*',7X,'MATRIX "ASSIGNED" AS ', X $ 'SINGULAR AND JACOBIAN PERTURBED',T74,'*') X ELSE X WRITE(NUNIT,15) CONNUM X15 FORMAT(T3,'*',7X,'CONDITION NUMBER TOO HIGH: ', X $ 1PD12.3,', JACOBIAN PERTURBED',T74,'*') X END IF X END IF X END IF X OVERFL=.FALSE. X IF(NEWSTM.NE.77) THEN XC XC FIND 1-NORM OF H MATRIX AND PERTURB DIAGONAL. XC X CALL ONENRM(ABORT ,PERTRB,N ,NUNIT ,OUTPUT,EPSMCH, X $ H1NORM,H ,SCALEX) X IF(ABORT) RETURN X END IF XC XC CHOLESKY DECOMPOSITION OF H MATRIX - MAXFFL=0 IMPLIES XC THAT H IS KNOWN TO BE POSITIVE DEFINITE. XC X MAXFFL=ZERO X CALL CHOLDE(N,MAXADD,MAXFFL,SQRTEP,H,A) X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,1) X WRITE(NUNIT,16) X16 FORMAT(T3,'*',5X,'CHOLESKY DECOMPOSITION OF H MATRIX' X $ ,T74,'*') X CALL MATPRT(N,N,N,N,NUNIT,A) X END IF XC XC FIND NEWTON STEP FROM CHOLESKY DECOMPOSITION. IF THE XC DIAGONAL HAS BEEN PERTURBED THEN THIS IS NOT THE ACTUAL XC NEWTON STEP BUT ONLY AN APPORXIMATION THEREOF. XC X DO 700 I=1,N X WV1(I)=-DELF(I) X700 CONTINUE X CALL CHSOLV(OVERCH,OVERFL,MAXEXP,N ,NUNIT , X $ OUTPUT,A ,WV1 ,SN ,WV2) X OVERFL=.FALSE. X IF(OUTPUT.GT.3) THEN X IF(.NOT.SCLXCH) THEN X WRITE(NUNIT,1) X IF(.NOT.PERTRB) THEN X WRITE(NUNIT,17) X17 FORMAT(T3,'*',5X,'NEWTON STEP FROM CHOLESKY', X $ ' DECOMPOSITION',T74,'*') X ELSE X WRITE(NUNIT,18) X18 FORMAT(T3,'*',5X,'APPROXIMATE NEWTON STEP FROM', X $ ' PERTURBED JACOBIAN',T74,'*') X END IF X WRITE(NUNIT,1) X DO 800 I=1,N X WRITE(NUNIT,19) I,SN(I) X19 FORMAT(T3,'*',7X,'SN(',I3,') = ',1PD12.3, X $ T74,'*') X800 CONTINUE X ELSE X WRITE(NUNIT,1) X IF(.NOT.PERTRB) THEN X WRITE(NUNIT,20) X20 FORMAT(T3,'*',5X,'NEWTON STEP FROM CHOLESKY', X $ ' DECOMPOSITION',3X,' IN SCALED UNITS',T74,'*') X ELSE X WRITE(NUNIT,21) X21 FORMAT(T3,'*',5X,'APPROXIMATE NEWTON STEP FROM', X $ ' PERTURBED JACOBIAN',3X,'IN SCALED UNITS',T74, X $ '*') X END IF X WRITE(NUNIT,1) X DO 900 I=1,N X WRITE(NUNIT,22) I,SN(I),I,SCALEX(I)*SN(I) X22 FORMAT(T3,'*',7X,'SN(',I3,') = ',1PD12.3, X $ 15X,'SN(',I3,') = ',1PD12.3,T74,'*') X900 CONTINUE X END IF X END IF XC XC SET QRSING TO TRUE SO THAT THE CORRECT MATRIX XC FACTORIZATION IS USED IN THE BACK-CALCULATION OF XC SBAR FOR DEUFLHARD RELAXATION FACTOR INITIALIZATION XC IN LINE SEARCH (ONLY MATTERS WHEN JACOBIAN IS ILL- XC CONDITIONED BUT NOT SINGULAR). XC X QRSING=.TRUE. X ELSE X IF(OUTPUT.GT.3.AND.N.GT.1) THEN X IF(.NOT.BYPASS.AND.CONNUM.LE.ONE/SQRTEP**1.33) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,23) CONNUM X23 FORMAT(T3,'*',7X,'CONDITION NUMBER ACCEPTABLE, ', X $ 1PD9.2,', JACOBIAN NOT PERTURBED',T74,'*') X END IF X IF(BYPASS.AND.CONNUM.GT.ONE/SQRTEP**1.33) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,24) CONNUM X24 FORMAT(T3,'*',7X,'CONDITION NUMBER HIGH, ', X $ 1PD9.2,', JACOBIAN NOT PERTURBED AS',T74,'*') X WRITE(NUNIT,25) X25 FORMAT(T3,'*',7X,'BYPASS IS TRUE',T74,'*') X END IF X END IF XC XC NOTE: HERE SN STORES THE R.H.S. - IT IS OVERWRITTEN. XC X DO 1000 I=1,N X SN(I)=-FVECC(I)*SCALEF(I) X1000 CONTINUE X IF(.NOT.BYPASS.AND.SCLXCH) THEN XC XC R WAS SCALED BEFORE THE CONDITION NUMBER ESTIMATOR - XC THIS CONVERTS IT BACK TO THE UNSCALED FORM. XC X DO 1100 J=1,N X IF(SCALEX(J).NE.ONE) THEN X SCALXJ=SCALEX(J) X RDIAG(J)=RDIAG(J)*SCALXJ X DO 1200 I=1,J-1 X A(I,J)=A(I,J)*SCALXJ X1200 CONTINUE X END IF X1100 CONTINUE X END IF XC XC ACCEPTABLE CONDITION NUMBER - USE BACK SUBSTITUTION TO XC FIND NEWTON STEP FROM QR DECOMPOSITION. XC X CALL QRSOLV(OVERCH,OVERFL,MAXEXP,N ,NUNIT , X $ OUTPUT,A ,HHPI ,RDIAG ,SN ) X OVERFL=.FALSE. XC X IF(OUTPUT.GT.3) THEN X IF(.NOT.SCLXCH) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,26) X26 FORMAT(T3,'*',7X,'NEWTON STEP FROM QR DECOMPOSITION ' X $ ,T74,'*') X WRITE(NUNIT,1) X DO 1300 I=1,N X WRITE(NUNIT,19) I,SN(I) X1300 CONTINUE X ELSE X WRITE(NUNIT,1) X WRITE(NUNIT,27) X27 FORMAT(T3,'*',7X,'NEWTON STEP FROM QR DECOMPOSITION ' X $ ,7X,'IN SCALED UNITS',T74,'*') X WRITE(NUNIT,1) X DO 1400 I=1,N X WRITE(NUNIT,22) I,SN(I),I,SCALEX(I)*SN(I) X1400 CONTINUE X END IF X END IF XC XC TRANSFORM MATRICES FOR SUBSEQUENT CALCULATIONS IN TRUST XC REGION METHODS (A IS STORED ABOVE IN H). XC X IF(.NOT.LINESR) THEN X DO 1500 I=1,N X A(I,I)=RDIAG(I) X DO 1600 J=1,I-1 X A(I,J)=A(J,I) X1600 CONTINUE X1500 CONTINUE X END IF X END IF X RETURN XC XC LAST CARD OF SUBROUTINE NSTPUN. XC X END END_OF_FILE if test 12509 -ne `wc -c <'nstpun.f'`; then echo shar: \"'nstpun.f'\" unpacked with wrong size! fi # end of 'nstpun.f' fi if test -f 'olhelp.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'olhelp.f'\" else echo shar: Extracting \"'olhelp.f'\" \(45104 characters\) sed "s/^X//" >'olhelp.f' <<'END_OF_FILE' X SUBROUTINE OLHELP(NUNIT,HELP) XC XC NOV. 4, 1991 XC XC BRIEF DESCRIPTIONS OF INPUT VARIABLES FOR NNES. XC XC INDIVIDUAL VARIABLES CAN BE ACCESSED BY ASSIGNING THAT XC VARIABLE'S NAME TO HELP (LEFT-JUSTIFIED PLEASE). XC XC GROUPS OF VARIABLES CAN BE ACCESSED BY ASSIGNING: XC XC ALLLOG ALL LOGICAL VARIABLES XC ALLINT ALL INTEGER VARIABLES XC ALLREA ALL REAL VARIABLES XC ALLMAT ALL MATRICES (INCLUDING VECTORS) XC XC OR DESCRIPTIONS OF ALL VARIABLES CAN BE ACCESSED BY SETTING XC HELP TO ALL. XC XC ERR STAYS TRUE IF AN INCORRECT INPUT WAS GIVEN BY THE USER. XC X CHARACTER*6 HELP X LOGICAL ERR ,PRALL ,PRALL1 ,PRALL2 ,PRALL3 ,PRALL4 XC XC PRALL BECOMES TRUE IF ALL VARIABLES ARE TO BE PRINTED. XC PRALL1 BECOMES TRUE IF ALL LOGICALS ARE TO BE PRINTED. XC PRALL2 " " " " INTEGERS " " " " . XC PRALL3 " " " " REALS " " " " . XC PRALL4 " " " " MATRICES " " " " . XC X ERR=.TRUE. X PRALL =.FALSE. X PRALL1=.FALSE. X PRALL2=.FALSE. X PRALL3=.FALSE. X PRALL4=.FALSE. X IF(HELP(1:3).EQ.'ALL'.AND.HELP(4:6).NE.'LOG' X $ .AND.HELP(4:6).NE.'INT' X $ .AND.HELP(4:6).NE.'REA' X $ .AND.HELP(4:6).NE.'MAT') PRALL=.TRUE. X IF(HELP.EQ.'ALLLOG') PRALL1=.TRUE. X IF(HELP.EQ.'ALLINT') PRALL2=.TRUE. X IF(HELP.EQ.'ALLREA') PRALL3=.TRUE. X IF(HELP.EQ.'ALLMAT') PRALL4=.TRUE. XC XC LOGICAL VARIABLES. XC X WRITE(NUNIT,1) X1 FORMAT(T3,72('*')) X WRITE(NUNIT,2) X2 FORMAT(T3,'*',T74,'*') X WRITE(NUNIT,3) X3 FORMAT(T3,'*',24X,'ON-LINE HELP FOR NNES',T74,'*') X WRITE(NUNIT,2) X WRITE(NUNIT,1) X WRITE(NUNIT,2) X IF(PRALL.OR.PRALL1) THEN X WRITE(NUNIT,2) X WRITE(NUNIT,5) X5 FORMAT(T3,'***',2X,'LOGICAL VARIABLES ***',T74,'*') X WRITE(NUNIT,2) X WRITE(NUNIT,2) X END IF X IF(PRALL.OR.PRALL1.OR.HELP.EQ.'ABSNEW') THEN X WRITE(NUNIT,6) X6 FORMAT(T3,'**',1X,'ABSNEW **',T74,'*',/T3,'*',T74,'*',/T3, X $ '*',2X,'DESIGNATES WHETHER ABSOLUTE NEWTON''','S METHOD IS', X $ ' TO BE USED.',T74,'*',/T3,'*',T74,'*',/T3,'*',2X, X $ 'DEFAULT VALUE: FALSE',T74,'*',/T3,'*',T74,'*',/T3,'*',2X, X $ 'CROSS-REFERENCE: LINESR, NEWTON',T74,'*') X WRITE(NUNIT,2) X ERR=.FALSE. X IF(HELP.EQ.'ABSNEW') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL1.OR.HELP.EQ.'CAUCHY') THEN X WRITE(NUNIT,7) X7 FORMAT(T3,'**',1X,'CAUCHY **',T74,'*',/T3,'*',T74,'*',/T3, X $ '*',2X,'THE CAUCHY POINT IS THE POINT AT THE MINIMUM OF THE', X $ ' QUADRATIC ',T74,'*',/T3,'*',2X,'MODEL IN THE STEEPEST', X $ ' DESCENT DIRECTION (THE DISTANCE FROM THE',T74,'*',/T3, X $ '*',2X,'CURRENT POINT TO THE CAUCHY POINT IS ALWAYS LESS', X $ ' THAN THE LENGTH',T74,'*',/T3,'*',2X,'OF THE NEWTON STEP).', X $ T74,'*',/T3,'*',T74,'*',/T3,'*',2X,'CAUCHY: TRUE => ', X $ ' INITIAL TRUST',' REGION IS DISTANCE TO CAUCHY POINT',T74, X $ '*',/T3,'*',11X,'FALSE => INITIAL TRUST REGION IS LENGTH', X $ ' OF NEWTON STEP',T74,'*',/T3,'*',T74,'*',/T3,'*',2X, X $ 'DEFAULT VALUE: FALSE (MORE AMBITIOUS; TRUE IS CONSERVATIVE)', X $ T74,'*',/T3,'*',T74,'*',/T3,'*',2X,'NOT USED IN LINE SEARCH', X $ ' METHODS',T74,'*',/T3,'*',T74,'*',/T3,'*',2X, X $ 'CROSS-REFERENCE: LINESR,DELTA',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP.EQ.'CAUCHY') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL1.OR.HELP.EQ.'DEUFLH') THEN X WRITE(NUNIT,8) X8 FORMAT(T3,'**',1X,'DEUFLH **',T74,'*',/T3,'*',T74,'*',/T3, X $ '*',2X,'INITIALIZATION OF THE RELAXATION FACTOR FOR LINE', X $ ' SEARCHES USING',T74,'*',/T3,'*',2X,'A MODIFICATION OF', X $ ' THE DEUFLHARD METHOD. THE INITIAL LAMBDA IN ANY',T74,'*', X $ /T3,'*',2X,'LINE SEARCH IS SET TO 1.0 USUALLY, UNLESS', X $ ' IT IS FOUND INTERNALLY,',T74,'*',/T3,'*',2X,'USING', X $ ' DEUFLHARD''','S METHOD, THAT A SMALL VALUE OF LAMBDA IS', X $ ' MORE',T74,'*',/T3,'*',2X,'LIKELY WHEREUPON LAMBDA IS', X $ ' INITIALIZED TO 0.1.',T74,'*',/T3,'*',T74,'*',/T3,'*',2X, X $ 'DEUFLH: TRUE => DEUFLHARD INITIALIZATION USED',T74,'*', X $ /T3,'*',11X,'FALSE => INITIAL RELAXATION FACTOR IS', X $ ' ALWAYS LAM0',T74,'*',/T3,'*',19X,' (LAM0 IS USUALLY 1.0)', X $ T74,'*',/T3,'*',T74,'*',/T3,'*',2X,'DEFAULT VALUE: TRUE',T74, X $ '*',/T3,'*',T74,'*',/T3,'*',2X,'NOT USED IN TRUST REGION ', X $ 'METHODS',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP.EQ.'DEUFLH') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL1.OR.HELP(1:5).EQ.'GEOMS') THEN X WRITE(NUNIT,9) X9 FORMAT(T3,'**',1X,'GEOMS **',T74,'*',/T3,'*',T74,'*',/T3,'*', X $ 2X,'TWO CHOICES ARE AVAILABLE WHEN REDUCING THE RELAXATION', X $ ' FACTOR IN',T74,'*',/T3,'*',2X,'LINE SEARCHES OR THE TRUST', X $ ' REGION SIZE IN TRUST REGION METHODS',T74,'*',/T3,'*' X $ ,T74,'*',/T3,'*',2X,'GEOMS: TRUE => GEOMETRIC REDUCTION;', X $ ' FACTOR SIGMA FOR L.S.',T74,'*',/T3,'*',48X,'DELFAC FOR ', X $ 'T.R.',T74,'*',/T3,'*',20X,'I.E.,',' LAMBDA(NEW)=0.5*LAMBDA', X $ '(OLD) FOR LINE',T74,'*',/T3,'*',20X,'SEARCHES AND DELTA', X $ '(NEW)=0.5*DELTA(OLD) FOR',T74,'*',/T3,'*',20X,'TRUST REGION', X $ ' METHODS.',T74,'*',/T3,'*',11X,'FALSE => SAFEGUARDED', X $ ' POLYNOMIAL INTERPOLATION',T74,'*',/T3,'*',T74,'*',/T3,'*', X $ 2X,'DEFAULT VALUE: TRUE',T74,'*',/T3,'*',T74,'*',/T3,'*',2X, X $ 'CROSS-REFERENCES: DELFAC, SIGMA',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP(1:5).EQ.'GEOMS') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL1.OR.HELP.EQ.'LINESR') THEN X WRITE(NUNIT,10) X10 FORMAT(T3,'**',1X,'LINESR **',T74,'*',/T3,'*',T74,'*',/T3, X $ '*',2X,'DISTINGUISHES BETWEEN MAJOR SOLUTION METHODS.',T74, X $ '*',/T3,'*',T74,'*',/T3,'*',2X,'LINESR: TRUE => ', X $ 'LINE SEARCH METHOD',T74,'*',/T3,'*',11X,'FALSE => TRUST', X $ ' REGION METHOD',T74,'*',/T3,'*',T74,'*',/T3,'*',2X, X $ 'DEFAULT VALUE: TRUE',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP.EQ.'LINESR') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL1.OR.HELP.EQ.'MATSUP') THEN X WRITE(NUNIT,11) X11 FORMAT(T3,'**',1X,'MATSUP **',T74,'*',/T3,'*',T74,'*',/T3, X $ '*',2X,'SUPPRESSES MATRIX PRINTING IN DETAILED OUTPUT.',T74, X $ '*',/T3,'*',T74,'*',/T3,'*',2X,'DEFAULT VALUE: FALSE',T74, X $ '*',/T3,'*',T74,'*',/T3,'*',2X,'CROSS-REFERENCE: OUTPUT', X $ T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP.EQ.'MATSUP') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL1.OR.HELP.EQ.'OVERCH') THEN X WRITE(NUNIT,12) X12 FORMAT(T3,'**',1X,'OVERCH **',T74,'*',/T3,'*',T74,'*', X $ /T3,'*',2X,'CHECKS FOR POTENTIAL OVERFLOWS AT KEY', X $ ' LOCATIONS; INSERTS',T74,'*',/T3,'*',2X,'(+OR-)10**MAXEXP', X $ ' AS AN APPROXIMATION IF AN OVERFLOW IS IMMINENT.',T74,'*', X $ /T3,'*',T74,'*',/T3,'*',2X,'OVERCH: TRUE => OVERFLOW', X $ ' CHECKING',T74,'*',/T3,'*',11X,'FALSE => NORMAL EXECUTION', X $ T74,'*',/T3,'*',T74,'*',/T3,'*',2X,'DEFAULT VALUE: FALSE ', X $ T74,'*',/T3,'*',T74,'*',/T3,'*',2X,'CROSS-REFERENCE: ', X $ 'MAXEXP',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP.EQ.'OVERCH'.OR.HELP.EQ.'ALLLOG') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL1.OR.HELP.EQ.'WRNSUP') THEN X WRITE(NUNIT,13) X13 FORMAT(T3,'**',1X,'WRNSUP **',T74,'*',/T3,'*',T74,'*',/T3, X $ '*',2X,'SUPPRESSES PRINTING WARNINGS; USED WHEN KNOWN', X $ ' WARNINGS',T74,'*',/T3,'*',2X,'WILL CLUTTER OUTPUT.',T74, X $ '*',/T3,'*',T74,'*',/T3,'*',2X,'DEFAULT VALUE: FALSE',T74, X $ '*',/T3,'*',T74,'*',/T3,'*',2X,'CROSS-REFERENCE: OUTPUT', X $ T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP.EQ.'WRNSUP') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL2) THEN X WRITE(NUNIT,2) X WRITE(NUNIT,14) X14 FORMAT(T3,'***',2X,'INTEGER VARIABLES ***',T74,'*') X WRITE(NUNIT,2) X END IF X IF(PRALL.OR.PRALL2.OR.HELP.EQ.'ACPTCR') THEN X WRITE(NUNIT,2) X WRITE(NUNIT,15) X15 FORMAT(T3,'**',1X,'ACPTCR **',T74,'*',/T3,'*',T74,'*',/T3, X $ '*',2X,'A STEP CAN BE ACCEPTED BY THE STANDARD OBJECTIVE', X $ ' FUNCTION, WHICH',T74,'*',/T3,'*',2X,'IS 1/2 {SUM OF', X $ ' SQUARES OF RESIDUALS}, ALONE OR BY DEUFLHARD''','S ', X $ T74,'*',/T3,'*',2X,'"NATURAL" OBJECTIVE FUNCTION AS WELL.', X $ T74,'*',/T3,'*',T74,'*',/T3,'*',2X,'ACPTCR: 1 => USE ONLY', X $ ' STANDARD OBJECTIVE FUNCTION',T74,'*',/T3,'*',11X, X $ '12 => ACCEPT',' STEP BASED ON EITHER CRITERION',T74,'*', X $ /T3,'*',T74,'*',/T3,'*',2X,'DEFAULT VALUE: 12 ',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP.EQ.'ACPTCR') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL2.OR.HELP.EQ.'ITSCLF') THEN X WRITE(NUNIT,16) X16 FORMAT(T3,'**',1X,'ITSCLF **',T74,'*',/T3,'*',T74,'*',/T3, X $ '*',2X,'ITERATION AT WHICH ADAPTIVE SCALING OF THE', X $ ' FUNCTIONS BEGINS.',T74,'*',/T3,'*',T74,'*',/T3,'*',2X, X $ 'ITSCLF: 0 => NO ADAPTIVE FUNCTION SCALING',T74,'*', X $ /T3,'*',11X,'K => ADAPTIVE FUNCTION SCALING BEGINS AT', X $ ' ITERATION K',T74,'*',/T3,'*',T74,'*',/T3,'*', X $ 2X,'DEFAULT VALUE: 0',T74,'*',/T3,'*',T74,'*',/T3,'*',2X, X $ 'CROSS-REFERENCE: SCALEF',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP.EQ.'ITSCLF') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL2.OR.HELP.EQ.'ITSCLX') THEN X WRITE(NUNIT,17) X17 FORMAT(T3,'**',1X,'ITSCLX **',T74,'*',/T3,'*',T74,'*',/T3, X $ '*',2X,'ITERATION AT WHICH ADAPTIVE SCALING OF THE', X $ ' VARIABLES BEGINS.',T74,'*',/T3,'*',T74,'*',/T3,'*', X $ 2X,'ITSCLX: 0 => NO ADAPTIVE VARIABLE SCALING',T74, X $ '*',/T3,'*',11X,'K => ADAPTIVE VARIABLE SCALING BEGINS', X $ ' AT ITERATION K',T74,'*',/T3,'*',T74,'*',/T3,'*', X $ 2X,'DEFAULT VALUE: 0',T74,'*',/T3,'*',T74,'*',/T3,'*',2X, X $ 'CROSS-REFERENCE: SCALEX',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP.EQ.'ITSCLX') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL2.OR.HELP.EQ.'JACTYP') THEN X WRITE(NUNIT,18) X18 FORMAT(T3,'**',1X,'JACTYP **',T74,'*',/T3,'*',T74,'*', X $ /T3,'*',2X,'JACTYP DETERMINES HOW THE JACOBIAN IS TO BE', X $ ' EVALUATED EXPLICITLY',T74,'*',/T3,'*',2X,'(VERSUS BEING', X $ ' UPDATED VIA A QUASI-NEWTON METHOD). LOWER AND UPPER',T74, X $ '*',/T3,'*',2X,'BOUNDS ARE CHECKED TO PREVENT VIOLATIONS.', X $ T74,'*',/T3,'*',T74,'*',/T3,'*',2X,'JACTYP: 0 => ', X $ 'ANALYTICAL JACOBIAN (DECLARE IN EXTERNAL STATEMENT)', X $ T74,'*',/T3,'*',11X,'1 => FORWARD DIFFERENCES', X $ T74,'*',/T3,'*',11X,'2 => BACKWARD DIFFERENCES', X $ T74,'*',/T3,'*',11X,'3 => CENTRAL DIFFERENCES', X $ T74,'*',/T3,'*',T74,'*',/T3,'*',2X,'DEFAULT VALUE: 1 ', X $ T74,'*',/T3,'*',T74,'*',/T3,'*',2X,'CROSS-REFERENCE: ', X $ 'JUPDM',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP.EQ.'JACTYP') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL2.OR.HELP(1:5).EQ.'JUPDM') THEN X WRITE(NUNIT,19) X19 FORMAT(T3,'**',1X,'JUPDM **',T74,'*',/T3,'*',T74,'*', X $ /T3,'*',2X,'JUPDM DETERMINES WHETHER THE JACOBIAN IS TO BE', X $ ' EVALUATED',T74,'*',/T3,'*',2X,'EXPLICITLY OR TO BE', X $ ' UPDATED VIA A QUASI-NEWTON METHOD.',T74,'*',/T3,'*',2X, X $ T74,'*',/T3,'*',2X,'JUPDM: 0 => JACOBIAN EVALUATED', X $ ' EXPLICITLY (SEE JACTYP FOR',T74,'*',/T3,'*',17X, X $ 'DIFFERENCING OPTIONS)', X $ T74,'*',/T3,'*',11X,'1 => BROYDEN UPDATE', X $ T74,'*',/T3,'*',11X,'2 => LEE AND LEE UPDATE', X $ T74,'*',/T3,'*',T74,'*',/T3,'*',2X,'DEFAULT VALUE: 0 ', X $ T74,'*',/T3,'*',T74,'*',/T3,'*',2X,'CROSS-REFERENCE: ', X $ 'JACTYP',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP(1:5).EQ.'JUPDM') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL2.OR.HELP.EQ.'MAXEXP') THEN X WRITE(NUNIT,20) X20 FORMAT(T3,'**',1X,'MAXEXP **',T74,'*',/T3,'*',T74,'*',/T3, X $ '*',2X,'MAXIMUM EXPONENT ALLOWED, BASE 10, DETERMINED IN', X $ ' SUBROUTINE SETUP',T74,'*',/T3,'*',2X,'BY SUBROUTINE', X $ ' MACHAR, E.G., 38 FOR THE VAX, 308 FOR IBM PC''','S.',T74, X $ '*',/T3,'*',T74,'*',/T3,'*',2X,'DEFAULT VALUE:', X $ ' DETERMINED INTERNALLY',T74,'*',/T3,'*',T74,'*',/T3,'*', X $ 2X,'CROSS-REFERENCE: OVERCH',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP.EQ.'MAXEXP') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL2.OR.HELP(1:5).EQ.'MAXIT') THEN X WRITE(NUNIT,21) X21 FORMAT(T3,'**',1X,'MAXIT **',T74,'*',/T3,'*',T74,'*',/T3,'*', X $ 2X,'MAXIMUM NUMBER OF ITERATIONS ALLOWED',T74,'*',/T3,'*', X $ T74,'*',/T3,'*',2X,'DEFAULT VALUE: 100',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP(1:5).EQ.'MAXIT') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL2.OR.HELP(1:5).EQ.'MAXNS') THEN X WRITE(NUNIT,22) X22 FORMAT(T3,'**',1X,'MAXNS **',T74,'*',/T3,'*',T74,'*',/T3,'*', X $ 2X,'MAXIMUM NUMBER OF LINE SEARCH STEPS OR TRUST REGION', X $ ' REDUCTIONS',T74,'*',/T3,'*',2X,'ALLOWED WHEN THE JACOBIAN', X $ ' HAS BEEN CALCULATED EXPLICITLY, I.E.,',T74,'*',/T3,'*',2X, X $ 'BY FINITE DIFFERENCES OR USING A USER-SUPPLIED JACOBIAN.', X $ ' THIS',T74,'*',/T3,'*',2X,'IS USUALLY GREATER THAN MAXQNS,', X $ ' THE NUMBER OF LINE SEARCH STEPS',T74,'*',/T3,'*',2X, X $ 'OR TRUST REGION REDUCTIONS ALLOWED AFTER THE JACOBIAN', X $ ' HAS BEEN',T74,'*',/T3,'*',2X,'UPDATED USING A QUASI-NEWTON', X $ ' METHOD.',T74,'*',/T3,'*',T74,'*',/T3,'*',2X,'DEFAULT', X $ ' VALUE: 50',T74,'*',/T3,'*',T74,'*',/T3,'*',2X, X $ 'CROSS-REFERENCE: MAXQNS',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP(1:5).EQ.'MAXNS') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL2.OR.HELP.EQ.'MAXQNS') THEN X WRITE(NUNIT,23) X23 FORMAT(T3,'**',1X,'MAXQNS **',T74,'*',/T3,'*',T74,'*',/T3, X $ '*',2X,'MAXIMUM NUMBER OF LINE SEARCH STEPS OR TRUST REGION', X $ ' REDUCTIONS',T74,'*',/T3,'*',2X,'ALLOWED WHEN THE JACOBIAN', X $ ' HAS BEEN UPDATED BY A QUASI-NEWTON',T74,'*',/T3, X $ '*',2X,'METHOD; THIS IS DESIGNED TO PREVENT EXCESSIVE LINE', X $ ' SEARCH STEPS',T74,'*',/T3,'*',2X,'IN A POOR SEARCH', X $ ' DIRECTION.',T74,'*',/T3,'*',T74,'*',/T3,'*',2X, X $ 'DEFAULT VALUE: 10',T74,'*',/T3,'*',T74,'*',/T3,'*',2X, X $ 'CROSS-REFERENCE: MAXNS',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP.EQ.'MAXQNS') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL2.OR.HELP(1:4).EQ.'MGLL') THEN X WRITE(NUNIT,24) X24 FORMAT(T3,'**',1X,'MGLL **',T74,'*',/T3,'*',T74,'*',/T3, X $ '*',2X,'NUMBER OF PREVIOUS MERIT FUNCTION(S) VALUES USED', X $ ' FOR THE',T74,'*',/T3,'*',2X,'NONMONOTONIC STEP', X $ ' ACCEPTANCE CRITERIA; THE SUM OF SQUARES',T74,'*',/T3,'*', X $ 2X,'AND POSSIBLY DEUFLHARD''','S CRITERION IS(ARE)', X $ ' COMPARED TO THE',T74,'*',/T3,'*',2X,'GREATEST OF THE', X $ ' MOST RECENT "MGLL" VALUES STORED IN THE FTRACK',T74, X $ '*',/T3,'*',2X,'AND STRACK VECTORS RESPECTIVELY.',T74,'*', X $ /T3,'*',T74,'*',/T3,'*',2X,'E.G. LINE SEARCHES, THE ', X $ 'ACCEPTANCE CRITERION FOR A FUNCTION, F, IS',T74,'*',/T3, X $ '*',T74,'*',/T3,'*', X $ 3X,'F(NEW) <= FMAX+LAMBDA*ALPHA*DELF^S WHERE',T74,'*', X $ /T3,'*',T74,'*',/T3,'*', X $ 3X,'F IS THE OBJECTIVE FUNCTION',T74,'*',/T3,'*', X $ 3X,'LAMBDA IS THE RELAXATION FACTOR',T74,'*',/T3,'*', X $ 3X,'ALPHA IS THE ARMIJO CONSTANT',T74,'*',/T3,'*', X $ 3X,'DELF IS THE GRADIENT OF F',T74,'*',/T3,'*', X $ 3X,'S IS THE PROPOSED STEP',T74,'*',/T3,'*', X $ 3X,'FMAX IS GIVEN BY',T74,'*',/T3,'*',T74,'*',/T3,'*', X $ 3X,'MAX(F(K-J)), 0 <= J <= M(K) WHERE',T74,'*',/T3,'*', X $ T74,'*',/T3,'*',3X,'M(K) = MIN[M(K-1)+1,MGLL]',T74,'*',/T3, X $ '*',T74,'*',/T3,'*',2X,'DEFAULT VALUE: GIVEN BY USER', X $ ' AS A PARAMETER, 10 IS TYPICAL',T74,'*',/T3,'*',T74,'*', X $ /T3,'*',2X,'CROSS-REFERENCE: NARMIJ,ALPHA',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP(1:4).EQ.'MGLL') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL2.OR.HELP.EQ.'MINQNS') THEN X WRITE(NUNIT,25) X25 FORMAT(T3,'**',1X,'MINQNS **',T74,'*',/T3,'*',T74,'*',/T3, X $ '*',2X,'MINIMUM NUMBER OF QUASI-NEWTON STEPS WHICH MUST', X $ ' BE TAKEN',T74,'*',/T3,'*',2X,'BETWEEN EXPLICIT JACOBIAN', X $ ' EVALUATIONS.',T74,'*',/T3,'*',T74,'*',/T3,'*',2X, X $ 'DEFAULT VALUE: 6',T74,'*',/T3,'*',T74,'*',/T3,'*',2X, X $ 'CROSS-REFERENCE: JACTYP,JUPDM,RATIOF',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP.EQ.'MINQNS') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL2.OR.HELP.EQ.'NARMIJ') THEN X WRITE(NUNIT,26) X26 FORMAT(T3,'**',1X,'NARMIJ **',T74,'*',/T3,'*',T74,'*',/T3, X $ '*',2X,'WHEN THE JACOBIAN IS EVALUATED EXPLICITLY AT', X $ ' EACH ITERATION, IT',T74,'*',/T3,'*',2X,'IS THE NUMBER OF', X $ ' STEPS WHICH MUST SATISFY THE ARMIJO CRITERION AT',T74,'*', X $ /T3,'*',2X,'THE START OF THE PROBLEM, I.E., STRICT DESCENT', X $ ' STEPS AT THE ',T74,'*',/T3,'*',2X,'START. IN QUASI-NEWTON', X $ ' METHODS IT IS THE NUMBER OF STEPS WHICH',T74,'*',/T3,'*', X $ 2X,'MUST SATISFY THE ARMIJO CRITERION AFTER EACH EXPLICIT', X $ ' JACOBIAN',T74,'*',/T3,'*',2X,'EVALUATION. THE ARMIJO', X $ ' CRITERION TESTS WHETHER',T74,'*',/T3,'*',T74,'*',/T3,'*', X $ 3X,'F(NEW) <= F(OLD)+LAMBDA*ALPHA*DELF^S WHERE',T74,'*', X $ /T3,'*',T74,'*',/T3,'*', X $ 3X,'F IS THE OBJECTIVE FUNCTION',T74,'*',/T3,'*', X $ 3X,'LAMBDA IS THE RELAXATION FACTOR',T74,'*',/T3,'*', X $ 3X,'ALPHA IS THE ARMIJO CONSTANT',T74,'*',/T3,'*', X $ 3X,'DELF IS THE GRADIENT OF F',T74,'*',/T3,'*', X $ 3X,'S IS THE PROPOSED STEP',T74,'*',/T3,'*',T74,'*', X $ /T3,'*',2X,'DEFAULT VALUE: 1',T74,'*',/T3,'*',T74,'*', X $ /T3,'*',2X,'CROSS-REFERENCE: MGLL,ALPHA',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP.EQ.'NARMIJ') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL2.OR.HELP.EQ.'NFETOT') THEN X WRITE(NUNIT,27) X27 FORMAT(T3,'**',1X,'NFETOT **',T74,'*',/T3,'*',T74,'*',/T3, X $ '*',2X,'TOTAL NUMBER OF FUNCTION EVALUATIONS INCLUDING', X $ ' THOSE REQUIRED',T74,'*',/T3,'*',2X,'FOR THE FINITE-', X $ 'DIFFERENCE CALCULATION OF JACOBIANS.',T74,'*',/T3,'*', X $ T74,'*',/T3,'*',2X,'DEFAULT VALUE: N/A (OUTPUT)',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP.EQ.'NFETOT') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL2.OR.HELP.EQ.'NINITN') THEN X WRITE(NUNIT,28) X28 FORMAT(T3,'**',1X,'NINITN **',T74,'*',/T3,'*',T74,'*',/T3, X $ '*',2X,'MAY BE USED TO DELAY ONSET OF LINE SEARCHES OR', X $ ' TRUST REGION STEPS.',T74,'*',/T3,'*',2X,'IT IS THE NUMBER', X $ ' OF INITIAL NEWTON STEPS BEFORE LINE SEARCHES OR',T74,'*', X $ /T3,'*',2X,'TRUST REGION STEPS BEGIN.',T74,'*',/T3,'*',T74, X $ '*',/T3,'*',2X,'DEFAULT VALUE: 0',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP.EQ.'NINITN') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL2.OR.HELP.EQ.'NJACCH') THEN X WRITE(NUNIT,29) X29 FORMAT(T3,'**',1X,'NJACCH **',T74,'*',/T3,'*',T74,'*',/T3, X $ '*',2X,'THE NUMBER TIMES AN ANALYTICAL JACOBIAN IS CHECKED', X $ ' USING FINITE',T74,'*',/T3,'*',2X,'DIFFERENCES AT THE', X $ ' START OF THE PROBLEM. THE TOLERANCE USED FOR',T74,'*', X $ /T3,'*',2X,'COMPARISON IS GIVEN BY FDTOLJ.',T74,'*',/T3, X $ '*',T74,'*',/T3,'*',2X,'DEFAULT VALUE: 0',T74,'*',/T3,'*', X $ T74,'*',/T3,'*',2X,'CROSS-REFERENCE: FDTOLJ',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP.EQ.'NJACCH') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL2.OR.HELP(1:5).EQ.'NUNIT') THEN X WRITE(NUNIT,30) X30 FORMAT(T3,'**',1X,'NUNIT **',T74,'*',/T3,'*',T74,'*',/T3, X $ '*',2X,'NUMBER OF THE LOGICAL UNIT FOR OUTPUT.',T74,'*',/T3, X $ '*',T74,'*',/T3,'*',2X,'DEFAULT VALUE: GIVEN BY USER', X $ T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP(1:5).EQ.'NUNIT') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL2.OR.HELP.EQ.'OUTPUT') THEN X WRITE(NUNIT,31) X31 FORMAT(T3,'**',1X,'OUTPUT **',T74,'*',/T3,'*',T74,'*', X $ /T3,'*',2X,'OUTPUT DETERMINES THE DETAIL OF THE OUTPUT.', X $ T74,'*',/T3,'*',T74,'*',/T3,'*',2X, X $ 'OUTPUT: 0 => NO OUTPUT', X $ T74,'*',/T3,'*',11X,'1 => ANSWER ONLY', X $ T74,'*',/T3,'*',11X,'2 => ECHO INPUT PLUS ANSWER', X $ T74,'*',/T3,'*',11X,'3 => SUMMARY OF EACH ITERATION', X $ T74,'*',/T3,'*',11X,'4 => DETAILED DESCRIPTION OF EACH', X $ ' ITERATION', X $ T74,'*',/T3,'*',11X,'5 => VERY DETAILED DESCRIPTION OF', X $ ' EACH ITERATION', X $ T74,'*',/T3,'*',T74,'*',/T3,'*',2X,'DEFAULT VALUE: 2', X $ T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP.EQ.'OUTPUT') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL2.OR.HELP.EQ.'QNUPDM') THEN X WRITE(NUNIT,32) X32 FORMAT(T3,'**',1X,'QNUPDM **',T74,'*',/T3,'*',T74,'*', X $ /T3,'*',2X,'QNUPDM DETERMINES HOW THE QUASI-NEWTON', X $ ' UPDATE IS DONE.',T74,'*',/T3,'*',T74,'*',/T3,'*',2X, X $ 'QNUPDM: 0 => UPDATE UNFACTORED JACOBIAN',T74,'*',/T3, X $ '*',11X, '1 => UPDATE QR DECOMPOSITION OF JACOBIAN',T74, X $ '*',/T3,'*',T74,'*',/T3,'*',2X,'QNUPDM=1 IS FASTER. USE ', X $ 'THIS UNLESS YOU WANT TO SEE THE',T74,'*',/T3,'*',2X, X $ 'JACOBIAN AT EACH ITERATION.',T74,'*',/T3,'*',T74,'*',/T3, X $ '*',2X,'DEFAULT VALUE: 1',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP.EQ.'QNUPDM') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL2.OR.HELP.EQ.'STOPCR') THEN X WRITE(NUNIT,33) X33 FORMAT(T3,'**',1X,'STOPCR **',T74,'*',/T3,'*',T74,'*', X $ /T3,'*',2X,'STOPCR DETERMINES THE STOPPING CRITERIA USED.', X $ T74,'*',/T3,'*',T74,'*',/T3,'*',2X,'STOPCR: 1 => STOP', X $ ' BASED ON STEP SIZE ONLY',T74,'*',/T3,'*',11X, X $ '2 => STOP BASED ON OBJECTIVE FUNCTION VALUE ONLY',T74,'*', X $ /T3,'*',11X,'12 => STOP BASED ON EITHER STEP SIZE OR', X $ ' FUNCTION VALUE',T74,'*',/T3,'*',11X,'3 => STOP BASED', X $ ' ON BOTH BEING SATISFIED',T74,'*',/T3,'*',T74,'*',/T3,'*', X $ 2X,'SEE FTOL, NSTTOL AND STPTOL FOR DETAILS OF THE CRITERIA.' X $ ,' THERE ARE',T74,'*',/T3,'*',2X,'TWO STEP SIZE CRITERIA:', X $ ' THE ONE BASED ON THE FULL NEWTON STEP IS',T74,'*',/T3, X $ '*',2X,'GOVERNED BY NSTTOL, AND THE OTHER BASED ON THE', X $ ' STEP SIZE AFTER',T74,'*',/T3,'*',2X,'THE LINE SEARCH', X $ ' OR TRUST REGION REDUCTION IS GOVERNED BY STPTOL.',T74,'*', X $ /T3,'*',T74,'*',/T3,'*',2X,'DEFAULT VALUE: 12',T74,'*',/T3, X $ '*',T74,'*',/T3,'*',2X,'CROSS-REFERENCE: TRMCOD,FTOL,', X $ 'NSTTOL,STPTOL',T74,'*',/T3,'*',2X,T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP.EQ.'STOPCR') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL2.OR.HELP.EQ.'SUPPRS') THEN X WRITE(NUNIT,34) X34 FORMAT(T3,'**',1X,'SUPPRS **',T74,'*',/T3,'*',T74,'*',/T3, X $ '*',2X,'SUPPRESS DETAILED OUTPUT FOR "SUPPRS" ITERATIONS;', X $ ' USED PRIMARILY',T74,'*',/T3,'*',2X,'TO SEE DETAILED', X $ ' OUTPUT BEFORE A FAILURE IN A LARGE PROBLEM.',T74,'*',/T3, X $ '*',T74,'*',/T3,'*',2X,'DEFAULT VALUE: 0',T74,'*',/T3,'*', X $ T74,'*',/T3,'*',2X,'CROSS-REFERENCE: OUTPUT',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP.EQ.'SUPPRS') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL2.OR.HELP.EQ.'TRMCOD') THEN X WRITE(NUNIT,35) X35 FORMAT(T3,'**',1X,'TRMCOD **',T74,'*',/T3,'*',T74,'*', X $ /T3,'*',2X,'TRMCOD TELLS WHICH STOPPING CRITERIA WERE MET.', X $ T74,'*',/T3,'*',T74,'*',/T3,'*',2X,'TRMCOD: 1 => STOP', X $ ' BASED ON STEP SIZE ONLY',T74,'*',/T3,'*',11X, X $ '2 => STOP BASED ON OBJECTIVE FUNCTION VALUE ONLY',T74,'*', X $ /T3,'*',11X,'12 => STOP BASED ON EITHER STEP SIZE OR', X $ ' FUNCTION VALUE',T74,'*',/T3,'*',11X,'3 => STOP BASED', X $ ' ON BOTH BEING SATISFIED',T74,'*',/T3,'*',T74,'*'/T3,'*', X $ 2X,'SEE FTOL, NSTTOL AND STPTOL FOR DETAILS OF THE CRITERIA.' X $ ,' THERE ARE',T74,'*',/T3,'*',2X,'TWO STEP SIZE CRITERIA:', X $ ' THE ONE BASED ON THE FULL NEWTON STEP IS',T74,'*',/T3, X $ '*',2X,'GOVERNED BY NSTTOL, AND THE OTHER BASED ON THE', X $ ' STEP SIZE AFTER',T74,'*',/T3,'*',2X,'THE LINE SEARCH', X $ ' OR TRUST REGION REDUCTION IS GOVERNED BY STPTOL.',T74,'*', X $ /T3,'*',T74,'*',/T3,'*',2X,'DEFAULT VALUE: N/A (OUTPUT)', X $ T74,'*',/T3,'*',T74,'*',/T3,'*',2X,'CROSS-REFERENCE: ', X $ 'STOPCR,FTOL,NSTTOL,STPTOL',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP.EQ.'TRMCOD') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL2.OR.HELP.EQ.'TRUPDM') THEN X WRITE(NUNIT,36) X36 FORMAT(T3,'**',1X,'TRUPDM **',T74,'*',/T3,'*',T74,'*', X $ /T3,'*',2X,'TRUPDM DETERMINES THE TRUST REGION UPDATING', X $ ' METHOD.',T74,'*',/T3,'*',T74,'*',/T3,'*',2X, X $ 'TRUPDM: 0 => POWELL''','S SCHEME',T74,'*',/T3,'*',11X, X $ '1 => DENNIS AND SCHNABEL''','S SCHEME',T74,'*',/T3,'*', X $ T74,'*',/T3,'*',2X,'DEFAULT VALUE: 0',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP.EQ.'TRUPDM'.OR.HELP.EQ.'ALLINT') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL3) THEN X WRITE(NUNIT,2) X WRITE(NUNIT,37) X37 FORMAT(T3,'***',2X,'REAL VARIABLES ***',T74,'*') X WRITE(NUNIT,2) X WRITE(NUNIT,2) X END IF X IF(PRALL.OR.PRALL3.OR.HELP(1:5).EQ.'ALPHA') THEN X WRITE(NUNIT,38) X38 FORMAT(T3,'**',1X,'ALPHA **',T74,'*',/T3,'*',T74,'*', X $ /T3,'*',2X,'ARMIJO CONSTANT. FOR MONOTONIC LINE SEARCHES,', X $ ' A STEP IS ACCEPTED IF',T74,'*',/T3,'*',T74,'*',/T3,'*',3X, X $ 'F(NEW) <= F(OLD)+LAMBDA*ALPHA*(DIRECTIONAL DERIVATIVE)', X $ ' WHERE',T74,'*',/T3,'*',T74,'*',/T3,'*',2X,'F',6X,'IS THE' X $ ,' OBJECTIVE FUNCTION',T74,'*',/T3,'*',2X,'LAMBDA IS THE', X $ ' RELAXATION FACTOR IN THE LINE SEARCH',T74,'*',/T3, X $ '*',2X,'THE DERIVATIVE IS IN THE LINE SEARCH DIRECTION.' X $ ,T74,'*',/T3,'*',T74,'*',/T3,'*',2X,'SIMILARLY,', X $ ' FOR TRUST REGION METHODS, THE CRITERION IS',T74,'*', X $ /T3,'*',T74,'*',/T3,'*',3X,'F(NEW) <= F(OLD)+ALPHA*', X $ '(DIRECTIONAL DERIVATIVE) WHERE',T74,'*',/T3,'*',T74,'*', X $ /T3,'*',2X,'THE DERIVATIVE IS IN THE TRUST REGION STEP', X $ ' DIRECTION.',T74,'*',/T3,'*',T74,'*',/T3,'*',2X,'THE', X $ ' CRITERION IS DIFFERENT FOR NONMONOTONIC SEARCHES, SEE', X $ ' MGLL.',T74,'*',/T3,'*',T74,'*',/T3,'*',2X,'DEFAULT', X $ ' VALUE: 1.0D-04',T74,'*',/T3,'*',T74,'*',/T3,'*',2X, X $ 'CROSS-REFERENCE: MGLL,NARMIJ',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP(1:5).EQ.'ALPHA') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL3.OR.HELP.EQ.'CONFAC') THEN X WRITE(NUNIT,39) X39 FORMAT(T3,'**',1X,'CONFAC **',T74,'*',/T3,'*',T74,'*', X $ /T3,'*',2X,'CONSTRAINT FACTOR WHICH GIVES THE FRACTION OF', X $ ' THE DISTANCE',T74,'*',/T3,'*',2X,'TO THE FIRST VIOLATED', X $ ' CONSTRAINT AT WHICH A LINE SEARCH WOULD',T74,'*',/T3, X $ '*',2X,'START OR A TRUST REGION LIMIT SET.',T74,'*',/T3,'*', X $ T74,'*',/T3,'*',2X,'DEFAULT VALUE: 0.95D0',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP.EQ.'CONFAC') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL3.OR.HELP(1:5).EQ.'DELTA') THEN X WRITE(NUNIT,40) X40 FORMAT(T3,'**',1X,'DELTA **',T74,'*',/T3,'*',T74,'*', X $ /T3,'*',2X,'DELTA IS THE TRUST REGION RADIUS. IF IT IS', X $ ' NEGATIVE ON',T74,'*',/T3,'*',2X,'INPUT, THE INITIAL', X $ ' TRUST REGION SIZE IS CALCULATED INTERNALLY;',T74,'*',/T3, X $ '*',2X,'SEE CAUCHY. A POSITIVE ENTRY SETS THE INITIAL', X $ ' TRUST REGION.',T74,'*',/T3,'*',T74,'*',/T3,'*',2X, X $ 'DEFAULT VALUE: -1.0D0',T74,'*',/T3,'*',T74,'*',/T3,'*',2X, X $ 'CROSS-REFERENCE: CAUCHY,LINESR',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP(1:5).EQ.'DELTA') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL3.OR.HELP.EQ.'DELFAC') THEN X WRITE(NUNIT,41) X41 FORMAT(T3,'**',1X,'DELFAC **',T74,'*',/T3,'*',T74,'*', X $ /T3,'*',2X,'DELFAC IS THE FACTOR BY WHICH THE TRUST REGION', X $ ' RADIUS IS CHANGED,',T74,'*',/T3,'*',2X,'BOTH WHEN', X $ ' INCREASED AND WHEN DECREASED, IF DELTA IS NOT BEING',T74, X $ '*',/T3,'*',2X,'BEING INCREASED TO THE LENGTH OF THE NEWTON', X $ ' STEP.',T74,'*',/T3,'*',T74,'*',/T3,'*',2X,'DEFAULT VALUE:', X $ ' 2.0D0',T74,'*',/T3,'*',T74,'*',/T3,'*',2X, X $ 'CROSS-REFERENCE: TRUPDM,DELTA',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP.EQ.'DELFAC') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL3.OR.HELP.EQ.'EPSMCH') THEN X WRITE(NUNIT,42) X42 FORMAT(T3,'**',1X,'EPSMCH **',T74,'*',/T3,'*',T74,'*', X $ /T3,'*',2X,'MACHINE PRECISION; AN ESTIMATE OF THE', X $ ' SMALLEST FLOATING POINT',T74,'*',/T3,'*',2X,'NUMBER', X $ ' SUCH THAT 1.0+X > 1.0.',T74,'*',/T3,'*',T74,'*',/T3,'*', X $ 2X,'DEFAULT VALUE: CALCULATED INTERNALLY',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP.EQ.'EPSMCH') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL3.OR.HELP.EQ.'ETAFAC') THEN X WRITE(NUNIT,43) X43 FORMAT(T3,'**',1X,'ETAFAC **',T74,'*',/T3,'*',T74,'*', X $ /T3,'*',2X,'FACTOR USED IN DETERMINING THE SHAPE', X $ ' OF THE DOUBLE DOGLEG STEP',T74,'*',/T3,'*',2X,'IN TRUST', X $ ' REGION METHODS; ETAFAC=1 CORRESPONDS TO SINGLE DOGLEG.', X $ T74,'*',/T3,'*',T74,'*',/T3,'*',2X,'DEFAULT VALUE: 0.2D0', X $ T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP.EQ.'ETAFAC') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL3.OR.HELP.EQ.'FCNNEW') THEN X WRITE(NUNIT,44) X44 FORMAT(T3,'**',1X,'FCNNEW **',T74,'*',/T3,'*',T74,'*', X $ /T3,'*',2X,'ON RETURN, FCNNEW HOLDS THE FINAL VALUE', X $ ' OF THE SUM-OF-SQUARES',T74,'*',/T3,'*',2X,'OBJECTIVE', X $ ' FUNCTION.',T74,'*',/T3,'*',T74,'*',/T3,'*',2X, X $ 'DEFAULT VALUE: N/A (OUTPUT)',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP.EQ.'FCNNEW') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL3.OR.HELP.EQ.'FDTOLJ') THEN X WRITE(NUNIT,45) X45 FORMAT(T3,'**',1X,'FDTOLJ **',T74,'*',/T3,'*',T74,'*', X $ /T3,'*',2X,'TOLERANCE FOR A FINITE-DIFFERENCE CHECK OF', X $ ' AN ANALYTICAL JACOBIAN.',T74,'*',/T3,'*',2X,'IF JACFD(I)', X $ ' IS THE FINITE-DIFFERENCE APPROXIMATION AND JACAN(I)', X $ T74,'*',/T3,'*',2X,'IS THE ANALYTICAL DERIVATIVE, WHEN', X $ T74,'*',/T3,'*',T74,'*',/T3,'*',3X, X $ 'ABS(JACFD(I)-JACAN(I))/MAX(ABS(JACFD(I)),1) >= FDTOLJ', X $ T74,'*',/T3,'*',T74,'*',/T3,'*',2X,'THEN A FAILURE IS', X $ ' DECLARED.',T74,'*',/T3,'*',T74,'*',/T3,'*',2X,'DEFAULT', X $ ' VALUE: 1.0D-06',T74,'*',/T3,'*',T74,'*',/T3,'*',2X, X $ 'CROSS-REFERENCE: NJACCH',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP.EQ.'FDTOLJ') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL3.OR.HELP(1:4).EQ.'FTOL') THEN X WRITE(NUNIT,46) X46 FORMAT(T3,'**',1X,'FTOL **',T74,'*',/T3,'*',T74,'*', X $ /T3,'*',2X,'STOPPING TOLERANCE FOR MAX-NORM OF SCALED', X $ ' FUNCTION VECTOR; IF',T74,'*',/T3,'*',T74,'*',/T3,'*',3X, X $ 'MAX(SCALEF(I)*ABS(FVEC(I))) I=1,...,N < FTOL ,STOP.',T74, X $ '*',/T3,'*',T74,'*',/T3,'*',2X,'DEFAULT VALUE: ', X $ 'EPSMCH**(1/3)',T74,'*',/T3,'*',T74,'*',/T3,'*',2X, X $ 'CROSS-REFERENCE: STOPCR,TRMCOD',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP(1:4).EQ.'FTOL') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL3.OR.HELP(1:4).EQ.'LAM0') THEN X WRITE(NUNIT,47) X47 FORMAT(T3,'**',1X,'LAM0 **',T74,'*',/T3,'*',T74,'*', X $ /T3,'*',2X,'USED TO SET THE INITIAL RELAXATION FACTOR', X $ ' IN LINE SEARCHES',T74,'*',/T3,'*',2X,'TO A VALUE LESS', X $ ' THAN 1.0 FOR EXTREMELY NONLINEAR PROBLEMS',T74,'*',/T3, X $ '*',2X,'THIS OVERRIDES DEUFLHARD INITIALIZATION.',T74,'*', X $ /T3,'*',T74,'*',/T3,'*',2X,'DEFAULT VALUE: 1.0D0',T74,'*' X $ ,/T3,'*',T74,'*',/T3,'*',2X,'CROSS-REFERENCE: DEUFLH', X $ T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP(1:4).EQ.'LAM0') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL3.OR.HELP(1:5).EQ.'MSTPF') THEN X WRITE(NUNIT,48) X48 FORMAT(T3,'**',1X,'MSTPF **',T74,'*',/T3,'*',T74,'*', X $ /T3,'*',2X,'FACTOR USED TO SET THE MAXIMUM STEP SIZE', X $ ' ALLOWED. USUALLY THE',T74,'*',/T3,'*',2X,'MAXIMUM STEP', X $ ' SIZE IS SET BY NNES IS MUCH TOO LARGE TO HAVE ANY', X $ T74,'*',/T3,'*',2X,'EFFECT, BUT IN SOME CASES THE USER MAY', X $ ' NEED TO RESTRICT POSSIBLY',T74,'*',/T3,'*',2X,'FATAL', X $ ' STEPS. THE MAXIMUM STEP IS SET BY:',T74,'*',/T3,'*',T74,'*', X $ /T3,'*',2X,'MAXSTP=MSTPF*MAX(NORM1,NORM2) WHERE',T74,'*',/T3, X $ '*',2X,T74,'*',/T3,'*',2X,' NORM1=2-NORM OF SCALED', X $ ' STARTING ESTIMATES',T74,'*',/T3,'*',2X,' NORM2=2-NORM OF', X $ ' COMPONENT SCALING FACTORS',T74,'*',/T3,'*',T74,'*', X $ /T3,'*',2X,'DEFAULT VALUE: 1.0D3',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP(1:5).EQ.'MSTPF') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL3.OR.HELP.EQ.'NSTTOL') THEN X WRITE(NUNIT,49) X49 FORMAT(T3,'**',1X,'NSTTOL **',T74,'*',/T3,'*',T74,'*', X $ /T3,'*',2X,'STOPPING TOLERANCE FOR FULL NEWTON STEP; STOP', X $ ' IF, FOR ALL I,',T74,'*',/T3,'*',T74, X $ '*',/T3,'*',3X,'MAX(ABS[SN(I)]/MAX(ABS[X(I)],1/SCALEX(I))', X $ ' < NSTTOL*(1+NORM(DX(I)))',T74,'*',/T3,'*',T74,'*',/T3,'*', X $ 3X,'SN(I) IS THE I(TH) COMPONENT OF THE NEWTON STEP',T74, X $ '*',/T3,'*',3X,'SCALEX(I) IS THE COMPONENT SCALING FACTOR', X $ T74,'*',/T3,'*',3X,'DX(I) IS SCALEX(I)*X(I)',T74,'*', X $ /T3,'*',T74,'*',/T3,'*',2X,'DEFAULT VALUE: EPSMCH**(2/3)', X $ T74,'*',/T3,'*',T74,'*',/T3,'*',2X,'CROSS-REFERENCE: ', X $ 'STOPCR,TRMCOD,SCALEX',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP.EQ.'NSTTOL') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL3.OR.HELP(1:5).EQ.'OMEGA') THEN X WRITE(NUNIT,50) X50 FORMAT(T3,'**',1X,'OMEGA **',T74,'*',/T3,'*',T74,'*', X $ /T3,'*',2X,'FACTOR IN THE LEE AND LEE QUASI-NEWTON', X $ ' UPDATES.',T74,'*',/T3,'*',T74,'*',/T3,'*',2X, X $ 'DEFAULT VALUE: 1.0D-01',T74,'*',/T3,'*',T74,'*',/T3, X $ '*',2X,'CROSS-REFERENCE: JUPDM',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP(1:5).EQ.'OMEGA') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL3.OR.HELP.EQ.'RATIOF') THEN X WRITE(NUNIT,51) X51 FORMAT(T3,'**',1X,'RATIOF **',T74,'*',/T3,'*',T74,'*', X $ /T3,'*',2X,'FACTOR USED IN QUASI-NEWTON METHODS TO DECIDE', X $ ' WHETHER AN',T74,'*',/T3,'*',2X,'EXPLICIT JACOBIAN UPDATE', X $ ' SHOULD BE DONE. IF',T74,'*',/T3,'*',T74,'*',/T3,'*',3X, X $ 'F(NEW) > RATIOF*F(OLD) THEN: NFAIL=NFAIL+1',T74,'*', X $ /T3,'*',T74,'*',/T3,'*',2X,'ELSE IF',T74,'*',/T3,'*',T74, X $ '*',/T3,'*',3X,'F(NEW) < 0.01*F(OLD) THEN: NFAIL=NFAIL-1', X $ T74,'*',/T3,'*',T74,'*',/T3,'*',2X,'IF NFAIL > MINQNS, NNES', X $ ' RESTARTS AT THE BEST POINT FOUND SO FAR',T74,'*',/T3,'*', X $ 2X,'AS IF THAT POINT WERE A NEW INITIAL ESTIMATE.',T74,'*', X $ /T3,'*',T74,'*',/T3,'*',2X,'DEFAULT VALUE: 7.0D-01',T74,'*', X $ /T3,'*',T74,'*',/T3,'*',2X,'CROSS-REFERENCE: MINQNS',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP.EQ.'RATIOF') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL3.OR.HELP(1:5).EQ.'SIGMA') THEN X WRITE(NUNIT,52) X52 FORMAT(T3,'**',1X,'SIGMA **',T74,'*',/T3,'*',T74,'*', X $ /T3,'*',2X,'FACTOR USED IN GEOMETRIC STEP REDUCTIONS TO', X $ ' DECREASE THE',T74,'*',/T3,'*',2X,'RELAXATION', X $ ' FACTOR IN LINE SEARCHES:' X $ ,T74,'*',/T3,'*',T74,'*',/T3,'*',3X,'LAMBDA(NEW)=', X $ 'SIGMA*LAMBDA(OLD)',T74,'*',/T3,'*',T74, X $ '*',/T3,'*',2X,'DEFAULT VALUE: 5.0D-01',T74,'*',/T3,'*',T74, X $ '*',/T3,'*',2X,'CROSS-REFERENCE: GEOMS',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP(1:5).EQ.'SIGMA') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL3.OR.HELP.EQ.'STPTOL') THEN X WRITE(NUNIT,53) X53 FORMAT(T3,'**',1X,'STPTOL **',T74,'*',/T3,'*',T74,'*', X $ /T3,'*',2X,'STOPPING TOLERANCE FOR STEP AFTER REDUCTION;', X $ ' STOP IF, FOR ALL I,',T74,'*',/T3,'*',T74, X $ '*',/T3,'*',3X,'MAX(ABS[S(I)]/MAX(ABS[X(I)],1/SCALEX(I))', X $ ' < STPTOL',T74,'*',/T3,'*',T74,'*',/T3,'*',3X,'S(I) IS', X $ ' THE I(TH) COMPONENT OF THE REDUCED STEP',T74, X $ '*',/T3,'*',3X,'SCALEX(I) IS THE COMPONENT SCALING FACTOR', X $ T74,'*',/T3,'*',T74,'*',/T3,'*',2X,'DEFAULT VALUE: ', X $ 'EPSMCH**(2/3)',T74,'*',/T3,'*',T74,'*',/T3,'*',2X, X $ 'CROSS-REFERENCE: STOPCR,TRMCOD,SCALEX',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(PRALL3.OR.HELP.EQ.'STPTOL') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL4) THEN X WRITE(NUNIT,2) X WRITE(NUNIT,54) X54 FORMAT(T3,'***',2X,'REAL VECTORS ***',T74,'*') X WRITE(NUNIT,2) X WRITE(NUNIT,2) X END IF X IF(PRALL.OR.PRALL4.OR.HELP.EQ.'BOUNDL') THEN X WRITE(NUNIT,55) X55 FORMAT(T3,'**',1X,'BOUNDL **',T74,'*',/T3,'*',T74,'*', X $ /T3,'*',2X,'LOWER BOUNDS FOR THE COMPONENTS.',T74,'*', X $ /T3,'*',T74,'*',/T3,'*',2X,'DEFAULT VALUE: -10**MAXEXP', X $ T74,'*',/T3,'*',T74,'*',/T3,'*',2X, X $ 'CROSS-REFERENCE: MAXEXP,BOUNDU',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP.EQ.'BOUNDL') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL4.OR.HELP.EQ.'BOUNDU') THEN X WRITE(NUNIT,56) X56 FORMAT(T3,'**',1X,'BOUNDU **',T74,'*',/T3,'*',T74,'*', X $ /T3,'*',2X,'UPPER BOUNDS FOR THE COMPONENTS.',T74,'*', X $ /T3,'*',T74,'*',/T3,'*',2X,'DEFAULT VALUE: 10**MAXEXP', X $ T74,'*',/T3,'*',T74,'*',/T3,'*',2X, X $ 'CROSS-REFERENCE: MAXEXP,BOUNDL',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP.EQ.'BOUNDU') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL4.OR.HELP.EQ.'SCALEF') THEN X WRITE(NUNIT,57) X57 FORMAT(T3,'**',1X,'SCALEF **',T74,'*',/T3,'*',T74,'*', X $ /T3,'*',2X,'SCALING FACTORS FOR THE FUNCTIONS. THESE ARE', X $ ' INVERSELY',T74,'*',/T3,'*',2X,'PROPORTIONAL TO TYPICAL', X $ ' VALUES FOR EACH OF THE FUNCTIONS.',T74,'*',/T3,'*',T74, X $ '*',/T3,'*',2X,'DEFAULT VALUE: 1.0D0',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP.EQ.'SCALEF') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL4.OR.HELP.EQ.'SCALEX') THEN X WRITE(NUNIT,58) X58 FORMAT(T3,'**',1X,'SCALEX **',T74,'*',/T3,'*',T74,'*', X $ /T3,'*',2X,'SCALING FACTORS FOR THE COMPONENTS. THESE ARE', X $ ' INVERSELY',T74,'*',/T3,'*',2X,'PROPORTIONAL TO TYPICAL', X $ ' VALUES FOR EACH OF THE COMPONENTS.',T74,'*',/T3,'*',T74, X $ '*',/T3,'*',2X,'DEFAULT VALUE: 1.0D0',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP.EQ.'SCALEX') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL4.OR.HELP(1:2).EQ.'XC') THEN X WRITE(NUNIT,59) X59 FORMAT(T3,'**',1X,'XC **',T74,'*',/T3,'*',T74,'*',/T3,'*', X $ 2X,'CONTAINS INITIAL ESTIMATE ON ENTRY.',T74,'*',/T3,'*', X $ T74,'*',/T3,'*',2X,'DEFAULT VALUE: GIVEN BY USER',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(HELP(1:2).EQ.'XC') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF X IF(PRALL.OR.PRALL4.OR.HELP(1:5).EQ.'XPLUS') THEN X WRITE(NUNIT,60) X60 FORMAT(T3,'**',1X,'XPLUS **',T74,'*',/T3,'*',T74,'*',/T3,'*', X $ 2X,'LATEST ESTIMATE ON RETURN.',T74,'*',/T3,'*',T74,'*', X $ /T3,'*',2X,'DEFAULT VALUE: N/A (OUTPUT)',T74,'*') X ERR=.FALSE. X WRITE(NUNIT,2) X IF(PRALL.OR.PRALL4.OR.HELP(1:5).EQ.'XPLUS') THEN X WRITE(NUNIT,1) X RETURN X END IF X END IF XC XC CHECK FOR INCORRECT INPUT INTO HELP FACILITY. XC X IF(ERR) THEN X WRITE(NUNIT,2) X WRITE(NUNIT,61) HELP X61 FORMAT(T3,'*',2X,'INCORRECT INPUT TO HELP FACILITY: ',A, X $ T74,'*') X WRITE(NUNIT,2) X WRITE(NUNIT,1) X END IF XC XC LAST CARD OF SUBROUTINE OLHELP. XC X END X END_OF_FILE if test 45104 -ne `wc -c <'olhelp.f'`; then echo shar: \"'olhelp.f'\" unpacked with wrong size! fi # end of 'olhelp.f' fi if test -f 'onenrm.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'onenrm.f'\" else echo shar: Extracting \"'onenrm.f'\" \(2093 characters\) sed "s/^X//" >'onenrm.f' <<'END_OF_FILE' X SUBROUTINE ONENRM(ABORT ,PERTRB,N ,NUNIT ,OUTPUT,EPSMCH, X $ H1NORM,H ,SCALEX) XC XC FEB. 23, 1992 XC XC FIND 1-NORM OF H MATRIX IF PERTURBATION IS DESIRED AND XC PERTURB DIAGONAL. XC X IMPLICIT DOUBLE PRECISION(A-H,O-Z) X INTEGER OUTPUT X DIMENSION H(N,N) ,SCALEX(N) X LOGICAL ABORT ,PERTRB X DATA ZERO /0.0D0/ XC X SQRTEP=SQRT(EPSMCH) X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,1) X1 FORMAT(T3,'*',T74,'*') X WRITE(NUNIT,2) X2 FORMAT(T3,'*',7X,'DIAGONAL OF MATRIX H ', X $ '(=JAC^JAC) BEFORE BEING PERTURBED',T74,'*') X WRITE(NUNIT,1) X DO 100 I=1,N X WRITE(NUNIT,3) I,I,H(I,I) X3 FORMAT(T3,'*',10X,'H(',I3,',',I3,') = ', X $ 1PD12.3,T74,'*') X100 CONTINUE X END IF X H1NORM=ZERO X DO 200 J=1,N X H1NORM=H1NORM+ABS(H(1,J))/SCALEX(J) X200 CONTINUE X H1NORM=H1NORM/SCALEX(1) X DO 300 I=2,N X TEMP=ZERO X DO 400 J=1,I X TEMP=TEMP+ABS(H(J,I))/SCALEX(J) X400 CONTINUE X DO 500 J=I+1,N X TEMP=TEMP+ABS(H(I,J))/SCALEX(J) X500 CONTINUE X H1NORM=MAX(H1NORM,TEMP/SCALEX(I)) X300 CONTINUE X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,4) H1NORM X4 FORMAT(T3,'*',7X,'1-NORM OF MATRIX H: ', X $ 1PD11.3,T74,'*') X END IF X IF(H1NORM.LT.EPSMCH) THEN X IF(OUTPUT.GT.0) THEN X WRITE(NUNIT,5) X5 FORMAT(T3,72('*')) X WRITE(NUNIT,1) X WRITE(NUNIT,6) X6 FORMAT(T3,'*',4X,'PROGRAM FAILS AS 1-NORM OF', X $ ' JACOBIAN IS TOO SMALL',T74,'*') X WRITE(NUNIT,1) X WRITE(NUNIT,5) X END IF X ABORT=.TRUE. X RETURN X ELSE XC XC PERTURB DIAGONAL OF MATRIX H - USE THIS TO FIND "SN". XC X PERTRB=.TRUE. X DO 600 I=1,N X H(I,I)=H(I,I) X $ +SQRT(DBLE(N))*SQRTEP*H1NORM*SCALEX(I)*SCALEX(I) X600 CONTINUE X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,1) X WRITE(NUNIT,7) X7 FORMAT(T3,'*',4X,'PERTURBED H MATRIX',T74,'*') X CALL MATPRT(N,N,N,N,NUNIT,H) X END IF X END IF X RETURN XC XC LAST CARD OF SUBROUTINE ONENRM. XC X END END_OF_FILE if test 2093 -ne `wc -c <'onenrm.f'`; then echo shar: \"'onenrm.f'\" unpacked with wrong size! fi # end of 'onenrm.f' fi if test -f 'qform.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'qform.f'\" else echo shar: Extracting \"'qform.f'\" \(944 characters\) sed "s/^X//" >'qform.f' <<'END_OF_FILE' X SUBROUTINE QFORM(N,A,HHPI,JAC) XC XC FEB. 14, 1991 XC XC FORM Q^ FROM THE HOUSEHOLDER MATRICES STORED IN XC MATRICES A AND HHPI AND STORE IT IN JAC. XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION JAC(N,N) X DIMENSION A(N,N) ,HHPI(N) X DATA ZERO,ONE /0.0D0,1.0D0/ XC X DO 100 J=1,N X DO 200 I=1,N X JAC(I,J)=ZERO X200 CONTINUE X JAC(J,J)=ONE X100 CONTINUE X DO 300 K=1,N-1 X IF(HHPI(K).NE.ZERO) THEN X DO 400 J=1,N X TAU=ZERO X DO 500 I=K,N X TAU=TAU+A(I,K)*JAC(I,J) X500 CONTINUE X TAU=TAU/HHPI(K) X DO 600 I=K,N X JAC(I,J)=JAC(I,J)-TAU*A(I,K) X600 CONTINUE X400 CONTINUE X END IF X300 CONTINUE X RETURN XC XC LAST CARD OF SUBROUTINE QFORM. XC X END END_OF_FILE if test 944 -ne `wc -c <'qform.f'`; then echo shar: \"'qform.f'\" unpacked with wrong size! fi # end of 'qform.f' fi if test -f 'qmin.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'qmin.f'\" else echo shar: Extracting \"'qmin.f'\" \(2587 characters\) sed "s/^X//" >'qmin.f' <<'END_OF_FILE' X SUBROUTINE QMIN(NUNIT,OUTPUT,DELFTS,DELTA,DELTAF,STPLEN) XC XC FEB. 9, 1991 XC XC SET THE NEW TRUST REGION SIZE, DELTA, BASED ON A QUADRATIC XC MINIMIZATION WHERE DELTA IS THE INDEPENDENT VARIABLE. XC XC DELTAF IS THE DIFFERENCE IN THE SUM-OF-SQUARES OBJECTIVE XC FUNCTION VALUE AND DELFTS IS THE DIRECTIONAL DERIVATIVE IN XC THE DIRECTION OF THE CURRENT STEP, S, WHICH HAS STEP LENGTH XC STPLEN. XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X INTEGER OUTPUT X DATA ZERO,POINT1,TWO /0.0D0,0.1D0,2.0D0/ XC X IF(DELTAF-DELFTS.NE.ZERO) THEN XC XC CALCULATE DELTA WHERE MINIMUM WOULD OCCUR - DELTMP. XC THIS IS PROVISIONAL AS IT MUST BE WITHIN CERTAIN XC LIMITS TO BE ACCEPTED. XC X DELTMP=-DELFTS*STPLEN/(TWO*(DELTAF-DELFTS)) X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,1) X1 FORMAT(T3,'*',T74,'*') X WRITE(NUNIT,2) DELTMP X2 FORMAT(T3,'*',7X,'TEMPORARY DELTA FROM QUADRATIC', X $ ' MINIMIZATION: ',1PD12.3,T74,'*') X WRITE(NUNIT,3) DELTA X3 FORMAT(T3,'*',30X,'VERSUS CURRENT DELTA: ',1PD12.3, X $ T74,'*') X END IF XC XC REDUCE DELTA DEPENDING ON THE MAGNITUDE OF DELTMP. XC IT MUST BE WITHIN [.1DELTA,.5DELTA] TO BE ACCEPTED - XC OTHERWISE THE NEAREST ENDPOINT OF THE INTERVAL IS USED. XC X IF(DELTMP.LT.POINT1*DELTA) THEN X DELTA=POINT1*DELTA X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,4) X4 FORMAT(T3,'*',7X,'NEW DELTA SET TO 0.1', X $ ' CURRENT DELTA',T74,'*') X END IF X ELSEIF(DELTMP.GT.DELTA/TWO) THEN X DELTA=DELTA/TWO X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,5) X5 FORMAT(T3,'*',7X,'NEW DELTA SET TO 0.5', X $ ' CURRENT DELTA',T74,'*') X END IF X ELSE X DELTA=DELTMP X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,6) X6 FORMAT(T3,'*',7X,'NEW DELTA SET TO DELTMP',T74,'*') X END IF X END IF X ELSE X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,7) X7 FORMAT(T3,'*',7X,'TO AVOID OVERFLOW NEW DELTA', X $ ' SET TO 0.5 CURRENT DELTA',T74,'*') X END IF X DELTA=DELTA/TWO X END IF X RETURN XC XC LAST CARD OF SUBROUTINE QMIN. XC X END END_OF_FILE if test 2587 -ne `wc -c <'qmin.f'`; then echo shar: \"'qmin.f'\" unpacked with wrong size! fi # end of 'qmin.f' fi if test -f 'qrdcom.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'qrdcom.f'\" else echo shar: Extracting \"'qrdcom.f'\" \(1537 characters\) sed "s/^X//" >'qrdcom.f' <<'END_OF_FILE' X SUBROUTINE QRDCOM(QRSING,N,EPSMCH,A,HHPI,RDIAG) XC XC FEB. 23, 1992 XC XC THIS SUBROUTINE COMPUTES THE QR DECOMPOSITION OF THE XC MATRIX A. THE DECOMPOSITION IS COMPLETED EVEN IF XC A SINGULARITY IS DETECTED (WHEREUPON QRSING IS SET TO XC TRUE). XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DIMENSION A(N,N) ,HHPI(N) ,RDIAG(N) X LOGICAL QRSING X DATA ZERO /0.0D0/ XC X QRSING=.FALSE. XC X DO 100 K=1,N-1 X ETA=ZERO X DO 200 I=K,N X ETA=MAX(ETA,ABS(A(I,K))) X200 CONTINUE X IF(ETA.LT.EPSMCH) THEN X QRSING=.TRUE. X HHPI(K)=ZERO X RDIAG(K)=ZERO X ELSE X DO 300 I=K,N X A(I,K)=A(I,K)/ETA X300 CONTINUE X SIGMA=ZERO X DO 400 I=K,N X SIGMA=SIGMA+A(I,K)*A(I,K) X400 CONTINUE X SIGMA=SIGN(SQRT(SIGMA),A(K,K)) X A(K,K)=A(K,K)+SIGMA X HHPI(K)=SIGMA*A(K,K) X RDIAG(K)=-ETA*SIGMA X DO 500 J=K+1,N X TAU=ZERO X DO 600 I=K,N X TAU=TAU+A(I,K)*A(I,J) X600 CONTINUE X TAU=TAU/HHPI(K) X DO 700 I=K,N X A(I,J)=A(I,J)-TAU*A(I,K) X700 CONTINUE X500 CONTINUE X END IF X100 CONTINUE X RDIAG(N)=A(N,N) X IF(ABS(RDIAG(N)).LT.EPSMCH) QRSING=.TRUE. X RETURN XC XC LAST CARD OF SUBROUTINE QRDCOM. XC X END END_OF_FILE if test 1537 -ne `wc -c <'qrdcom.f'`; then echo shar: \"'qrdcom.f'\" unpacked with wrong size! fi # end of 'qrdcom.f' fi if test -f 'qrsolv.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'qrsolv.f'\" else echo shar: Extracting \"'qrsolv.f'\" \(2559 characters\) sed "s/^X//" >'qrsolv.f' <<'END_OF_FILE' X SUBROUTINE QRSOLV(OVERCH,OVERFL,MAXEXP,N ,NUNIT , X $ OUTPUT,A ,HHPI ,RDIAG ,B ) XC XC FEB. 2, 1991 XC XC THIS SUBROUTINE SOLVES XC XC (QR)X=B XC XC WHERE Q AND R ARE OBTAINED FROM THE QR DECOMPOSITION XC B IS A GIVEN RIGHT HAND SIDE WHICH IS XC OVERWRITTEN XC XC R IS CONTAINED IN THE STRICT UPPER TRIANGLE OF XC MATRIX A AND THE VECTOR RDIAG XC Q IS "CONTAINED" IN THE LOWER TRIANGLE OF MATRIX A XC XC FRSTOV INDICATES FIRST OVERFLOW - USED ONLY TO SET BORDER XC FOR OUTPUT XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X INTEGER OUTPUT X DIMENSION A(N,N) ,HHPI(N) ,B(N) ,RDIAG(N) X LOGICAL FRSTOV ,OVERCH ,OVERFL ,WRNSUP X COMMON/NNES_2/WRNSUP X DATA ZERO,ONE,TEN /0.0D0,1.0D0,10.0D0/ XC X EPS=TEN**(-MAXEXP) X FRSTOV=.TRUE. X OVERFL=.FALSE. XC XC MULTIPLY RIGHT HAND SIDE BY Q^ THEN SOLVE USING R XC STORED IN MATRIX A. XC X DO 100 J=1,N-1 X TAU=ZERO X DO 200 I=J,N X IF(OVERCH) THEN X IF(LOG10(ABS(A(I,J))+EPS)+LOG10(ABS(B(I))+EPS) X $ -LOG10(HHPI(J)+EPS).GT.MAXEXP) THEN X OVERFL=.TRUE. X TAU=SIGN(TEN**MAXEXP,A(I,J))* X $ SIGN(ONE,B(J)) X GO TO 201 X END IF X END IF X TAU=TAU+A(I,J)*B(I)/HHPI(J) X201 CONTINUE X200 CONTINUE X DO 300 I=J,N X IF(OVERCH) THEN X IF(LOG10(ABS(TAU)+EPS)+LOG10(ABS(A(I,J))+EPS) X $ .GT.MAXEXP) THEN X OVERFL=.TRUE. X B(I)=-SIGN(TEN**MAXEXP,TAU) X $ *SIGN(ONE,A(I,J)) X IF(OUTPUT.GT.2.AND.(.NOT.WRNSUP)) THEN X IF(FRSTOV) THEN X WRITE(NUNIT,1) X1 FORMAT(T3,'*',T74,'*') X END IF X WRITE(NUNIT,2) I,B(I) X2 FORMAT(T3,'*',4X,'WARNING: COMPONENT ',I3, X $ ' SET TO ',1PD11.3,' IN QRSOLV BEFORE', X $ ' RSOLV',T74,'*') X END IF X GO TO 301 X END IF X END IF X B(I)=B(I)-TAU*A(I,J) X301 CONTINUE X300 CONTINUE X100 CONTINUE X CALL RSOLV(OVERCH,OVERFL,MAXEXP,N,NUNIT,OUTPUT,A,RDIAG,B) X RETURN XC XC LAST CARD OF SUBROUTINE QRSOLV. XC X END END_OF_FILE if test 2559 -ne `wc -c <'qrsolv.f'`; then echo shar: \"'qrsolv.f'\" unpacked with wrong size! fi # end of 'qrsolv.f' fi if test -f 'qrupda.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'qrupda.f'\" else echo shar: Extracting \"'qrupda.f'\" \(2048 characters\) sed "s/^X//" >'qrupda.f' <<'END_OF_FILE' X SUBROUTINE QRUPDA(OVERFL,MAXEXP,N,EPSMCH,A,JAC,U,V) XC XC FEB. 12, 1991 XC XC UPDATE QR DECOMPOSITION USING A SERIES OF GIVENS ROTATIONS. XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION JAC(N,N) X DIMENSION A(N,N) ,HOLD(2) ,U(N) ,V(N) X LOGICAL OVERFL X DATA ZERO /0.0D0/ XC XC REPLACE SUBDIAGONAL WITH ZEROS SO THAT WHEN R IS MULTIPLIED XC BY GIVENS (JACOBI) ROTATIONS THE SUBDIAGONAL ELEMENTS DO XC NOT AFFECT THE OUTCOME. XC X DO 100 I=2,N X A(I,I-1)=ZERO X100 CONTINUE XC XC FIND LARGEST K FOR WHICH U(K) DOES NOT EQUAL ZERO. XC X K=N X DO 200 L=1,N X IF(U(K).EQ.ZERO) THEN X IF(K.GT.1) THEN X K=K-1 X ELSE X GO TO 201 X END IF X ELSE X GO TO 201 X END IF X200 CONTINUE X201 CONTINUE XC XC MULTIPLY UV^ BY A SERIES OF ROTATIONS SO THAT ALL BUT THE XC TOP ROW IS MADE ZERO (THEORETICALLY THIS IS WHAT HAPPENS XC ALTHOUGH THIS MATRIX ISN'T ACTUALLY FORMED). XC X DO 300 I=K-1,1,-1 X CALL JACROT(OVERFL,I,MAXEXP,N,U(I),U(I+1),EPSMCH,A,JAC) X IF(U(I).EQ.ZERO) THEN XC XC THIS STEP JUST AVOIDS ADDING ZERO. XC X U(I)=ABS(U(I+1)) X ELSE X HOLD(1)=U(I) X HOLD(2)=U(I+1) X LDHOLD=2 X CALL TWONRM(OVERFL,MAXEXP,LDHOLD,EPSMCH,EUCNRM,HOLD) X U(I)=EUCNRM X END IF X300 CONTINUE XC XC ADD THE TOP ROW TO THE TOP ROW OF A - THIS FORMS THE XC UPPER HESSENBERG MATRIX. XC X DO 400 J=1,N X A(1,J)=A(1,J)+U(1)*V(J) X400 CONTINUE XC XC FORM THE UPPER TRIANGULAR R MATRIX BY A SERIES OF ROTATIONS XC TO ZERO OUT THE SUBDIAGONALS. XC X DO 500 I=1,K-1 X CALL JACROT(OVERFL,I ,MAXEXP,N ,A(I,I) ,A(I+1,I), X $ EPSMCH,A ,JAC) X500 CONTINUE X RETURN XC XC LAST CARD OF SUBROUTINE QRUPDA. XC X END END_OF_FILE if test 2048 -ne `wc -c <'qrupda.f'`; then echo shar: \"'qrupda.f'\" unpacked with wrong size! fi # end of 'qrupda.f' fi if test -f 'rcdprt.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'rcdprt.f'\" else echo shar: Extracting \"'rcdprt.f'\" \(3975 characters\) sed "s/^X//" >'rcdprt.f' <<'END_OF_FILE' X SUBROUTINE RCDPRT(NUNIT,RETCOD,DELTA,RELLEN,STPTOL) XC XC FEB. 14, 1991 XC XC DESCRIBE MEANING OF RETURN CODES, RETCOD, FROM TRUST REGION XC UPDATING. XC X DOUBLE PRECISION DELTA ,RELLEN ,STPTOL X INTEGER RETCOD XC X WRITE(NUNIT,1) X1 FORMAT(T3,'*',T74,'*') X WRITE(NUNIT,2) RETCOD X2 FORMAT(T3,'*',7X,'RETCOD, FROM TRUST REGION UPDATING:',I5, X $ T74,'*') X WRITE(NUNIT,1) X IF(RETCOD.EQ.1) THEN X WRITE(NUNIT,3) X3 FORMAT(T3,'*',7X,'PROMISING STEP FOUND; DELTA', X $ ' HAS BEEN INCREASED TO NEWLEN BUT',T74,'*') X WRITE(NUNIT,4) X4 FORMAT(T3,'*',7X,'BECAUSE OF OVERFLOWS IN THE FUNCTION', X $ ' VECTOR(S) IN SUBSEQUENT',T74,'*') X WRITE(NUNIT,5) X5 FORMAT(T3,'*',7X,'STEP(S) THE PROJECTED DELTA IS LESS', X $ ' THAN THAT AT THE ALREADY SUCCESSFUL',T74,'*') X WRITE(NUNIT,6) X6 FORMAT(T3,'*',7X,'STEP - RETURN TO SUCCESSFUL STEP', X $ ' AND ACCEPT AS NEW POINT',T74,'*') X ELSEIF(RETCOD.EQ.2) THEN X WRITE(NUNIT,3) X WRITE(NUNIT,7) X7 FORMAT(T3,'*',7X,'BECAUSE OF OVERFLOWS IN THE OBJECTIVE', X $ ' FUNCTION IN SUBSEQUENT',T74,'*') X WRITE(NUNIT,5) X WRITE(NUNIT,6) X ELSEIF(RETCOD.EQ.3) THEN X WRITE(NUNIT,3) X WRITE(NUNIT,8) X8 FORMAT(T3,'*',7X,'BECAUSE OF SUBSEQUENT FAILURES IN', X $ ' THE STEP ACCEPTANCE TEST(S)',T74,'*') X WRITE(NUNIT,9) X9 FORMAT(T3,'*',7X,'THE PROJECTED DELTA IS LESS', X $ ' THAN THAT AT THE ALREADY',T74,'*') X WRITE(NUNIT,10) X10 FORMAT(T3,'*',7X,'SUCCESSFUL STEP - RETURN TO', X $ ' SUCCESSFUL STEP AND ACCEPT',T74,'*') X ELSEIF(RETCOD.EQ.4) THEN X WRITE(NUNIT,11) X11 FORMAT(T3,'*',7X,'STEP ACCEPTED BY STEP SIZE CRITERION', X $ ' ONLY - DELTA REDUCED',T74,'*') X ELSEIF(RETCOD.EQ.5) THEN X WRITE(NUNIT,12) X12 FORMAT(T3,'*',7X,'STEP ACCEPTED - NEW FUNCTION VALUE' X $ ' GREATER THAN PREVIOUS =>',T74,'*') X WRITE(NUNIT,13) X13 FORMAT(T3,'*',7X,'REDUCE TRUST REGION',T74,'*') X ELSEIF(RETCOD.EQ.6) THEN X WRITE(NUNIT,14) X14 FORMAT(T3,'*',7X,'STEP ACCEPTED - DELTA CHANGED' X $ ' AS DETAILED ABOVE',T74,'*') X ELSEIF(RETCOD.EQ.7) THEN X WRITE(NUNIT,15) X15 FORMAT(T3,'*',7X,'NO PROGRESS MADE: RELATIVE STEP', X $ ' SIZE IS TOO SMALL',T74,'*') X WRITE(NUNIT,16) RELLEN,STPTOL X16 FORMAT(T3,'*',7X,'REL. STEP SIZE, RELLEN = ', X $ 1PD12.3,', STPTOL = ',1PD12.3,T74,'*') X ELSEIF(RETCOD.EQ.8) THEN X WRITE(NUNIT,17) X17 FORMAT(T3,'*',7X,'POINT MODIFIED BY CONSTRAINTS', X $ ' NOT A DESCENT DIRECTION',T74,'*') X WRITE(NUNIT,18) X18 FORMAT(T3,'*',7X,'DELTA REDUCED TO CONFAC*RATIOM*DELTA', X $ T74,'*') X ELSEIF(RETCOD.EQ.9) THEN X WRITE(NUNIT,19) X19 FORMAT(T3,'*',7X,'OVERFLOW DETECTED IN FUNCTION VECTOR', X $ ' - DELTA REDUCED',T74,'*') X ELSEIF(RETCOD.EQ.10) THEN X WRITE(NUNIT,20) X20 FORMAT(T3,'*',7X,'OVERFLOW IN OBJECTIVE FUNCTION', X $ ' - DELTA REDUCED',T74,'*') X ELSEIF(RETCOD.EQ.11) THEN X WRITE(NUNIT,21) X21 FORMAT(T3,'*',7X,'STEP NOT ACCEPTED - REDUCE TRUST', X $ ' REGION SIZE BY MINIMIZATION',T74,'*') X WRITE(NUNIT,22) X22 FORMAT(T3,'*',7X,'OF QUADRATIC MODEL IN STEP', X $ ' DIRECTION',T74,'*') X ELSE X WRITE(NUNIT,23) X23 FORMAT(T3,'*',7X,'PROMISING STEP - INCREASE DELTA TO', X $ ' NEWLEN AND TRY A NEW STEP',T74,'*') X END IF X WRITE(NUNIT,1) X WRITE(NUNIT,24) DELTA X24 FORMAT(T3,'*',7X,'DELTA ON RETURN FROM TRUST REGION', X $ ' UPDATING: ',1PD11.3,T74,'*') X RETURN XC XC LAST CARD OF SUBROUTINE RCDPRT. XC X END END_OF_FILE if test 3975 -ne `wc -c <'rcdprt.f'`; then echo shar: \"'rcdprt.f'\" unpacked with wrong size! fi # end of 'rcdprt.f' fi if test -f 'rsolv.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'rsolv.f'\" else echo shar: Extracting \"'rsolv.f'\" \(3289 characters\) sed "s/^X//" >'rsolv.f' <<'END_OF_FILE' X SUBROUTINE RSOLV(OVERCH,OVERFL,MAXEXP,N ,NUNIT , X $ OUTPUT,A ,RDIAG ,B ) XC XC FEB. 14, 1991 XC XC THIS SUBROUTINE SOLVES, BY BACKWARDS SUBSTITUTION, XC XC RX=B XC XC WHERE R IS TAKEN FROM THE QR DECOMPOSITION AND XC IS STORED IN THE STRICT UPPER TRIANGLE XC OF MATRIX A AND THE VECTOR, RDIAG XC B IS A GIVEN RIGHT HAND SIDE WHICH IS XC OVERWRITTEN XC XC FRSTOV INDICATES FIRST OVERFLOW - USED ONLY TO SET XC BORDERS FOR OUTPUT XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION MAXLOG X INTEGER OUTPUT X DIMENSION A(N,N) ,B(N) ,RDIAG(N) X LOGICAL FRSTOV ,OVERCH ,OVERFL ,WRNSUP X COMMON/NNES_2/WRNSUP X DATA ZERO,ONE,TEN /0.0D0,1.0D0,10.0D0/ XC X FRSTOV=.TRUE. X OVERFL=.FALSE. X EPS=TEN**(-MAXEXP) XC X IF(OVERCH) THEN X IF(LOG10(ABS(B(N))+EPS)-LOG10(ABS(RDIAG(N))+EPS) X $ .GT.MAXEXP) THEN X OVERFL=.TRUE. X B(N)=SIGN(TEN**MAXEXP,B(N))*SIGN(ONE,RDIAG(N)) X IF(OUTPUT.GT.2.AND.(.NOT.WRNSUP)) THEN X FRSTOV=.FALSE. X WRITE(NUNIT,1) X1 FORMAT(T3,'*',T74,'*') X WRITE(NUNIT,2) N,B(N) X2 FORMAT(T3,'*',4X,'WARNING: COMPONENT ',I3, X $ ' SET TO ',1PD12.3,T74,'*') X END IF X GO TO 101 X END IF X END IF X B(N)=B(N)/RDIAG(N) X101 CONTINUE X DO 200 I=N-1,1,-1 X IF(OVERCH) THEN XC XC CHECK TO FIND IF ANY TERMS IN THE EVALUATION WOULD XC OVERFLOW. XC X MAXLOG=LOG10(ABS(B(I))+EPS)-LOG10(ABS(RDIAG(I))+EPS) X JSTAR=0 X DO 300 J=I+1,N X TMPLOG=LOG10(ABS(A(I,J))+EPS)+LOG10(ABS(B(J))+EPS)- X $ LOG10(ABS(RDIAG(I))+EPS) X IF(TMPLOG.GT.MAXLOG) THEN X JSTAR=J X MAXLOG=TMPLOG X END IF X300 CONTINUE XC XC IF AN OVERFLOW WOULD OCCUR ASSIGN A VALUE FOR THE XC TERM WITH CORRECT SIGN. XC X IF(MAXLOG.GT.MAXEXP) THEN X OVERFL=.TRUE. X IF(JSTAR.EQ.0) THEN X B(I)=SIGN(TEN**MAXEXP,B(I))* X $ SIGN(ONE,RDIAG(I)) X ELSE X B(I)=-SIGN(TEN**MAXEXP,A(I,JSTAR))* X $ SIGN(ONE,B(JSTAR))*SIGN(ONE,RDIAG(I)) X END IF X IF(FRSTOV) THEN X FRSTOV=.FALSE. X WRITE(NUNIT,1) X END IF X IF(OUTPUT.GT.2.AND.(.NOT.WRNSUP)) WRITE(NUNIT,2) I,B(I) X GO TO 301 X END IF X END IF XC XC SUM FOR EACH TERM ORDERING OPERATIONS TO MINIMIZE XC POSSIBILITY OF OVERFLOW. XC X SUM=ZERO X DO 400 J=I+1,N X SUM=SUM+(MIN(ABS(A(I,J)),ABS(B(J)))/RDIAG(I)) X $ *(MAX(ABS(A(I,J)),ABS(B(J)))) X $ *SIGN(ONE,A(I,J))*SIGN(ONE,B(J)) X400 CONTINUE X B(I)=B(I)/RDIAG(I)-SUM X301 CONTINUE X200 CONTINUE X RETURN XC XC LAST CARD OF SUBROUTINE RSOLV. XC X END END_OF_FILE if test 3289 -ne `wc -c <'rsolv.f'`; then echo shar: \"'rsolv.f'\" unpacked with wrong size! fi # end of 'rsolv.f' fi if test -f 'rtrmul.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'rtrmul.f'\" else echo shar: Extracting \"'rtrmul.f'\" \(533 characters\) sed "s/^X//" >'rtrmul.f' <<'END_OF_FILE' X SUBROUTINE RTRMUL(N,A,H,RDIAG,WV1) XC XC SEPT. 4, 1991 XC XC FIND R^R FOR QR-DECOMPOSED JACOBIAN. XC XC R IS STORED IN STRICT UPPER TRIANGLE OF A AND RDIAG. XC X IMPLICIT DOUBLE PRECISION(A-H,O-Z) X DIMENSION A(N,N) ,H(N,N) ,RDIAG(N) ,WV1(N) XC XC TEMPORARILY REPLACE DIAGONAL OF R IN A (A IS RESTORED LATER). XC X DO 100 I=1,N X WV1(I)=A(I,I) X A(I,I)=RDIAG(I) X100 CONTINUE X CALL UTUMUL(N,N,N,N,N,N,A,H) X DO 200 I=1,N X A(I,I)=WV1(I) X200 CONTINUE X RETURN XC XC LAST CARD OF SUBROUTINE RTRMUL. XC X END X X END_OF_FILE if test 533 -ne `wc -c <'rtrmul.f'`; then echo shar: \"'rtrmul.f'\" unpacked with wrong size! fi # end of 'rtrmul.f' fi if test -f 'setup.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'setup.f'\" else echo shar: Extracting \"'setup.f'\" \(3510 characters\) sed "s/^X//" >'setup.f' <<'END_OF_FILE' X SUBROUTINE SETUP(ABSNEW ,CAUCHY ,DEUFLH ,GEOMS ,LINESR , X $ NEWTON ,OVERCH ,ACPTCR ,ITSCLF ,ITSCLX , X $ JACTYP ,JUPDM ,MAXEXP ,MAXIT ,MAXNS , X $ MAXQNS ,MINQNS ,N ,NARMIJ ,NIEJEV , X $ NJACCH ,OUTPUT ,QNUPDM ,STOPCR ,SUPPRS , X $ TRUPDM ,ALPHA ,CONFAC ,DELTA ,DELFAC , X $ EPSMCH ,ETAFAC ,FDTOLJ ,FTOL ,LAM0 , X $ MSTPF ,NSTTOL ,OMEGA ,RATIOF ,SIGMA , X $ STPTOL ,BOUNDL ,BOUNDU ,SCALEF ,SCALEX , X $ HELP) XC XC DEC. 7, 1991 XC XC SUBROUTINE SETUP ASSIGNS DEFAULT VALUES TO ALL XC REQUISITE PARAMETERS. XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION LAM0 ,MSTPF ,NSTTOL X INTEGER ACPTCR ,OUTPUT ,QNUPDM ,STOPCR , X $ SUPPRS ,TRUPDM X DIMENSION BOUNDL(N),BOUNDU(N),SCALEF(N),SCALEX(N) X LOGICAL ABSNEW ,BYPASS ,CAUCHY ,DEUFLH , X $ GEOMS ,LINESR ,MATSUP ,NEWTON , X $ OVERCH ,WRNSUP X CHARACTER*6 HELP X COMMON/NNES_1/MATSUP X COMMON/NNES_2/WRNSUP X COMMON/NNES_3/BYPASS X COMMON/NNES_4/NFETOT X COMMON/NNES_5/SMALLB,BIGB,SMALLS,BIGS,BIGR X integer i1mach X double precision d1mach XC XC LOGICAL VALUES. XC X ABSNEW=.FALSE. X BYPASS=.FALSE. X CAUCHY=.FALSE. X DEUFLH=.TRUE. X GEOMS=.TRUE. X LINESR=.TRUE. X MATSUP=.FALSE. X NEWTON=.FALSE. X OVERCH=.FALSE. X WRNSUP=.FALSE. XC XC INTEGER VALUES. XC X ACPTCR=12 X ITSCLF=0 X ITSCLX=0 X JACTYP=1 X JUPDM=0 X MAXIT=250 X MAXNS=50 X MAXQNS=10 X MINQNS=7 X NARMIJ=1 X NFETOT=0 X NIEJEV=1 X NJACCH=1 X OUTPUT=2 X QNUPDM=1 X STOPCR=12 X SUPPRS=0 X TRUPDM=0 XC XC REAL VALUES. XC X ALPHA = 1.0D-04 X CONFAC = 0.95D0 X DELTA =-1.0D0 X DELFAC = 2.0D0 X ETAFAC = 0.2D0 X LAM0 = 1.0D0 X MSTPF = 1.0D3 X OMEGA = 0.1D0 X RATIOF = 0.70D0 X SIGMA = 0.5D0 XC XC CHARACTER VARIABLE. XC X HELP(1:4)='NONE' XC XC NOTE: NOTATIONAL CHANGES IN CALLING PROGRAM FROM MACHAR XC 1) EPSMCH DENOTES MACHINE EPSILON XC 2) MINEBB DENOTES MINIMUM EXPONENT BASE BETA XC 3) MAXEBB DENOTES MAXIMUM EXPONENT BASE BETA XC X* CALL MACHAR(IBETA ,IT ,IRND ,NGRD ,MACHEP, X* $ NEGEP ,IEXP ,MINEBB,MAXEBB,EPSMCH, X* $ EPSNEG,XMIN ,XMAX ) X IT = i1mach(14) X IBETA = i1mach(10) X MINEBB = i1mach(15) X MAXEBB = i1mach(16) X EPSMCH = d1mach(4) X XMAX = d1mach(2) X MAXEXP=INT(DBLE(MAXEBB)*LOG(DBLE(IBETA))/LOG(10.0D0)) XC XC VALUES FOR TWO-NORM CALCULATIONS. XC X SMALLB=DBLE(IBETA)**((MINEBB+1)/2) X BIGB= DBLE(IBETA)**((MAXEBB-IT+1)/2) X SMALLS=DBLE(IBETA)**((MINEBB-1)/2) X BIGS= DBLE(IBETA)**((MAXEBB+IT-1)/2) X BIGR= XMAX XC XC SET STOPPING CRITERIA PARAMETERS. XC X FDTOLJ = 1.0D-06 X FTOL = EPSMCH**0.333 X NSTTOL = FTOL*FTOL X STPTOL = NSTTOL XC XC VECTOR VALUES. XC X TEMP=-10.0D0**MAXEXP X DO 100 I=1,N X BOUNDL(I)=TEMP X BOUNDU(I)=-TEMP X SCALEF(I)=1.0D0 X SCALEX(I)=1.0D0 X100 CONTINUE X RETURN XC XC LAST CARD OF SUBROUTINE SETUP. XC X END X END_OF_FILE if test 3510 -ne `wc -c <'setup.f'`; then echo shar: \"'setup.f'\" unpacked with wrong size! fi # end of 'setup.f' fi if test -f 'setup.f0' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'setup.f0'\" else echo shar: Extracting \"'setup.f0'\" \(3352 characters\) sed "s/^X//" >'setup.f0' <<'END_OF_FILE' X SUBROUTINE SETUP(ABSNEW ,CAUCHY ,DEUFLH ,GEOMS ,LINESR , X $ NEWTON ,OVERCH ,ACPTCR ,ITSCLF ,ITSCLX , X $ JACTYP ,JUPDM ,MAXEXP ,MAXIT ,MAXNS , X $ MAXQNS ,MINQNS ,N ,NARMIJ ,NIEJEV , X $ NJACCH ,OUTPUT ,QNUPDM ,STOPCR ,SUPPRS , X $ TRUPDM ,ALPHA ,CONFAC ,DELTA ,DELFAC , X $ EPSMCH ,ETAFAC ,FDTOLJ ,FTOL ,LAM0 , X $ MSTPF ,NSTTOL ,OMEGA ,RATIOF ,SIGMA , X $ STPTOL ,BOUNDL ,BOUNDU ,SCALEF ,SCALEX , X $ HELP) XC XC DEC. 7, 1991 XC XC SUBROUTINE SETUP ASSIGNS DEFAULT VALUES TO ALL XC REQUISITE PARAMETERS. XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION LAM0 ,MSTPF ,NSTTOL X INTEGER ACPTCR ,OUTPUT ,QNUPDM ,STOPCR , X $ SUPPRS ,TRUPDM X DIMENSION BOUNDL(N),BOUNDU(N),SCALEF(N),SCALEX(N) X LOGICAL ABSNEW ,BYPASS ,CAUCHY ,DEUFLH , X $ GEOMS ,LINESR ,MATSUP ,NEWTON , X $ OVERCH ,WRNSUP X CHARACTER*6 HELP X COMMON/NNES_1/MATSUP X COMMON/NNES_2/WRNSUP X COMMON/NNES_3/BYPASS X COMMON/NNES_4/NFETOT X COMMON/NNES_5/SMALLB,BIGB,SMALLS,BIGS,BIGR XC XC LOGICAL VALUES. XC X ABSNEW=.FALSE. X BYPASS=.FALSE. X CAUCHY=.FALSE. X DEUFLH=.TRUE. X GEOMS=.TRUE. X LINESR=.TRUE. X MATSUP=.FALSE. X NEWTON=.FALSE. X OVERCH=.FALSE. X WRNSUP=.FALSE. XC XC INTEGER VALUES. XC X ACPTCR=12 X ITSCLF=0 X ITSCLX=0 X JACTYP=1 X JUPDM=0 X MAXIT=250 X MAXNS=50 X MAXQNS=10 X MINQNS=7 X NARMIJ=1 X NFETOT=0 X NIEJEV=1 X NJACCH=1 X OUTPUT=2 X QNUPDM=1 X STOPCR=12 X SUPPRS=0 X TRUPDM=0 XC XC REAL VALUES. XC X ALPHA = 1.0D-04 X CONFAC = 0.95D0 X DELTA =-1.0D0 X DELFAC = 2.0D0 X ETAFAC = 0.2D0 X LAM0 = 1.0D0 X MSTPF = 1.0D3 X OMEGA = 0.1D0 X RATIOF = 0.70D0 X SIGMA = 0.5D0 XC XC CHARACTER VARIABLE. XC X HELP(1:4)='NONE' XC XC NOTE: NOTATIONAL CHANGES IN CALLING PROGRAM FROM MACHAR XC 1) EPSMCH DENOTES MACHINE EPSILON XC 2) MINEBB DENOTES MINIMUM EXPONENT BASE BETA XC 3) MAXEBB DENOTES MAXIMUM EXPONENT BASE BETA XC X CALL MACHAR(IBETA ,IT ,IRND ,NGRD ,MACHEP, X $ NEGEP ,IEXP ,MINEBB,MAXEBB,EPSMCH, X $ EPSNEG,XMIN ,XMAX ) X MAXEXP=INT(DBLE(MAXEBB)*LOG(DBLE(IBETA))/LOG(10.0D0)) XC XC VALUES FOR TWO-NORM CALCULATIONS. XC X SMALLB=DBLE(IBETA)**((MINEBB+1)/2) X BIGB= DBLE(IBETA)**((MAXEBB-IT+1)/2) X SMALLS=DBLE(IBETA)**((MINEBB-1)/2) X BIGS= DBLE(IBETA)**((MAXEBB+IT-1)/2) X BIGR= XMAX XC XC SET STOPPING CRITERIA PARAMETERS. XC X FDTOLJ = 1.0D-06 X FTOL = EPSMCH**0.333 X NSTTOL = FTOL*FTOL X STPTOL = NSTTOL XC XC VECTOR VALUES. XC X TEMP=-10.0D0**MAXEXP X DO 100 I=1,N X BOUNDL(I)=TEMP X BOUNDU(I)=-TEMP X SCALEF(I)=1.0D0 X SCALEX(I)=1.0D0 X100 CONTINUE X RETURN XC XC LAST CARD OF SUBROUTINE SETUP. XC X END X END_OF_FILE if test 3352 -ne `wc -c <'setup.f0'`; then echo shar: \"'setup.f0'\" unpacked with wrong size! fi # end of 'setup.f0' fi if test -f 'title.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'title.f'\" else echo shar: Extracting \"'title.f'\" \(16895 characters\) sed "s/^X//" >'title.f' <<'END_OF_FILE' X SUBROUTINE TITLE(CAUCHY,DEUFLH,GEOMS ,LINESR,NEWTON, X $ OVERCH,ACPTCR,CONTYP,ITSCLF,ITSCLX, X $ JACTYP,JUPDM ,MAXIT ,MAXNS ,MAXQNS, X $ MGLL ,MINQNS,N ,NARMIJ,NINITN, X $ NJACCH,NUNIT ,OUTPUT,QNUPDM,STOPCR, X $ TRUPDM,ALPHA ,CONFAC,DELFAC,DELTA , X $ EPSMCH,ETAFAC,FCNOLD,FTOL ,LAM0 , X $ MAXSTP,MSTPF ,NSTTOL,OMEGA ,RATIOF, X $ SIGMA ,STPTOL,BOUNDL,BOUNDU,FVECC , X $ SCALEF,SCALEX,XC ) XC XC APR. 13, 1991 XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION LAM0 ,MAXSTP ,MSTPF ,NSTTOL X INTEGER ACPTCR ,CONTYP ,QNUPDM ,OUTPUT , X $ STOPCR ,TRUPDM X DIMENSION BOUNDL(N),BOUNDU(N),FVECC(N),SCALEF(N), X $ SCALEX(N),XC(N) X LOGICAL CAUCHY ,DEUFLH ,GEOMS ,LINESR , X $ NEWTON ,OVERCH X DATA ZERO,ONE /0.0D0,1.0D0/ XC X IF(OUTPUT.LT.2) RETURN X WRITE(NUNIT,1) X1 FORMAT(////,T3,72('*')) X WRITE(NUNIT,2) X2 FORMAT(T3,72('*')) X WRITE(NUNIT,2) X WRITE(NUNIT,3) X3 FORMAT(T3,'*',T74,'*') X WRITE(NUNIT,4) X4 FORMAT(T3,'*',33X,'NNES',T74,'*') X WRITE(NUNIT,3) X WRITE(NUNIT,5) X5 FORMAT(T3,'*',9X,'NONMONOTONIC NONLINEAR EQUATION SOLVER', X $ ' VERSION 1.05',9X,'*') X WRITE(NUNIT,3) X WRITE(NUNIT,6) X6 FORMAT(T3,'*',21X,'COPYRIGHT 1991, BY R.S. BAIN',T74,'*') X WRITE(NUNIT,3) X WRITE(NUNIT,2) X WRITE(NUNIT,2) X WRITE(NUNIT,2) X WRITE(NUNIT,7) X7 FORMAT(///) X IF(OUTPUT.LT.3) GO TO 101 X WRITE(NUNIT,8) X8 FORMAT('1',T3,72('*')) X WRITE(NUNIT,2) X WRITE(NUNIT,3) X IF(NEWTON) THEN X IF(JUPDM.EQ.0) THEN X WRITE(NUNIT,9) X9 FORMAT(T3,'*',2X,'METHOD: NEWTON (NO LINE SEARCH)', X $ T74,'*') X ELSEIF(JUPDM.EQ.1) THEN X WRITE(NUNIT,10) X10 FORMAT(T3,'*',2X,'METHOD: QUASI-NEWTON (NO LINE SEARCH)', X $ ' USING BROYDEN UPDATE',T74,'*') X ELSEIF(JUPDM.EQ.2) THEN X WRITE(NUNIT,11) X11 FORMAT(T3,'*',2X,'METHOD: QUASI-NEWTON (NO LINE SEARCH)', X $ ' USING LEE AND LEE UPDATE',T74,'*') X END IF X WRITE(NUNIT,3) X IF(OVERCH) THEN X WRITE(NUNIT,12) X12 FORMAT(T3,'*',2X,'OVERLOW CHECKING IN USE',T74,'*') X ELSE X WRITE(NUNIT,13) X13 FORMAT(T3,'*',2X,'OVERFLOW CHECKING NOT IN USE', X $ T74,'*') X END IF X IF(JACTYP.EQ.0) THEN X IF(NJACCH.GT.0) THEN X WRITE(NUNIT,14) NJACCH X14 FORMAT(T3,'*',2X,'ANALYTICAL JACOBIAN USED', X $ ', CHECKED NUMERICALLY, NJACCH: ',I5,T74,'*') X ELSE X WRITE(NUNIT,15) X15 FORMAT(T3,'*',2X,'ANALYTICAL JACOBIAN USED; NOT', X $ ' CHECKED',T74,'*') X END IF X ELSEIF(JACTYP.EQ.1) THEN X WRITE(NUNIT,16) X16 FORMAT(T3,'*',2X,'JACOBIAN ESTIMATED USING FORWARD', X $ ' DIFFERENCES',T74,'*') X ELSEIF(JACTYP.EQ.2) THEN X WRITE(NUNIT,17) X17 FORMAT(T3,'*',2X,'JACOBIAN ESTIMATED USING BACKWARD', X $ ' DIFFERENCES',T74,'*') X ELSE X WRITE(NUNIT,18) X18 FORMAT(T3,'*',2X,'JACOBIAN ESTIMATED USING CENTRAL', X $ ' DIFFERENCES',T74,'*') X END IF X WRITE(NUNIT,3) X WRITE(NUNIT,2) X ELSE X IF(LINESR) THEN X WRITE(NUNIT,3) X IF(DEUFLH) THEN X WRITE(NUNIT,19) X19 FORMAT(T3,'*',2X,'DEUFLHARD RELAXATION FACTOR ', X $ 'INITIALIZATION IN EFFECT',T74,'*') X ELSE X WRITE(NUNIT,20) X20 FORMAT(T3,'*',2X,'DEUFLHARD RELAXATION FACTOR ', X $ 'INITIALIZATION NOT IN EFFECT',T74,'*') X END IF X ELSE X IF(ETAFAC.EQ.ONE) THEN X WRITE(NUNIT,21) X21 FORMAT(T3,'*',2X,'METHOD: TRUST REGION USING', X $ ' SINGLE DOGLEG STEPS',T74,'*') X ELSE X WRITE(NUNIT,22) X22 FORMAT(T3,'*',2X,'METHOD: TRUST REGION USING', X $ ' DOUBLE DOGLEG STEPS',T74,'*') X END IF X WRITE(NUNIT,3) X IF(CAUCHY) THEN X WRITE(NUNIT,23) X23 FORMAT(T3,'*',2X,'INITIAL STEP CONSTRAINED BY', X $ ' SCALED CAUCHY STEP',T74,'*') X ELSE X WRITE(NUNIT,24) X24 FORMAT(T3,'*',2X,'INITIAL STEP CONSTRAINED BY', X $ ' SCALED NEWTON STEP',T74,'*') X END IF X END IF X IF(GEOMS) THEN X WRITE(NUNIT,25) X25 FORMAT(T3,'*',2X,'METHOD: GEOMETRIC SEARCH', X $ T74,'*') X ELSE X WRITE(NUNIT,26) X26 FORMAT(T3,'*',2X,'METHOD: SEARCH BASED ON', X $ ' SUCCESSIVE MINIMIZATIONS',T74,'*') X END IF X IF(OVERCH) THEN X WRITE(NUNIT,12) X ELSE X WRITE(NUNIT,13) X END IF X IF(JUPDM.EQ.0) THEN X WRITE(NUNIT,27) X27 FORMAT(T3,'*',2X,'NO QUASI-NEWTON UPDATE USED',T74,'*') X END IF X IF(JUPDM.EQ.1) THEN X IF(QNUPDM.EQ.0) THEN X WRITE(NUNIT,28) X28 FORMAT(T3,'*',2X,'BROYDEN QUASI-NEWTON UPDATE', X $ ' OF UNFACTORED JACOBIAN',T74,'*') X ELSE X WRITE(NUNIT,29) X29 FORMAT(T3,'*',2X,'BROYDEN QUASI-NEWTON UPDATE', X $ ' OF FACTORED JACOBIAN',T74,'*') X END IF X ELSEIF(JUPDM.EQ.2) THEN X IF(QNUPDM.EQ.0) THEN X WRITE(NUNIT,30) X30 FORMAT(T3,'*',2X,'LEE AND LEE QUASI-NEWTON UPDATE', X $ ' OF UNFACTORED JACOBIAN',T74,'*') X ELSE X WRITE(NUNIT,31) X31 FORMAT(T3,'*',2X,'LEE AND LEE QUASI-NEWTON UPDATE', X $ ' OF FACTORED JACOBIAN',T74,'*') X END IF X END IF X IF(JACTYP.EQ.0) THEN X IF(NJACCH.GT.0) THEN X WRITE(NUNIT,14) X ELSE X WRITE(NUNIT,15) X END IF X ELSEIF(JACTYP.EQ.1) THEN X WRITE(NUNIT,16) X ELSEIF(JACTYP.EQ.2) THEN X WRITE(NUNIT,17) X ELSE X WRITE(NUNIT,18) X END IF X IF(.NOT.LINESR) THEN X WRITE(NUNIT,3) X IF(TRUPDM.EQ.0.AND.JUPDM.GT.0) THEN X WRITE(NUNIT,32) X32 FORMAT(T3,'*',2X,'TRUST REGION UPDATED USING', X $ ' POWELL STRATEGY',T74,'*') X ELSE X WRITE(NUNIT,33) X33 FORMAT(T3,'*',2X,'TRUST REGION UPDATED USING', X $ ' DENNIS AND SCHNABEL STRATEGY',T74,'*') X END IF X END IF X WRITE(NUNIT,3) X WRITE(NUNIT,2) X WRITE(NUNIT,3) X IF(ITSCLF.NE.0) THEN X WRITE(NUNIT,34) ITSCLF X34 FORMAT(T3,'*',2X,'ADAPTIVE FUNCTION SCALING STARTED AT', X $ ' ITERATION: ..........',I6,T74,'*') X WRITE(NUNIT,3) X END IF X IF(ITSCLX.NE.0) THEN X WRITE(NUNIT,35) ITSCLX X35 FORMAT(T3,'*',2X,'ADAPTIVE VARIABLE SCALING STARTED AT', X $ ' ITERATION: ..........',I6,T74,'*') X WRITE(NUNIT,3) X END IF X IF(LINESR) THEN X IF(JUPDM.EQ.0) THEN X WRITE(NUNIT,36) MAXNS X36 FORMAT(T3,'*',2X,'MAXIMUM NUMBER OF STEPS IN LINE', X $ ' SEARCH, MAXNS: ...........',I6,T74,'*') X ELSE X WRITE(NUNIT,37) MAXNS X37 FORMAT(T3,'*',2X,'MAXIMUM NUMBER OF NEWTON LINE', X $ ' SEARCH STEPS, MAXNS: .......',I6,T74,'*') X WRITE(NUNIT,38) MAXQNS X38 FORMAT(T3,'*',2X,'MAXIMUM NUMBER OF QUASI-NEWTON', X $ ' LINE SEARCH STEPS, MAXQNS: ',I6,T74,'*') X END IF X ELSE X IF(JUPDM.EQ.0) THEN X WRITE(NUNIT,39) MAXNS X39 FORMAT(T3,'*',2X,'MAXIMUM NUMBER OF TRUST REGION', X $ ' UPDATES, MAXNS: ','...........',I6,T74,'*') X ELSE X WRITE(NUNIT,40) MAXNS X40 FORMAT(T3,'*',2X,'MAXIMUM NO. OF NEWTON TRUST', X $ ' REGION UPDATES, MAXNS: .......',I6,T74,'*') X WRITE(NUNIT,41) MAXQNS X41 FORMAT(T3,'*',2X,'MAXIMUM NO. OF QUASI-NEWTON', X $ ' TRUST REGION UPDATES, MAXQNS: ',I6,T74,'*') X END IF X END IF X IF(NARMIJ.LT.MAXIT) THEN X WRITE(NUNIT,3) X WRITE(NUNIT,42) MGLL X42 FORMAT(T3,'*',2X,'NUMBER OF OBJECTIVE FUNCTION', X $ ' VALUES COMPARED, MGLL: ','......',I6,T74,'*') X END IF X IF(JUPDM.GT.0) THEN X IF(NARMIJ.EQ.MAXIT) WRITE(NUNIT,3) X WRITE(NUNIT,43) MINQNS X43 FORMAT(T3,'*',2X,'MINIMUM NUMBER OF STEPS BETWEEN', X $ ' JACOBIAN UPDATES, MINQNS: ',I6,T74,'*') X WRITE(NUNIT,44) NINITN X44 FORMAT(T3,'*',2X,'NUMBER OF NON-QUASI-NEWTON', X $ ' STEPS AT START, NINITN: .......',I6,T74,'*') X END IF X WRITE(NUNIT,45) NARMIJ X45 FORMAT(T3,'*',2X,'NUMBER OF ARMIJO STEPS AT START,', X $ ' NARMIJ:',' .................',I6,T74,'*') X END IF X WRITE(NUNIT,3) X IF(STOPCR.EQ.3) THEN X WRITE(NUNIT,46) STOPCR X46 FORMAT(T3,'*',2X,'FUNCTION AND STEP SIZE STOPPING' X $ ' CRITERIA, STOPCR: ........',I6,T74,'*') X ELSEIF(STOPCR.EQ.12) THEN X WRITE(NUNIT,47) STOPCR X47 FORMAT(T3,'*',2X,'FUNCTION OR STEP SIZE STOPPING', X $ ' CRITERIA, STOPCR: .........',I6,T74,'*') X ELSEIF(STOPCR.EQ.1) THEN X WRITE(NUNIT,48) STOPCR X48 FORMAT(T3,'*',2X,'STEP SIZE STOPPING CRITERION,', X $ ' STOPCR: ','....................',I6,T74,'*') X ELSE X WRITE(NUNIT,49) STOPCR X49 FORMAT(T3,'*',2X,'FUNCTION STOPPING CRITERION,', X $ ' STOPCR: ','.....................',I6,T74,'*') X END IF X IF(.NOT.NEWTON) THEN X WRITE(NUNIT,3) X IF(ACPTCR.EQ.12) THEN X WRITE(NUNIT,50) ACPTCR X50 FORMAT(T3,'*',2X,'FUNCTION AND STEP SIZE ACCEPTANCE' X $ ' CRITERIA, ACPTCR: ......',I6,T74,'*') X ELSEIF(ACPTCR.EQ.2) THEN X WRITE(NUNIT,51) ACPTCR X51 FORMAT(T3,'*',2X,'STEP SIZE ACCEPTANCE CRITERION, ', X $ 'ACPTCR: ..................',I6,T74,'*') X ELSE X WRITE(NUNIT,52) ACPTCR X52 FORMAT(T3,'*',2X,'FUNCTION ACCEPTANCE CRITERION, ', X $ 'ACPTCR: ...................',I6,T74,'*') X END IF X IF(CONTYP.NE.0) THEN X WRITE(NUNIT,3) X WRITE(NUNIT,53) CONTYP X53 FORMAT(T3,'*',2X,'CONSTRAINTS IN USE, CONTYP: ', X $ '..............................',I6,T74,'*') X END IF X END IF X WRITE(NUNIT,3) X WRITE(NUNIT,2) X WRITE(NUNIT,3) X WRITE(NUNIT,54) EPSMCH X54 FORMAT(T3,'*',2X,'ESTIMATED MACHINE EPSILON, EPSMCH:', X $ ' ...................',1PD10.3,T74,'*') X WRITE(NUNIT,3) X WRITE(NUNIT,55) MSTPF X55 FORMAT(T3,'*',2X,'FACTOR TO ESTABLISH MAXIMUM STEP SIZE', X $ ', MSTPF: ........',1PD10.3,T74,'*') X WRITE(NUNIT,56) MAXSTP X56 FORMAT(T3,'*',2X,'CALCULATED MAXIMUM STEP SIZE, MAXSTP:', X $ ' ................',1PD10.3,T74,'*') X IF(.NOT.LINESR) THEN X IF(DELTA.LT.ZERO) THEN X WRITE(NUNIT,3) X WRITE(NUNIT,57) X57 FORMAT(T3,'*',2X,'INITIAL TRUST REGION NOT PROVIDED', X $ T74,'*') X ELSE X WRITE(NUNIT,3) X WRITE(NUNIT,58) DELTA X58 FORMAT(T3,'*',2X,'INITIAL TRUST REGION SIZE, DELTA:', X $ ' ....................',1PD10.3,T74,'*') X END IF X IF(ETAFAC.LT.ONE) THEN X WRITE(NUNIT,59) ETAFAC X59 FORMAT(T3,'*',2X,'FACTOR TO SET DIRECTION OF', X $ ' TRUST REGION STEP, ETAFAC: ... ',F6.4,T74,'*') X END IF X WRITE(NUNIT,60) DELFAC X60 FORMAT(T3,'*',2X,'TRUST REGION UPDATING FACTOR, DELFAC: ', X $ '................',1PD10.3,T74,'*') X END IF X IF(.NOT.NEWTON) THEN X WRITE(NUNIT,3) X WRITE(NUNIT,61) ALPHA X61 FORMAT(T3,'*',2X,'FACTOR IN OBJECTIVE FUNCTION', X $ ' COMPARISON, ALPHA: ......',1PD10.3,T74,'*') X IF(LINESR.AND.(.NOT.NEWTON)) THEN X WRITE(NUNIT,3) X WRITE(NUNIT,62) SIGMA X62 FORMAT(T3,'*',2X,'REDUCTION FACTOR FOR RELAXATION' X $ ' FACTOR, SIGMA: .......'1PD10.3,T74,'*') X END IF X IF(JUPDM.NE.0) THEN X WRITE(NUNIT,3) X WRITE(NUNIT,63) RATIOF X63 FORMAT(T3,'*',2X,'REDUCTION REQUIRED IN OBJ. FUNCTION', X $ ' FOR QN STEP, RATIOF: ',F6.4,T74,'*') X END IF X IF(JUPDM.EQ.2) THEN X WRITE(NUNIT,3) X WRITE(NUNIT,64) OMEGA X64 FORMAT(T3,'*',2X,'FACTOR IN LEE AND LEE UPDATE, OMEGA:', X $ ' .....................',F6.4,T74,'*') X END IF X END IF X WRITE(NUNIT,3) X IF(STOPCR.NE.2) THEN X WRITE(NUNIT,65) STPTOL X65 FORMAT(T3,'*',2X,'STOPPING TOLERANCE FOR STEP SIZE,' X $ ' STPTOL: ............',1PD10.3,T74,'*') X WRITE(NUNIT,66) NSTTOL X66 FORMAT(T3,'*',2X,'STOPPING TOLERANCE FOR NEWTON STEP,' X $ ' NSTTOL: ..........',1PD10.3,T74,'*') X END IF X IF(STOPCR.NE.1) THEN X WRITE(NUNIT,67) FTOL X67 FORMAT(T3,'*',2X,'STOPPING TOLERANCE FOR OBJECTIVE' X $ ' FUNCTION, FTOL: .....',1PD10.3,T74,'*') X END IF X IF(LINESR.AND.(.NOT.NEWTON).AND.LAM0.LT.ONE) THEN X WRITE(NUNIT,3) X WRITE(NUNIT,68) LAM0 X68 FORMAT(T3,'*',2X,'INITIAL LAMBDA IN LINE SEARCH,', X $ ' LAM0: .................',1PD10.3,T74,'*') X END IF X IF(CONTYP.GT.0) THEN X WRITE(NUNIT,3) X WRITE(NUNIT,69) CONFAC X69 FORMAT(T3,'*'2X,'FACTOR TO ENSURE STEP WITHIN', X $ ' CONSTRAINTS, CONFAC: ........',F6.4,T74,'*') X END IF X WRITE(NUNIT,3) X WRITE(NUNIT,2) X WRITE(NUNIT,3) X WRITE(NUNIT,70) X70 FORMAT(T3,'*',2X,'SCALING FACTORS',T74,'*') X WRITE(NUNIT,3) X WRITE(NUNIT,71) X71 FORMAT(T3,'*',6X,'COMPONENT VALUES',24X,'FUNCTION VALUES', X $ T74,'*') X WRITE(NUNIT,3) X DO 100 I=1,N X WRITE(NUNIT,72) I,SCALEX(I),I,SCALEF(I) X72 FORMAT(T3,'*',2X,'SCALEX(',I3,') = ',1PD10.3,15X, X $ 'SCALEF(',I3,') = ',1PD10.3,T74,'*') X100 CONTINUE X IF(CONTYP.GT.0) THEN X WRITE(NUNIT,3) X WRITE(NUNIT,2) X WRITE(NUNIT,3) X WRITE(NUNIT,73) X73 FORMAT(T3,'*',2X,'LOWER AND UPPER BOUNDS',T74,'*') X WRITE(NUNIT,3) X WRITE(NUNIT,74) X74 FORMAT(T3,'*',8X,'LOWER BOUNDS',27X,'UPPER BOUNDS', X $ T74,'*') X WRITE(NUNIT,3) X DO 200 I=1,N X WRITE(NUNIT,75) I,BOUNDL(I),I,BOUNDU(I) X75 FORMAT(T3,'*',2X,'BOUNDL(',I3,') = ',1PD10.3,15X, X $ 'BOUNDU(',I3,') = ',1PD10.3,T74,'*') X200 CONTINUE X END IF X WRITE(NUNIT,3) X101 CONTINUE X IF(OUTPUT.EQ.2) WRITE(NUNIT,2) X WRITE(NUNIT,2) X WRITE(NUNIT,3) X WRITE(NUNIT,76) X76 FORMAT(T3,'*',4X,'INITIAL ESTIMATES',16X, X $ 'INITIAL FUNCTION VALUES',T74,'*') X WRITE(NUNIT,3) X DO 300 I=1,N X WRITE(NUNIT,77) I,XC(I),I,FVECC(I) X77 FORMAT(T3,'*',2X,'X(',I3,') = ',1PD12.3,15X, X $ 'F(',I3,') = ',1PD12.3,T74,'*') X300 CONTINUE X WRITE(NUNIT,3) X WRITE(NUNIT,78) FCNOLD X78 FORMAT(T3,'*',2X,'INITIAL OBJECTIVE FUNCTION VALUE = ', X $ 1PD10.3,T74,'*') X WRITE(NUNIT,3) X WRITE(NUNIT,2) X WRITE(NUNIT,2) X IF(OUTPUT.LT.3) RETURN X WRITE(NUNIT,79) X79 FORMAT('1',//,T3,24X,23('*')) X WRITE(NUNIT,80) X80 FORMAT(T3,24X,23('*')) X WRITE(NUNIT,81) X81 FORMAT(T3,24X,'*',21X,'*') X WRITE(NUNIT,82) X82 FORMAT(T3,24X,'* UPDATED ESTIMATES *') X WRITE(NUNIT,81) X WRITE(NUNIT,80) X WRITE(NUNIT,80) X WRITE(NUNIT,83) X83 FORMAT(//) X RETURN XC XC LAST CARD OF SUBROUTINE TITLE. XC X END END_OF_FILE if test 16895 -ne `wc -c <'title.f'`; then echo shar: \"'title.f'\" unpacked with wrong size! fi # end of 'title.f' fi if test -f 'trstup.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'trstup.f'\" else echo shar: Extracting \"'trstup.f'\" \(23872 characters\) sed "s/^X//" >'trstup.f' <<'END_OF_FILE' X SUBROUTINE TRSTUP(GEOMS ,NEWTKN,OVERCH,OVERFL,QRSING, X $ SCLFCH,SCLXCH,ACPCOD,ACPSTR,ACPTCR, X $ CONTYP,ISEJAC,JUPDM ,MAXEXP,MGLL , X $ MNEW ,N ,NARMIJ,NFUNC ,NOTRST, X $ NUNIT ,OUTPUT,QNUPDM,RETCOD,TRUPDM, X $ ALPHA ,CONFAC,DELFAC,DELSTR,DELTA , X $ EPSMCH,FCNMAX,FCNNEW,FCNOLD,FCNPRE, X $ MAXSTP,NEWLEN,NEWMAX,POWTAU,RELLEN, X $ STPTOL,A ,ASTORE,BOUNDL,BOUNDU, X $ DELF ,FPLPRE,FTRACK,FVEC ,FVECC , X $ HHPI ,JAC ,RDIAG ,RHS ,S , X $ SBAR ,SCALEF,SCALEX,STRACK,WV3 , X $ XC ,XPLPRE,XPLUS ,FVECEV) XC XC FEB. 28, 1992 XC XC THIS SUBROUTINE CHECKS FOR ACCEPTANCE OF A TRUST REGION XC STEP GENERATED BY THE DOUBLE DOGLEG METHOD. XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DOUBLE PRECISION JAC(N,N) ,MAXSTP ,NEWLEN ,NEWMAX X INTEGER ACPCOD ,ACPSTR ,ACPTCR ,CONTYP , X $ OUTPUT ,QNUPDM ,RETCOD ,TRUPDM X DIMENSION A(N,N) ,ASTORE(N,N),BOUNDL(N),BOUNDU(N), X $ DELF(N) ,FTRACK(0:MGLL-1) ,FPLPRE(N), X $ FVEC(N) ,FVECC(N) ,HHPI(N) ,RDIAG(N) , X $ RHS(N) ,S(N) ,SBAR(N) ,SCALEF(N), X $ SCALEX(N) ,STRACK(0:MGLL-1) ,WV3(N) , X $ XC(N) ,XPLPRE(N) ,XPLUS(N) X LOGICAL CONVIO ,GEOMS ,NEWTKN ,OVERCH , X $ OVERFL ,QRSING ,SCLFCH ,SCLXCH , X $ WRNSUP X COMMON/NNES_2/WRNSUP X EXTERNAL FVECEV X DATA ZERO,PT5,THREEQ,ONE,ONEPT1,TWO,TEN X $ /0.0D0,0.5D0,0.75D0,1.0D0,1.1D0,2.0D0,10.0D0/ XC XC NOTE: ACCEPTANCE CODE, ACPCOD, IS 0 ON ENTRANCE TO TRSTUP XC X CONVIO=.FALSE. X OVERFL=.FALSE. XC X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X1 FORMAT(T3,'*',T74,'*') X WRITE(NUNIT,1) X IF(.NOT.SCLFCH.AND.(.NOT.SCLXCH)) THEN X WRITE(NUNIT,2) X2 FORMAT(T3,'*',4X,'TRUST REGION UPDATING',T74,'*') X ELSE X WRITE(NUNIT,3) X3 FORMAT(T3,'*',4X,'TRUST REGION UPDATING (ALL X''','S', X $ ' AND F''','S IN UNSCALED UNITS)',T74,'*') X END IF X WRITE(NUNIT,1) X END IF XC XC CHECK TO MAKE SURE "S" IS A DESCENT DIRECTION - FIND XC DIRECTIONAL DERIVATIVE AT CURRENT XC USING S GENERATED XC BY DOGLEG SUBROUTINE. XC X CALL INNERP(OVERCH,OVERFL,MAXEXP,N ,N ,N ,NUNIT , X $ OUTPUT,DELFTS,DELF ,S ) X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,4) DELFTS X4 FORMAT(T3,'*',7X,'INNER PRODUCT OF DELF AND S, DELFTS: ' X $ ,'........',1PD13.4,T74,'*') X END IF X IF(DELFTS.GT.ZERO) THEN X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,5) X5 FORMAT(T3,'*',7X,'DIRECTIONAL DERIVATIVE POSITIVE', X $ '; SEARCH DIRECTION REVERSED',T74,'*') X END IF X DO 100 I=1,N X S(I)=-S(I) X100 CONTINUE X END IF XC XC FIND MAXIMUM OBJECTIVE FUNCTION VALUE AND MAXIMIUM STEP XC LENGTH FOR NONMONOTONIC SEARCH. THIS HAS TO BE DONE ONLY XC ONCE DURING EACH ITERATION (WHERE NOTRST=1). XC X IF(NOTRST.EQ.1) THEN X NEWMAX=NEWLEN X FCNMAX=FCNOLD X IF(ISEJAC.GT.NARMIJ) THEN X IF(ISEJAC.LT.NARMIJ+MGLL) THEN X DO 200 J=1,MNEW X FCNMAX=MAX(FCNMAX,FTRACK(J-1)) X NEWMAX=MAX(NEWMAX,STRACK(J-1)) X200 CONTINUE X ELSE X DO 300 J=0,MNEW X FCNMAX=MAX(FCNMAX,FTRACK(J)) X NEWMAX=MAX(NEWMAX,STRACK(J)) X300 CONTINUE X END IF X END IF X END IF XC XC TEST TRIAL POINT - FIND XPLUS AND TEST FOR CONSTRAINT XC VIOLATIONS IF CONTYP DOES NOT EQUAL 0. XC X DO 400 I=1,N X WV3(I)=-ONE XC XC WV3 IS A MARKER FOR "VIOLATORS" - IT CHANGES TO 1 OR 2. XC X XPLUS(I)=XC(I)+S(I) X IF(CONTYP.GT.0) THEN X IF(XPLUS(I).LT.BOUNDL(I)) THEN X CONVIO=.TRUE. X WV3(I)=ONE X ELSEIF(XPLUS(I).GT.BOUNDU(I)) THEN X CONVIO=.TRUE. X WV3(I)=TWO X END IF X END IF X400 CONTINUE XC XC IF CONSTRAINT IS VIOLATED ... XC X IF(CONVIO) THEN X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,6) X6 FORMAT(T3,'*',7X,'CONSTRAINT VIOLATED',T74,'*',/T3,'*', X $ T74,'*',/T3,'*',10X,'TRIAL ESTIMATES (VIOLATIONS MARKED)' X $ ,T74,'*') X WRITE(NUNIT,1) X DO 500 I=1,N X IF(WV3(I).GT.ZERO) THEN X WRITE(NUNIT,7) I,XPLUS(I) X7 FORMAT(T3,'*',13X,'XPLUS(',I3,') = ',1PD12.3, X $ 2X,'*',T74,'*') X ELSE X WRITE(NUNIT,8) I,XPLUS(I) X8 FORMAT(T3,'*',13X,'XPLUS(',I3,') = ',1PD12.3, X $ T74,'*') X END IF X500 CONTINUE X END IF XC XC FIND STEP WITHIN CONSTRAINED REGION. XC XC FIND THE RATIO OF THE DISTANCE FROM THE (I)TH XC COMPONENT TO ITS CONSTRAINT TO THE LENGTH OF THE XC PROPOSED STEP, XPLUS(I)-XC(I). MULTIPLY THIS BY XC CONFAC (DEFAULT 0.95) TO ENSURE THE NEW STEP STAYS XC WITHIN THE ACCEPTABLE REGION UNLESS XC IS CLOSE TO XC THE BOUNDARY (RATIO <= 1/2). IN SUCH CASES A FACTOR XC OF 0.5*CONFAC IS USED. XC XC NOTE: ONLY THE VIOLATING COMPONENTS ARE REDUCED. XC X RATIOM=ONE XC XC RATIOM STORES THE MINIMUM VALUE OF RATIO. XC X DO 600 I=1,N X IF(WV3(I).EQ.ONE) THEN X RATIO=(BOUNDL(I)-XC(I))/S(I) X ELSEIF(WV3(I).EQ.TWO) THEN X RATIO=(BOUNDU(I)-XC(I))/S(I) X END IF X IF(WV3(I).GT.ZERO) THEN XC XC NOTE: RATIO IS STORED IN WV3 FOR OUTPUT ONLY. XC X WV3(I)=RATIO XC X RATIOM=MIN(RATIOM,RATIO) X IF(RATIO.GT.PT5) THEN X XPLUS(I)=XC(I)+CONFAC*RATIO*S(I) X ELSE XC XC WITHIN BUFFER ZONE. XC X XPLUS(I)=XC(I)+CONFAC*RATIO*S(I)/TWO X END IF X S(I)=XPLUS(I)-XC(I) X END IF X600 CONTINUE X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,1) X WRITE(NUNIT,9) X9 FORMAT(T3,'*',7X,'NEW S AND XPLUS VECTORS', X $ ' (WITH RATIOS FOR VIOLATIONS)',T74,'*') X WRITE(NUNIT,1) X WRITE(NUNIT,10) X10 FORMAT(T3,'*',7X,'NOTE: RATIOS ARE RATIO OF', X $ ' LENGTH TO BOUNDARY FROM CURRENT',T74,'*') X WRITE(NUNIT,11) X11 FORMAT(T3,'*',7X,'X VECTOR TO MAGNITUDE OF', X $ ' CORRESPONDING PROPOSED STEP',T74,'*') X WRITE(NUNIT,1) X DO 700 I=1,N X IF(WV3(I).LT.ZERO) THEN X WRITE(NUNIT,12) I,S(I),I,XPLUS(I) X12 FORMAT(T3,'*',7X,'S(',I3,') = ',1PD12.3,4X, X $ 'XPLUS(',I3,') = ',1PD12.3,T74,'*') X ELSE X WRITE(NUNIT,13) I,S(I),I,XPLUS(I),WV3(I) X13 FORMAT(T3,'*',7X,'S(',I3,') = ',1PD12.3,4X, X $ 'XPLUS(',I3,') = ',1PD12.3,1X,1PD11.3,T74,'*') X END IF X700 CONTINUE X WRITE(NUNIT,1) X WRITE(NUNIT,14) RATIOM X14 FORMAT(T3,'*',7X,'MINIMUM OF RATIOS, RATIOM: ', X $ 1PD12.3,T74,'*') X END IF XC XC THE NEW POINT, XPLUS, IS NOT NECESSARILY IN A DESCENT XC DIRECTION. CHECK DIRECTIONAL DERIVATIVE FOR MODIFIED XC STEP, DLFTSM. XC X CALL INNERP(OVERCH,OVERFL,MAXEXP,N ,N ,N , X $ NUNIT ,OUTPUT,DLFTSM,DELF ,S ) X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,15) DLFTSM X15 FORMAT(T3,'*',7X,'INNER PRODUCT OF DELF AND MODIFIED S', X $ ', DLFTSM: ',1PD12.3,T74,'*') X END IF XC XC IF DLFTSM IS POSITIVE REDUCE TRUST REGION. IF NOT, TEST XC NEW POINT. XC X IF(DLFTSM.GT.ZERO) THEN X DELTA=CONFAC*RATIOM*DELTA X RETCOD=8 X RETURN X END IF X END IF XC XC CONSTRAINTS NOT (OR NO LONGER) VIOLATED - TEST NEW POINT. XC X CALL FVECEV(OVERFL,N,FVEC,XPLUS) X NFUNC=NFUNC+1 XC XC IF OVERFLOW AT NEW POINT REDUCE TRUST REGION AND RETURN. XC X IF(OVERFL) THEN XC XC IF THE OVERFLOW COMES AS A RESULT OF INCREASING DELTA XC WITHIN THE CURRENT ITERATION (IMPLYING DELSTR IS POSITIVE) XC AND DIVIDING DELTA BY 10 WOULD PRODUCE A DELTA WHICH XC IS SMALLER THAN THAT AT THE STORED POINT, THEN USE XC STORED POINT AS THE UPDATED RESULT. XC X IF(DELSTR.GT.DELTA/TEN) THEN X CALL MATCOP(N,N,1,1,N,1,XPLPRE,XPLUS) X CALL MATCOP(N,N,1,1,N,1,FPLPRE,FVEC) X ACPCOD=ACPSTR X DELTA=DELSTR X FCNNEW=FCNPRE X RETCOD=1 X ELSE X DELTA=DELTA/TEN X RETCOD=9 X END IF X RETURN X END IF XC XC NO OVERFLOW IN RESIDUAL VECTOR. XC X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,16) X16 FORMAT(T3,'*',12X,'TRIAL ESTIMATES',18X, X $ 'FUNCTION VALUES',T74,'*') X WRITE(NUNIT,1) X DO 800 I=1,N X WRITE(NUNIT,17) I,XPLUS(I),I,FVEC(I) X17 FORMAT(T3,'*',7X,'XPLUS(',I3,') = ',1PD12.3,9X, X $ 'FVEC(',I3,') = ',1PD12.3,T74,'*') X800 CONTINUE X END IF XC XC IF NO OVERFLOW WITHIN RESIDUAL VECTOR FIND OBJECTIVE XC FUNCTION. XC X CALL FCNEVL(OVERFL,MAXEXP,N ,NUNIT ,OUTPUT, X $ EPSMCH,FCNNEW,FVEC ,SCALEF,WV3 ) XC XC IF OVERFLOW IN OBJECTIVE FUNCTION EVALUATION REDUCE XC TRUST REGION AND RETURN. XC X IF(OVERFL) THEN XC XC IF THE OVERFLOW COMES AS A RESULT OF INCREASING DELTA XC WITHIN THE CURRENT ITERATION (SO THAT DELSTR IS POSITIVE) XC AND DIVIDING DELTA BY 10 WOULD PRODUCE A DELTA WHICH XC IS SMALLER THAN THAT AT THE STORED POINT THEN USE XC STORED POINT AS THE UPDATED RESULT. XC X IF(DELSTR.GT.DELTA/TEN) THEN X CALL MATCOP(N,N,1,1,N,1,XPLPRE,XPLUS) X CALL MATCOP(N,N,1,1,N,1,FPLPRE,FVEC) X ACPCOD=ACPSTR X DELTA=DELSTR X FCNNEW=FCNPRE X RETCOD=2 X ELSE X DELTA=DELTA/TEN X RETCOD=10 X END IF X RETURN X ELSE XC XC NO OVERFLOW AT TRIAL POINT - COMPARE OBJECTIVE FUNCTION XC TO FCNMAX. XC X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X IF(.NOT.SCLFCH) THEN X WRITE(NUNIT,18) FCNNEW X18 FORMAT(T3,'*',7X,'OBJECTIVE FUNCTION AT XPLUS,', X $ ' FCNNEW: .........',1PD12.4,T74,'*') X ELSE X WRITE(NUNIT,19) FCNNEW X19 FORMAT(T3,'*',7X,'SCALED OBJECTIVE FUNCTION AT XPLUS', X $ ', FCNNEW: ..',1PD12.4,T74,'*') X END IF X WRITE(NUNIT,20) FCNMAX+ALPHA*DELFTS X20 FORMAT(T3,'*',7X,'COMPARE TO FCNMAX+ALPHA*DELFTS: ', X $ 14('.'),1PD12.4,T74,'*') X END IF X END IF XC XC IF ACPTCR=12 CHECK SECOND DEUFLHARD STEP ACCEPTANCE TEST XC BY FINDING 2-NORM OF SBAR. THERE ARE FOUR POSSIBILITIES XC DEPENDING ON WHETHER THE JACOBIAN IS OR IS NOT SINGULAR XC AND WHETHER QNUPDM IS 0 OR 1. XC X IF(ACPTCR.EQ.12) THEN X IF(QRSING) THEN XC XC FORM -J^F AS RIGHT HAND SIDE - METHOD DEPENDS ON XC WHETHER QNUPDM EQUALS 0 OR 1 (UNFACTORED OR FACTORED). XC X IF(QNUPDM.EQ.0) THEN XC XC UNSCALED JACOBIAN IS IN MATRIX JAC. XC X DO 900 I=1,N X WV3(I)=-FVEC(I)*SCALEF(I)*SCALEF(I) X900 CONTINUE X CALL ATBMUL(N,N,1,1,N,N,JAC,WV3,RHS) XC X ELSE XC XC R IN UPPER TRIANGLE OF A PLUS RDIAG AND Q^ IN JAC XC FROM QR DECOMPOSITION OF SCALED JACOBIAN. XC X DO 1000 I=1,N X SUM=ZERO X DO 1100 J=1,N X SUM=SUM-JAC(I,J)*FVEC(J)*SCALEF(J) X1100 CONTINUE X WV3(I)=SUM X1000 CONTINUE X RHS(1)=RDIAG(1)*WV3(1) X DO 1200 J=2,N X SUM=ZERO X DO 1300 I=1,J-1 X SUM=SUM+A(I,J)*WV3(I) X1300 CONTINUE X RHS(J)=SUM+RDIAG(J)*WV3(J) X1200 CONTINUE X END IF X CALL CHSOLV(OVERCH,OVERFL,MAXEXP,N ,NUNIT , X $ OUTPUT,A ,RHS ,SBAR ,WV3 ) X ELSE XC XC RIGHT HAND SIDE IS -FVEC. XC X IF(QNUPDM.EQ.0.OR.JUPDM.EQ.0) THEN XC XC QR DECOMPOSITION OF SCALED JACOBIAN STORED IN XC ASTORE. XC X DO 1400 I=1,N X SBAR(I)=-FVEC(I)*SCALEF(I) X1400 CONTINUE X CALL QRSOLV(OVERCH,OVERFL,MAXEXP,N ,NUNIT , X $ OUTPUT,ASTORE,HHPI ,RDIAG ,SBAR ) X ELSE XC XC SET UP RIGHT HAND SIDE - MULTIPLY -FVEC BY Q^ XC (STORED IN JAC). RHS IS A WORK VECTOR ONLY HERE. XC X DO 1500 I=1,N X WV3(I)=-FVEC(I)*SCALEF(I) X1500 CONTINUE X CALL AVMUL(N,N,N,N,JAC,WV3,SBAR) X CALL RSOLV(OVERCH,OVERFL,MAXEXP,N ,NUNIT , X $ OUTPUT,A ,RDIAG ,SBAR ) X END IF X END IF XC XC NORM OF (SCALED) SBAR IS NEEDED FOR SECOND ACCEPTANCE TEST. XC X DO 1600 I=1,N X WV3(I)=SCALEX(I)*SBAR(I) X1600 CONTINUE X CALL TWONRM(OVERFL,MAXEXP,N,EPSMCH,SBRNRM,WV3) XC X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,1) X IF(.NOT.SCLXCH) THEN X WRITE(NUNIT,21) X21 FORMAT(T3,'*',10X,'DEUFLHARD SBAR VECTOR',T74,'*') X WRITE(NUNIT,1) X DO 1700 I=1,N X WRITE(NUNIT,22) I,SBAR(I) X22 FORMAT(T3,'*',10X,'SBAR(',I3,') = ', X $ 1PD12.3,T74,'*') X1700 CONTINUE X ELSE X WRITE(NUNIT,23) X23 FORMAT(T3,'*',10X,'DEUFLHARD SBAR VECTOR',14X, X $ 'IN SCALED X UNITS',T74,'*') X WRITE(NUNIT,1) X DO 1800 I=1,N X WRITE(NUNIT,24) I,SBAR(I),I,SCALEX(I)*SBAR(I) X24 FORMAT(T3,'*',10X,'SBAR(',I3,') = ',1PD12.3, X $ 8X,'SBAR(',I3,') = ',1PD12.3,T74,'*') X1800 CONTINUE X END IF X END IF X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X IF(.NOT.SCLXCH) THEN X WRITE(NUNIT,25) SBRNRM X25 FORMAT(T3,'*',10X,'VALUE OF SBRNRM', X $ ' AT XPLUS: .................'1PD12.4,T74,'*') X ELSE X WRITE(NUNIT,26) SBRNRM X26 FORMAT(T3,'*',10X,'VALUE OF SCALED SBRNRM', X $ ' AT XPLUS: ..........'1PD12.4,T74,'*') X END IF X WRITE(NUNIT,27) NEWMAX X27 FORMAT(T3,'*',10X,'NEWMAX: ',35('.'),1PD12.4,T74,'*') X END IF X IF(SBRNRM.LT.NEWMAX) ACPCOD=2 XC XC FUNCTION VALUE ACCEPTANCE IS ALSO CHECKED REGARDLESS XC OF WHETHER SECOND STEP ACCEPTANCE CRITERION WAS MET. XC X END IF XC XC ESTABLISH DELTAF FOR USE IN COMPARISON TO PREDICTED XC CHANGE IN OBJECTIVE FUNCTION, DELFPR, LATER. XC X DELTAF=FCNNEW-FCNOLD X IF(FCNNEW.GE.FCNMAX+ALPHA*DELFTS) THEN XC XC FAILURE OF FIRST STEP ACCEPTANCE TEST. TEST LENGTH OF XC STEP TO ENSURE PROGRESS IS STILL BEING MADE. XC X RELLEN=ZERO X DO 1900 I=1,N X RELLEN=MAX(RELLEN,ABS(S(I))/ X $ MAX((ABS(XPLUS(I))),ONE/SCALEX(I))) X1900 CONTINUE X IF(RELLEN.LT.STPTOL) THEN XC XC NO PROGRESS BEING MADE - RETCOD = 7 STOPS PROGRAM. XC X CALL MATCOP(N,N,1,1,N,1,XC,XPLUS) X RETCOD=7 X RETURN X ELSE XC XC FAILURE OF STEP BY OBJECTIVE FUNCTION CRITERION. XC ESTABLISH A NEW DELTA FROM EITHER SIMPLE DIVISION XC BY DELFAC OR BY FINDING THE MINIMUM OF A QUADRATIC XC MODEL. XC X IF(GEOMS) THEN X DELTA=DELTA/DELFAC X ELSE XC XC FIRST FIND LENGTH OF TRUST REGION STEP. XC X DO 2000 I=1,N X WV3(I)=S(I)*SCALEX(I) X2000 CONTINUE X CALL TWONRM(OVERFL,MAXEXP,N,EPSMCH,STPLEN,WV3) XC X CALL QMIN(NUNIT,OUTPUT,DELFTS,DELTA,DELTAF,STPLEN) XC X END IF X IF(DELTA.LT.DELSTR) THEN XC XC IF DELTA HAS BEEN INCREASED AT THIS ITERATION XC AND THE DELTA FROM QMIN IS LESS THAN THE DELTA XC AT THE PREVIOUSLY ACCEPTED (STORED) POINT THEN XC RETURN TO THAT POINT AND ACCEPT IT AS THE UPDATED XC ITERATE. XC X CALL MATCOP(N,N,1,1,N,1,XPLPRE,XPLUS) X CALL MATCOP(N,N,1,1,N,1,FPLPRE,FVEC) X ACPCOD=ACPSTR X DELTA=DELSTR X FCNNEW=FCNPRE X RETCOD=3 X RETURN X END IF XC XC IF THE SECOND ACCEPTANCE TEST HAS BEEN PASSED RETURN XC WITH NEW TRUST REGION AND CONTINUE ON TO NEXT ITER- XC ATION; OTHERWISE TRY A NEW STEP WITH REDUCED DELTA. XC X IF(ACPCOD.EQ.2) THEN X RETCOD=4 X ELSE XC XC FAILURE OF FIRST STEP ACCEPTANCE TEST. XC X RETCOD=11 X END IF X RETURN X END IF X ELSE XC XC OBJECTIVE FUNCTION MEETS FIRST ACCEPTANCE CRITERION. XC IN NONMONOTONIC SEARCHES IT MAY BE GREATER THAN THE XC PREVIOUS OBJECTIVE FUNCTION VALUE - CONSIDER THIS XC CASE FIRST. XC X IF(DELTAF.GE.ALPHA*DELFTS) THEN XC XC AN ACCEPTABLE STEP HAS BEEN FOUND FOR THE XC NONMONOTONIC SEARCH BUT THE OBJECTIVE FUNCTION XC VALUE IS NOT A "DECREASE" FROM THE PREVIOUS XC ITERATION (ACTUALLY IT MIGHT BE BETWEEN ZERO AND XC ALPHA*DELFTS). ACCEPT STEP BUT REDUCE DELTA. XC X DELTA=DELTA/DELFAC X RETCOD=5 X IF(ACPCOD.EQ.2) THEN X ACPCOD=12 X ELSE X ACPCOD=1 X END IF X RETURN X END IF XC XC COMPARE DELTAF TO DELTAF PREDICTED, DELFPR, TO DETERMINE XC NEXT TRUST REGION SIZE. NOTE: DELTAF MUST BE LESS THAN XC ALPHA*DELFTS (IN ESSENCE NEGATIVE) TO HAVE REACHED THIS XC POINT IN TRSTUP. R IS IN UPPER TRIANGLE OF MATRIX A SO XC THE FOLLOWING CODE FINDS: XC XC DELFPR = DELF^S + 1/2 S^J^JS = DELF^S + 1/2 S^R^RS XC X DELFPR=DELFTS X CALL UVMUL(N,N,N,N,A,S,WV3) X DO 2100 I=1,N X DELFPR=DELFPR+WV3(I)*WV3(I)/TWO X2100 CONTINUE X IF(OUTPUT.GT.4) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,28) DELFPR X28 FORMAT(T3,'*',7X,'PREDICTED CHANGE IN OBJECTIVE', X $ ' FUNCTION, DELFPR:',1PD12.3,T74,'*') X WRITE(NUNIT,29) DELTAF X29 FORMAT(T3,'*',7X,' ACTUAL CHANGE IN OBJECTIVE', X $ ' FUNCTION, DELTAF:',1PD12.3,T74,'*') X END IF X IF(RETCOD.LE.6.AND.(ABS(DELFPR-DELTAF).LE. X $ ABS(DELTAF)/TEN.OR.DELTAF.LE.DELFTS).AND.(.NOT.NEWTKN) X $ .AND.(.NOT.CONVIO).AND.DELSTR.EQ.ZERO) THEN X IF(MIN(NEWLEN,MAXSTP)/DELTA.GT.ONEPT1) THEN XC XC PROMISING STEP - INCREASE TRUST REGION. XC XC STORE CURRENT POINT. XC X CALL MATCOP(N,N,1,1,N,1,XPLUS,XPLPRE) X CALL MATCOP(N,N,1,1,N,1,FVEC,FPLPRE) X DELSTR=DELTA X FCNPRE=FCNNEW XC XC IF NONMONOTONIC STEPS ARE BEING USED EXPAND TRUST XC REGION TO NEWLEN, OTHERWISE EXPAND BY DELFAC. XC X IF(ISEJAC.GT.NARMIJ) THEN X DELTA=MIN(NEWLEN,MAXSTP) X ELSE X DELTA=MIN(DELFAC*DELTA,MAXSTP) X END IF X RETCOD=12 X IF(ACPCOD.EQ.2) THEN X ACPSTR=12 X ELSE X ACPSTR=1 X END IF X ACPCOD=0 X ELSE X RETCOD=0 X IF(ACPCOD.EQ.2) THEN X ACPCOD=12 X ELSE X ACPCOD=1 X END IF X END IF X RETURN X ELSE XC XC CHANGE TRUST REGION SIZE DEPENDING ON DELTAF AND XC DELFPR. XC X RETCOD=6 X IF(ACPCOD.EQ.2) THEN X ACPCOD=12 X ELSE X ACPCOD=1 X END IF X IF(DELTAF.GE.DELFPR/TEN) THEN X DELTA=DELTA/DELFAC X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,30) X30 FORMAT(T3,'*',7X,'CHANGE IN F, DELTAF, IS GREATER', X $ ' THAN .1 DELFPR - REDUCE DELTA',T74,'*') X END IF X ELSEIF(TRUPDM.EQ.0.AND.JUPDM.GT.0) THEN XC XC POWELL'S UPDATING SCHEME - FIND JAC S FIRST. XC X IF(QNUPDM.EQ.0) THEN XC XC UNSCALED JACOBIAN IN JAC. XC X DO 2200 I=1,N X RHS(I)=S(I)*SCALEF(I) X2200 CONTINUE X CALL AVMUL(N,N,N,N,JAC,RHS,WV3) X ELSE XC XC MULTIPLY BY R FIRST. XC X CALL UVMUL(N,N,N,N,A,S,RHS) XC XC THEN Q (IN JAC^) XC X CALL ATBMUL(N,N,1,1,N,N,JAC,RHS,WV3) X END IF X DMULT=DELFPR/TEN-DELTAF X SP=ZERO X SS=ZERO X DO 2300 K=1,N X WV3(K)=WV3(K)+FVECC(K) X SP=SP+ABS(FVEC(K)*(FVEC(K)-WV3(K))) X SS=SS+(FVEC(K)-WV3(K))*(FVEC(K)-WV3(K)) X2300 CONTINUE X IF(SP+SQRT(SP*SP+DMULT*SS).LT.EPSMCH) THEN X POWLAM=TEN X ELSE X POWLAM=ONE+DMULT/(SP+SQRT(SP*SP+DMULT*SS)) X END IF X POWLAM=SQRT(POWLAM) X POWMU=MIN(DELFAC,POWLAM,POWTAU) X POWTAU=POWLAM/POWMU X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,31) X31 FORMAT(T3,'*',7X,'FACTORS IN POWELL UPDATING', X $ ' SCHEME',T74,'*') X WRITE(NUNIT,1) X WRITE(NUNIT,32) POWLAM,POWMU,POWTAU X32 FORMAT(T3,'*',7X,'LAMBDA: ',1PD12.3,4X,'MU: ', X $ 1PD12.3,4X,'TAU: ',1PD12.3,T74,'*') X WRITE(NUNIT,33) X33 FORMAT(T3,'*',7X,'DELTA IS MINIMUM OF MU*DELTA', X $ ' AND MAXSTP',T74,'*') X END IF X DELTA=MIN(POWMU*DELTA,MAXSTP) X ELSE X IF(DELTAF.LT.THREEQ*DELFPR) THEN X DELTA=MIN(DELFAC*DELTA,MAXSTP) X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,34) X34 FORMAT(T3,'*',7X,'CHANGE IN F, DELTAF, IS LESS', X $ ' THAN .75 X PREDICTED',T74,'*') X WRITE(NUNIT,35) DELTA X35 FORMAT(T3,'*',7X,'DELTA INCREASED TO: ',1PD12.3, X $ T74,'*') X END IF X ELSE X IF(OUTPUT.GT.3) THEN X WRITE(NUNIT,1) X WRITE(NUNIT,36) X36 FORMAT(T3,'*',7X,'DELTAF BETWEEN 0.1 AND 0.75', X $ ' DELFPR - LEAVE DELTA UNCHANGED',T74,'*') X END IF X END IF X END IF X END IF X END IF X RETURN XC XC LAST CARD OF SUBROUTINE TRSTUP. XC X END X END_OF_FILE if test 23872 -ne `wc -c <'trstup.f'`; then echo shar: \"'trstup.f'\" unpacked with wrong size! fi # end of 'trstup.f' fi if test -f 'twonrm.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'twonrm.f'\" else echo shar: Extracting \"'twonrm.f'\" \(3033 characters\) sed "s/^X//" >'twonrm.f' <<'END_OF_FILE' X SUBROUTINE TWONRM(OVERFL,MAXEXP,N,EPSMCH,EUCNRM,V) XC XC FEB. 23 ,1992 XC XC THIS SUBROUTINE EVALUATES THE EUCLIDEAN NORM OF A VECTOR, V. XC IT FOLLOWS THE ALGORITHM OF J.L. BLUE IN ACM TOMS V4 15 (1978) XC BUT USES SLIGHTLY DIFFERENT CUTS. THE CONSTANTS IN COMMON BLOCK XC NNES_5 ARE CALCULATED IN THE SUBROUTINE MACHAR OR ARE PROVIDED XC BY THE USER IN THE DRIVER. XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DIMENSION V(N) X LOGICAL OVERFL X COMMON/NNES_5/SMALLB,BIGB,SMALLS,BIGS,BIGR X DATA ZERO,ONE,TWO,TEN /0.0D0,1.0D0,2.0D0,10.0D0/ XC X OVERFL=.FALSE. X SQRTEP=SQRT(EPSMCH) XC X ASMALL=ZERO X AMED=ZERO X ABIG=ZERO X DO 100 I=1,N XC XC ACCUMULATE SUMS OF SQUARES IN ONE OF THREE ACCULULATORS, XC ABIG, AMED AND ASMALL, DEPENDING ON THEIR SIZES. XC X ABSVI=ABS(V(I)) XC XC THIS COMPARISON RESTRICTS THE MAXIMUM VALUE OF AMED TO BE XC B/N => CANNOT SUM SO THAT AMED OVERFLOWS. XC X IF(ABSVI.GT.BIGB/DBLE(N)) THEN XC XC THIS DIVISOR OF 10N RESTRICTS ABIG FROM (PATHALOGICALLY) XC OVERFLOWING FROM SUMMATION. XC X ABIG=ABIG+((V(I)/(TEN*DBLE(N)*BIGS)))**2 XC X ELSEIF(ABSVI.LT.SMALLS) THEN XC X ASMALL=ASMALL+((V(I)/SMALLS))**2 XC X ELSE XC X AMED=AMED+V(I)*V(I) XC X END IF XC X100 CONTINUE X IF(ABIG.GT.ZERO) THEN XC XC IF OVERFLOW WOULD OCCUR ASSIGN BIGR AS NORM AND SIGNAL TO XC CALLING SUBROUTINE VIA OVERFL. XC X IF(LOG10(ABIG)/TWO+LOG10(BIGS)+1+LOG10(DBLE(N)) X $ .GT.MAXEXP) THEN X EUCNRM=BIGR X OVERFL=.TRUE. X RETURN X END IF XC XC IF AMED IS POSITIVE IT COULD CONTRIBUTE TO THE NORM - XC DETERMINATION IS DELAYED UNTIL LATER TO SAVE REPEATING XC CODE. XC X IF(AMED.GT.ZERO) THEN X YMIN=MIN(SQRT(AMED),TEN*DBLE(N)*BIGS*SQRT(ABIG)) X YMAX=MAX(SQRT(AMED),TEN*DBLE(N)*BIGS*SQRT(ABIG)) X ELSE XC XC AMED DOESN'T CONTRIBUTE AND ASMALL WON'T MATTER IF XC ABIG IS NONZERO - FIND NORM USING ABIG AND RETURN. XC X EUCNRM=TEN*DBLE(N)*BIGS*SQRT(ABIG) X RETURN X END IF X ELSEIF(ASMALL.GT.ZERO) THEN X IF(AMED.GT.ZERO) THEN X YMIN=MIN(SQRT(AMED),SMALLS*SQRT(ASMALL)) X YMAX=MAX(SQRT(AMED),SMALLS*SQRT(ASMALL)) X ELSE XC XC ABIG AND AMED ARE ZERO SO USE ASMALL ONLY. XC X EUCNRM=SMALLS*SQRT(ASMALL) X RETURN X END IF X ELSE X EUCNRM=SQRT(AMED) X RETURN X END IF X IF(YMIN.LT.SQRTEP*YMAX) THEN XC XC SMALLER PORTION DOES NOT CONTRIBUTE TO NORM. XC X EUCNRM=YMAX X ELSE XC XC SMALLER PORTION CONTRIBUTES TO NORM. XC X EUCNRM=YMAX*SQRT((ONE+YMIN/YMAX)*(ONE+YMIN/YMAX)) X END IF X RETURN XC XC LAST CARD OF SUBROUTINE TWONRM. XC X END END_OF_FILE if test 3033 -ne `wc -c <'twonrm.f'`; then echo shar: \"'twonrm.f'\" unpacked with wrong size! fi # end of 'twonrm.f' fi if test -f 'update.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'update.f'\" else echo shar: Extracting \"'update.f'\" \(730 characters\) sed "s/^X//" >'update.f' <<'END_OF_FILE' X SUBROUTINE UPDATE(MNEW ,MOLD ,N ,TRMCOD,FCNNEW, X $ FCNOLD,FVEC ,FVECC ,XC ,XPLUS ) XC XC FEB. 9, 1991 XC XC THIS SUBROUTINE RESETS CURRENT ESTIMATES OF SOLUTION XC AND UPDATES THE OBJECTIVE FUNCTION VALUE, M (USED TO XC SET HOW MANY PREVIOUS VALUES TO LOOK AT IN THE NON- XC MONOTONIC COMPARISONS) AND THE TERMINATION CODE, TRMCOD. XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X INTEGER TRMCOD X DIMENSION FVEC(N) ,FVECC(N) ,XC(N) ,XPLUS(N) X FCNOLD=FCNNEW X MOLD=MNEW X TRMCOD=0 X DO 100 I=1,N X FVECC(I)=FVEC(I) X XC(I)=XPLUS(I) X100 CONTINUE X RETURN XC XC LAST CARD OF SUBROUTINE UPDATE. XC X END END_OF_FILE if test 730 -ne `wc -c <'update.f'`; then echo shar: \"'update.f'\" unpacked with wrong size! fi # end of 'update.f' fi if test -f 'utbmul.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'utbmul.f'\" else echo shar: Extracting \"'utbmul.f'\" \(4280 characters\) sed "s/^X//" >'utbmul.f' <<'END_OF_FILE' X SUBROUTINE UTBMUL(NCADEC,NCAACT,NCBDEC,NCBACT,NCDEC,NCACT, X $ AMAT ,BMAT ,CMAT) XC XC FEB. 8, 1991 XC XC MATRIX MULTIPLICATION: A^B=C WHERE A IS UPPER TRIANGULAR XC XC VERSION WITH INNER LOOP UNROLLED TO DEPTHS 32, 16, 8 AND 4. XC XC NCADEC IS 2ND DIM. OF AMAT; NCAACT IS ACTUAL LIMIT FOR 2ND INDEX XC NCBDEC IS 2ND DIM. OF BMAT; NCBACT IS ACTUAL LIMIT FOR 2ND INDEX XC NCDEC IS COMMON DIMENSION OF AMAT & BMAT; NCACT IS ACTUAL LIMIT XC XC I.E. NCADEC IS NUMBER OF COLUMNS OF A DECLARED XC NCBDEC IS NUMBER OF COLUMNS OF B DECLARED XC NCDEC IS THE NUMBER OF ROWS IN BOTH A AND B DECLARED XC XC MODIFICATION OF THE MATRIX MULTIPLIER DONATED BY PROF. JAMES XC MACKINNON, QUEEN'S UNIVERSITY, KINGSTON, ONTARIO, CANADA XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DIMENSION AMAT(NCDEC,NCADEC), BMAT(NCDEC,NCBDEC), X $ CMAT(NCADEC,NCBDEC) X DATA ZERO /0.0D0/ X DO 100 I=1,NCAACT XC XC FIND NUMBER OF GROUPS OF SIZE 32, 16 ... XC X NEND=MIN(I,NCACT) XC XC THIS ADJUSTMENT IS REQUIRED WHEN NCACT IS LESS THAN NCAACT. XC X NCC32=NEND/32 X NCC32R=NEND-32*NCC32 X NCC16=NCC32R/16 X NCC16R=NCC32R-16*NCC16 X NCC8=NCC16R/8 X NCC8R=NCC16R-8*NCC8 X NCC4=NCC8R/4 X NCC4R=NCC8R-4*NCC4 XC XC FIND ENTRY IN MATRIX C. XC X DO 200 J=1,NCBACT X SUM=ZERO X K=0 X IF(NCC32.GT.0) THEN X DO 300 KK=1,NCC32 X K=K+32 X SUM=SUM X $ +AMAT(K-31,I)*BMAT(K-31,J)+AMAT(K-30,I)*BMAT(K-30,J) X $ +AMAT(K-29,I)*BMAT(K-29,J)+AMAT(K-28,I)*BMAT(K-28,J) X $ +AMAT(K-27,I)*BMAT(K-27,J)+AMAT(K-26,I)*BMAT(K-26,J) X $ +AMAT(K-25,I)*BMAT(K-25,J)+AMAT(K-24,I)*BMAT(K-24,J) X SUM=SUM X $ +AMAT(K-23,I)*BMAT(K-23,J)+AMAT(K-22,I)*BMAT(K-22,J) X $ +AMAT(K-21,I)*BMAT(K-21,J)+AMAT(K-20,I)*BMAT(K-20,J) X $ +AMAT(K-19,I)*BMAT(K-19,J)+AMAT(K-18,I)*BMAT(K-18,J) X $ +AMAT(K-17,I)*BMAT(K-17,J)+AMAT(K-16,I)*BMAT(K-16,J) X SUM=SUM X $ +AMAT(K-15,I)*BMAT(K-15,J)+AMAT(K-14,I)*BMAT(K-14,J) X $ +AMAT(K-13,I)*BMAT(K-13,J)+AMAT(K-12,I)*BMAT(K-12,J) X $ +AMAT(K-11,I)*BMAT(K-11,J)+AMAT(K-10,I)*BMAT(K-10,J) X $ +AMAT(K-9,I) *BMAT(K-9,J) +AMAT(K-8,I) *BMAT(K-8,J) X SUM=SUM X $ +AMAT(K-7,I)*BMAT(K-7,J)+AMAT(K-6,I)*BMAT(K-6,J) X $ +AMAT(K-5,I)*BMAT(K-5,J)+AMAT(K-4,I)*BMAT(K-4,J) X $ +AMAT(K-3,I)*BMAT(K-3,J)+AMAT(K-2,I)*BMAT(K-2,J) X $ +AMAT(K-1,I)*BMAT(K-1,J)+AMAT(K,I) *BMAT(K,J) X300 CONTINUE X END IF X IF(NCC16.GT.0) THEN X DO 400 KK=1,NCC16 X K=K+16 X SUM=SUM X $ +AMAT(K-15,I)*BMAT(K-15,J)+AMAT(K-14,I)*BMAT(K-14,J) X $ +AMAT(K-13,I)*BMAT(K-13,J)+AMAT(K-12,I)*BMAT(K-12,J) X $ +AMAT(K-11,I)*BMAT(K-11,J)+AMAT(K-10,I)*BMAT(K-10,J) X $ +AMAT(K-9,I)*BMAT(K-9,J) +AMAT(K-8,I) *BMAT(K-8,J) X SUM=SUM X $ +AMAT(K-7,I)*BMAT(K-7,J)+AMAT(K-6,I)*BMAT(K-6,J) X $ +AMAT(K-5,I)*BMAT(K-5,J)+AMAT(K-4,I)*BMAT(K-4,J) X $ +AMAT(K-3,I)*BMAT(K-3,J)+AMAT(K-2,I)*BMAT(K-2,J) X $ +AMAT(K-1,I)*BMAT(K-1,J)+AMAT(K,I) *BMAT(K,J) X400 CONTINUE X END IF X IF(NCC8.GT.0) THEN X DO 500 KK=1,NCC8 X K=K+8 X SUM=SUM X $ +AMAT(K-7,I)*BMAT(K-7,J)+AMAT(K-6,I)*BMAT(K-6,J) X $ +AMAT(K-5,I)*BMAT(K-5,J)+AMAT(K-4,I)*BMAT(K-4,J) X $ +AMAT(K-3,I)*BMAT(K-3,J)+AMAT(K-2,I)*BMAT(K-2,J) X $ +AMAT(K-1,I)*BMAT(K-1,J)+AMAT(K,I) *BMAT(K,J) X500 CONTINUE X END IF X IF(NCC4.GT.0) THEN X DO 600 KK=1,NCC4 X K=K+4 X SUM=SUM X $ +AMAT(K-3,I)*BMAT(K-3,J)+AMAT(K-2,I)*BMAT(K-2,J) X $ +AMAT(K-1,I)*BMAT(K-1,J)+AMAT(K,I) *BMAT(K,J) X600 CONTINUE X END IF X IF(NCC4R.GT.0) THEN X DO 700 KK=1,NCC4R X K=K+1 X SUM=SUM+AMAT(K,I)*BMAT(K,J) X700 CONTINUE X END IF X CMAT(I,J)=SUM X200 CONTINUE X100 CONTINUE X RETURN XC XC LAST CARD OF SUBROUTINE UTBMUL. XC X END END_OF_FILE if test 4280 -ne `wc -c <'utbmul.f'`; then echo shar: \"'utbmul.f'\" unpacked with wrong size! fi # end of 'utbmul.f' fi if test -f 'utumul.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'utumul.f'\" else echo shar: Extracting \"'utumul.f'\" \(4492 characters\) sed "s/^X//" >'utumul.f' <<'END_OF_FILE' X SUBROUTINE UTUMUL(NRADEC,NCADEC,NRAACT,NCAACT,NRBDEC,NCBDEC, X $ AMAT ,BMAT) XC XC FEB. 8, 1991 XC XC MATRIX MULTIPLICATION: A^A=B WHERE A IS UPPER TRIANGULAR XC XC VERSION WITH INNER LOOP UNROLLED TO DEPTHS 32, 16, 8 AND 4. XC XC NRADEC IS NUMBER OF ROWS IN A DECLARED XC NCADEC IS NUMBER OF COLUMNS IN A DECLARED XC NRAACT IS THE LIMIT FOR THE 1ST INDEX IN A XC NCAACT IS THE LIMIT FOR THE 2ND INDEX IN A XC NRBDEC IS NUMBER OF ROWS IN B DECLARED XC NCBDEC IS NUMBER OF COLUMNS IN B DECLARED XC XC MODIFIED VERSION OF THE MATRIX MULTIPLIER DONATED BY PROF. JAMES XC MACKINNON, QUEEN'S UNIVERSITY, KINGSTON, ONTARIO, CANADA XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DIMENSION AMAT(NRADEC,NCADEC), BMAT(NRBDEC,NCBDEC) X DATA ZERO /0.0D0/ XC XC FIND ENTRY IN MATRIX B. XC X DO 100 I=1,NCAACT XC XC FIND NUMBER OF GROUPS OF SIZE 32, 16 ... XC X NEND=MIN(I,NRAACT) XC X NCC32=NEND/32 X NCC32R=NEND-32*NCC32 X NCC16=NCC32R/16 X NCC16R=NCC32R-16*NCC16 X NCC8=NCC16R/8 X NCC8R=NCC16R-8*NCC8 X NCC4=NCC8R/4 X NCC4R=NCC8R-4*NCC4 X DO 200 J=I,NCAACT X SUM=ZERO X K=0 X IF(NCC32.GT.0) THEN X DO 300 KK=1,NCC32 X K=K+32 X SUM=SUM X $ +AMAT(K-31,I)*AMAT(K-31,J)+AMAT(K-30,I)*AMAT(K-30,J) X $ +AMAT(K-29,I)*AMAT(K-29,J)+AMAT(K-28,I)*AMAT(K-28,J) X $ +AMAT(K-27,I)*AMAT(K-27,J)+AMAT(K-26,I)*AMAT(K-26,J) X $ +AMAT(K-25,I)*AMAT(K-25,J)+AMAT(K-24,I)*AMAT(K-24,J) X SUM=SUM X $ +AMAT(K-23,I)*AMAT(K-23,J)+AMAT(K-22,I)*AMAT(K-22,J) X $ +AMAT(K-21,I)*AMAT(K-21,J)+AMAT(K-20,I)*AMAT(K-20,J) X $ +AMAT(K-19,I)*AMAT(K-19,J)+AMAT(K-18,I)*AMAT(K-18,J) X $ +AMAT(K-17,I)*AMAT(K-17,J)+AMAT(K-16,I)*AMAT(K-16,J) X SUM=SUM X $ +AMAT(K-15,I)*AMAT(K-15,J)+AMAT(K-14,I)*AMAT(K-14,J) X $ +AMAT(K-13,I)*AMAT(K-13,J)+AMAT(K-12,I)*AMAT(K-12,J) X $ +AMAT(K-11,I)*AMAT(K-11,J)+AMAT(K-10,I)*AMAT(K-10,J) X $ +AMAT(K-9,I)*AMAT(K-9,J) +AMAT(K-8,I)*AMAT(K-8,J) X SUM=SUM X $ +AMAT(K-7,I)*AMAT(K-7,J)+AMAT(K-6,I)*AMAT(K-6,J) X $ +AMAT(K-5,I)*AMAT(K-5,J)+AMAT(K-4,I)*AMAT(K-4,J) X $ +AMAT(K-3,I)*AMAT(K-3,J)+AMAT(K-2,I)*AMAT(K-2,J) X $ +AMAT(K-1,I)*AMAT(K-1,J)+AMAT(K,I) *AMAT(K,J) X300 CONTINUE X END IF X IF(NCC16.GT.0) THEN X DO 400 KK=1,NCC16 X K=K+16 X SUM=SUM X $ +AMAT(K-15,I)*AMAT(K-15,J)+AMAT(K-14,I)*AMAT(K-14,J) X $ +AMAT(K-13,I)*AMAT(K-13,J)+AMAT(K-12,I)*AMAT(K-12,J) X $ +AMAT(K-11,I)*AMAT(K-11,J)+AMAT(K-10,I)*AMAT(K-10,J) X $ +AMAT(K-9,I)*AMAT(K-9,J) +AMAT(K-8,I) *AMAT(K-8,J) X SUM=SUM X $ +AMAT(K-7,I)*AMAT(K-7,J)+AMAT(K-6,I)*AMAT(K-6,J) X $ +AMAT(K-5,I)*AMAT(K-5,J)+AMAT(K-4,I)*AMAT(K-4,J) X $ +AMAT(K-3,I)*AMAT(K-3,J)+AMAT(K-2,I)*AMAT(K-2,J) X $ +AMAT(K-1,I)*AMAT(K-1,J)+AMAT(K,I)*AMAT(K,J) X400 CONTINUE X END IF X IF(NCC8.GT.0) THEN X DO 500 KK=1,NCC8 X K=K+8 X SUM=SUM X $ +AMAT(K-7,I)*AMAT(K-7,J)+AMAT(K-6,I)*AMAT(K-6,J) X $ +AMAT(K-5,I)*AMAT(K-5,J)+AMAT(K-4,I)*AMAT(K-4,J) X $ +AMAT(K-3,I)*AMAT(K-3,J)+AMAT(K-2,I)*AMAT(K-2,J) X $ +AMAT(K-1,I)*AMAT(K-1,J)+AMAT(K,I)*AMAT(K,J) X500 CONTINUE X END IF X IF(NCC4.GT.0) THEN X DO 600 KK=1,NCC4 X K=K+4 X SUM=SUM X $ +AMAT(K-3,I)*AMAT(K-3,J)+AMAT(K-2,I)*AMAT(K-2,J) X $ +AMAT(K-1,I)*AMAT(K-1,J)+AMAT(K,I)*AMAT(K,J) X600 CONTINUE X END IF X IF(NCC4R.GT.0) THEN X DO 700 KK=1,NCC4R X K=K+1 X SUM=SUM+AMAT(K,I)*AMAT(K,J) X700 CONTINUE X END IF X BMAT(I,J)=SUM X IF(I.NE.J) BMAT(J,I)=BMAT(I,J) X200 CONTINUE X100 CONTINUE X RETURN XC XC LAST CARD OF SUBROUTINE UTUMUL. XC X END X X END_OF_FILE if test 4492 -ne `wc -c <'utumul.f'`; then echo shar: \"'utumul.f'\" unpacked with wrong size! fi # end of 'utumul.f' fi if test -f 'uvmul.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'uvmul.f'\" else echo shar: Extracting \"'uvmul.f'\" \(4180 characters\) sed "s/^X//" >'uvmul.f' <<'END_OF_FILE' X SUBROUTINE UVMUL(NRADEC,NRAACT,NCDEC ,NCACT ,AMAT ,BVEC ,CVEC) XC XC FEB. 8, 1991 XC XC MATRIX-VECTOR MULTIPLICATION: AB=C WHERE A IS UPPER TRIANGULAR XC XC VERSION WITH INNER LOOP UNROLLED TO DEPTHS 32, 16, 8 AND 4 XC EACH ROW OF MATRIX A IS SAVED AS A COLUMN BEFORE USE. XC XC NRADEC IS 1ST DIM. OF AMAT; NRAACT IS ACTUAL LIMIT FOR 1ST INDEX XC NCDEC IS COMMON DIMENSION OF AMAT & BVEC; NCACT IS ACTUAL LIMIT XC XC I.E. NRADEC IS THE NUMBER OF ROWS OF A DECLARED XC NCDEC IS THE COMMON DECLARED DIMENSION (COLUMNS OF A AND XC ROWS OF B) XC XC MODIFICATION OF THE MATRIX MULTIPLIER DONATED BY PROF. JAMES XC MACKINNON, QUEEN'S UNIVERSITY, KINGSTON, ONTARIO, CANADA XC X IMPLICIT DOUBLE PRECISION (A-H,O-Z) X DIMENSION AMAT(NRADEC,NCDEC), BVEC(NCDEC), CVEC(NRADEC) X DATA ZERO /0.0D0/ X DO 100 I=1,NRAACT XC XC FIND NUMBER OF GROUPS OF SIZE 32, 16 ... XC X NCC32=(NCACT-(I-1))/32 X NCC32R=(NCACT-(I-1))-32*NCC32 X NCC16=NCC32R/16 X NCC16R=NCC32R-16*NCC16 X NCC8=NCC16R/8 X NCC8R=NCC16R-8*NCC8 X NCC4=NCC8R/4 X NCC4R=NCC8R-4*NCC4 XC XC FIND ENTRY FOR VECTOR C. XC X SUM=ZERO X K=I-1 X IF(NCC32.GT.0) THEN X DO 200 KK=1,NCC32 X K=K+32 X SUM=SUM X $ +AMAT(I,K-31)*BVEC(K-31)+AMAT(I,K-30)*BVEC(K-30) X $ +AMAT(I,K-29)*BVEC(K-29)+AMAT(I,K-28)*BVEC(K-28) X $ +AMAT(I,K-27)*BVEC(K-27)+AMAT(I,K-26)*BVEC(K-26) X $ +AMAT(I,K-25)*BVEC(K-25)+AMAT(I,K-24)*BVEC(K-24) X SUM=SUM X $ +AMAT(I,K-23)*BVEC(K-23)+AMAT(I,K-22)*BVEC(K-22) X $ +AMAT(I,K-21)*BVEC(K-21)+AMAT(I,K-20)*BVEC(K-20) X $ +AMAT(I,K-19)*BVEC(K-19)+AMAT(I,K-18)*BVEC(K-18) X $ +AMAT(I,K-17)*BVEC(K-17)+AMAT(I,K-16)*BVEC(K-16) X SUM=SUM X $ +AMAT(I,K-15)*BVEC(K-15)+AMAT(I,K-14)*BVEC(K-14) X $ +AMAT(I,K-13)*BVEC(K-13)+AMAT(I,K-12)*BVEC(K-12) X $ +AMAT(I,K-11)*BVEC(K-11)+AMAT(I,K-10)*BVEC(K-10) X $ +AMAT(I,K-9)*BVEC(K-9) +AMAT(I,K-8) *BVEC(K-8) X SUM=SUM X $ +AMAT(I,K-7)*BVEC(K-7)+AMAT(I,K-6)*BVEC(K-6) X $ +AMAT(I,K-5)*BVEC(K-5)+AMAT(I,K-4)*BVEC(K-4) X $ +AMAT(I,K-3)*BVEC(K-3)+AMAT(I,K-2)*BVEC(K-2) X $ +AMAT(I,K-1)*BVEC(K-1)+AMAT(I,K) *BVEC(K) X200 CONTINUE X END IF X IF(NCC16.GT.0) THEN X DO 300 KK=1,NCC16 X K=K+16 X SUM=SUM X $ +AMAT(I,K-15)*BVEC(K-15)+AMAT(I,K-14)*BVEC(K-14) X $ +AMAT(I,K-13)*BVEC(K-13)+AMAT(I,K-12)*BVEC(K-12) X $ +AMAT(I,K-11)*BVEC(K-11)+AMAT(I,K-10)*BVEC(K-10) X $ +AMAT(I,K-9)*BVEC(K-9) +AMAT(I,K-8) *BVEC(K-8) X SUM=SUM X $ +AMAT(I,K-7)*BVEC(K-7)+AMAT(I,K-6)*BVEC(K-6) X $ +AMAT(I,K-5)*BVEC(K-5)+AMAT(I,K-4)*BVEC(K-4) X $ +AMAT(I,K-3)*BVEC(K-3)+AMAT(I,K-2)*BVEC(K-2) X $ +AMAT(I,K-1)*BVEC(K-1)+AMAT(I,K) *BVEC(K) X300 CONTINUE X END IF X IF(NCC8.GT.0) THEN X DO 400 KK=1,NCC8 X K=K+8 X SUM=SUM X $ +AMAT(I,K-7)*BVEC(K-7)+AMAT(I,K-6)*BVEC(K-6) X $ +AMAT(I,K-5)*BVEC(K-5)+AMAT(I,K-4)*BVEC(K-4) X $ +AMAT(I,K-3)*BVEC(K-3)+AMAT(I,K-2)*BVEC(K-2) X $ +AMAT(I,K-1)*BVEC(K-1)+AMAT(I,K) *BVEC(K) X400 CONTINUE X END IF X IF(NCC4.GT.0) THEN X DO 500 KK=1,NCC4 X K=K+4 X SUM=SUM X $ +AMAT(I,K-3)*BVEC(K-3)+AMAT(I,K-2)*BVEC(K-2) X $ +AMAT(I,K-1)*BVEC(K-1)+AMAT(I,K) *BVEC(K) X500 CONTINUE X END IF X IF(NCC4R.GT.0) THEN X DO 600 KK=1,NCC4R X K=K+1 X SUM=SUM+AMAT(I,K)*BVEC(K) X600 CONTINUE X END IF X CVEC(I)=SUM X100 CONTINUE X RETURN XC XC LAST CARD OF SUBROUTINE UVMUL. XC X END END_OF_FILE if test 4180 -ne `wc -c <'uvmul.f'`; then echo shar: \"'uvmul.f'\" unpacked with wrong size! fi # end of 'uvmul.f' fi echo shar: End of shell archive. exit 0