C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> cnmnsg.f SUBROUTINE CONMIN(FUNCNM,N,X,F,G, ACC,NFLAG, W,MDIM,NMETH, - TRACES,TUN,NTR ) INTEGER N, NFLAG, MDIM, NMETH, TUN, NTR LOGICAL TRACES(NTR) REAL FUNCNM, X(N), F, G(N), ACC, W(MDIM) C!!!! DOUBLE PRECISION FUNCNM, X(N), F, G(N), ACC, W(MDIM) C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: CNMN.F,V 2.5 91/12/31 14:52:21 BUCKLEY EXP $ C>RCS $LOG: CNMN.F,V $ C>RCS REVISION 2.5 91/12/31 14:52:21 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 2.4 91/12/16 11:18:53 BUCKLEY C>RCS MINOR FIX FOR TOMS. C>RCS C>RCS REVISION 2.3 91/11/22 11:27:35 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 2.2 91/06/12 14:10:40 BUCKLEY C>RCS FIXED ERROR 1.0E0 AND 1.0D0 C>RCS C>RCS REVISION 2.1 90/07/31 10:48:34 BUCKLEY C>RCS ADDED REVISED BLAS. C>RCS C>RCS REVISION 2.0 90/07/17 14:54:16 BUCKLEY C>RCS MINOR FIX TO REMOVE UNUSED XSQ. C>RCS C>RCS REVISION 1.9 89/06/30 13:27:34 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C## D E S C R I P T I O N: C C PURPOSE: SUBROUTINE CONMIN MINIMIZES AN UNCONSTRAINED NONLINEAR C SCALAR VALUED FUNCTION OF A VECTOR VARIABLE X C EITHER BY THE BFGS VARIABLE METRIC ALGORITHM OR BY A C BEALE RESTARTED CONJUGATE GRADIENT ALGORITHM. C C USAGE: CALL CONMIN(N,X,F,G,IFUN,ITER,EPS,NFLAG,MXFUN,W, C IOUT,MDIM,IDEV,ACC,NMETH) C C PARAMETERS: N THE NUMBER OF VARIABLES IN THE FUNCTION TO C BE MINIMIZED. C X THE VECTOR CONTAINING THE CURRENT ESTIMATE TO C THE MINIMIZER. ON ENTRY TO CONMIN,X MUST CONTAIN C AN INITIAL ESTIMATE SUPPLIED BY THE USER. C ON EXITING,X WILL HOLD THE BEST ESTIMATE TO THE C MINIMIZER OBTAINED BY CONMIN. X MUST BE DOUBLE C PRECISIONED AND DIMENSIONED N. C F ON EXITING FROM CONMIN,F WILL CONTAIN THE LOWEST C VALUE OF THE OBJECT FUNCTION OBTAINED. C F IS DOUBLE PRECISIONED. C G ON EXITING FROM CONMIN,G WILL CONTAIN THE C ELEMENTS OF THE GRADIENT OF F EVALUATED AT THE C POINT CONTAINED IN X. G MUST BE DOUBLE C PRECISIONED AND DIMENSIONED N. C IFUN UPON EXITING FROM CONMIN,IFUN CONTAINS THE C NUMBER OF TIMES THE FUNCTION AND GRADIENT C HAVE BEEN EVALUATED. C ITER UPON EXITING FROM CONMIN,ITER CONTAINS THE C TOTAL NUMBER OF SEARCH DIRECTIONS CALCULATED C TO OBTAIN THE CURRENT ESTIMATE TO THE MINIZER. C ACC ACC IS THE USER SUPPLIED CONVERGENCE PARAMETER. C CONVERGENCE OCCURS WHEN THE NORM OF THE GRADIENT C IS LESS THAN OR EQUAL TO ACC TIMES THE MAXIMUM C OF ONE AND THE NORM OF THE VECTOR X. EPS C MUST BE DOUBLE PRECISIONED. C NFLAG UPON EXITING FROM CONMIN,NFLAG STATES WHICH C CONDITION CAUSED THE EXIT. C IF NFLAG:0, THE ALGORITHM HAS CONVERGED. C IF NFLAG=1, THE MAXIMUM NUMBER OF FUNCTION C EVALUATIONS HAVE BEEN USED. C IF NFLAG=2, THE LINEAR SEARCH HAS FAILED TO C IMPROVE THE FUNCTION VALUE. THIS IS THE C USUAL EXIT IF EITHER THE FUNCTION OR THE C GRADIENT IS INCORRECTLY CODED. C IF NFLAG=3, THE SEARCH VECTOR WAS NOT C A DESCENT DIRECTION. THIS CAN ONLY BE CAUSED C BY ROUNDOFF,AND MAY SUGGEST THAT THE C CONVERGENCE CRITERION IS TOO STRICT. C MXFUN MXFUN IS THE USER SUPPLIED MAXIMUM NUMBER OF C FUNCTION AND GRADIENT CALLS THAT CONMIN WILL C BE ALLOWED TO MAKE. C W W IS A VECTOR OF WORKING STORAGE.IF NMETH=0, C W MUST BE DIMENSIONED 5*N+2. IF NMETH=1, C W MUST BE DIMENSIONED N*(N+7)/2. IN BOTH CASES, C W MUST BE DOUBLE PRECISIONED. C IOUT IOUT IS A USER SUPPLIED OUTPUT PARAMETER. C IF IOUT = 0, THERE IS NO PRINTED OUTPUT FROM C CONMIN. IF IOUT # 0,THE VALUE OF F AND THE C NORM OF THE GRADIENT SQUARED,AS WELL AS ITER C AND IFUN,ARE WRITTEN EVERY IOUT ITERATIONS. C MDIM MDIM IS THE USER SUPPLIED DIMENSION OF THE C VECTOR W. IF NMETH=0,MDIM=5*N+2. IF NMETH=1, C MDIM=N*(N+7)/2. C IDEV IDEV IS THE USER SUPPLIED NUMBER OF THE OUTPUT C DEVICE ON WHICH OUTPUT IS TO BE WRITTEN WHEN C IOUT#0. C EPS EPS IS A USER SUPPLIED ESTIMATE OF MACHINE C ACCURACY. A LINEAR SEARCH IS UNSUCCESSFULLY C TERMINATED WHEN THE NORM OF THE STEP SIZE C BECOMES SMALLER THAN EPS. IN PRACTICE, C EPS=10.D-20 HAS PROVED SATISFACTORY. EPS IS C DOUBLE PRECISIONED. C NMETH NMETH IS THE USER SUPPLIED VARIABLE WHICH C CHOOSES THE METHOD OF OPTIMIZATION. IF C NMETH=0,A CONJUGATE GRADIENT METHOD IS C USED. IF NMETH=1, THE BFGS METHOD IS USED. C C REMARKS= IN ADDITION TO THE SPECIFIED VALUES IN THE ABOVE C ARGUMENT LIST, THE USER MUST SUPPLY A SUBROUTINE C CALCFG WHICH CALCULATES THE FUNCTION AND GRADIENT AT C X AND PLACES THEM IN F AND G(1),...,G(N) RESPECTIVELY. C THE SUBROUTINE MUST HAVE THE FORM= C SUBROUTINE CALCFG(N,X,F,G) C DOUBLE PRECISION X(N),G(N),F C C AN EXAMPLE SUBROUTINE FOR THE ROSENBROCK FUNCTION IS= C C SUBROUTINE CALCFG(N,X,F,G) C DOUBLE PRECISION X(N),G(N),F,T1,T2 C T1=X(2)-X(1)*X(1) C T2=1.0-X(1) C F=100.0*T1*T1+T2*T2 C G(1)=-400.0*T1*X(1)-2.0*T2 C G(2)=200.0*T1 C RETURN C END C REAL FP,FMIN,ALPHA,AT,AP,GSQ,DG,DG1 C!!!! DOUBLE PRECISION FP,FMIN,ALPHA,AT,AP,GSQ,DG,DG1 REAL DP,STEP,DAL,U1,U2,U3,U4,EPS, ZZMPAR C!!!! DOUBLE PRECISION DP,STEP,DAL,U1,U2,U3,U4,EPS, ZZMPAR REAL RTST, SQRT, AMIN1, AMAX1, ABS C!!!! DOUBLE PRECISION RTST, DSQRT, DMIN1, DMAX1, DABS C REAL RW(1) DOUBLE PRECISION DW(1) INTEGER CASE, IW(1), IFUN, NX, NG, NRY, NRD, NCONS INTEGER NCONS1, NCONS2, NRST, I, NCALLS, IJ, J, NXPI, NGPI INTEGER NRDPI, NRYPI, NGPJ, II C LOGICAL RSW , LESS, FRSTPT C C INITIALIZE ITER,IFUN AND NFLAG WHICH COUNTS OUTPUT ITERATIONS. C IF(TRACES(1)) - WRITE(TUN,*)'CONMIN ',N,ACC,NFLAG,NMETH,MDIM,' EPS= ',EPS EPS = ZZMPAR(1) * 5.0 IFUN=0 C IOUTK=0 NFLAG=0 C C SET PARAMETERS TO EXTRACT VECTORS FROM W. C W(I) HOLDS THE SEARCH VECTOR,W(NX+I) HOLDS THE BEST CURRENT C ESTIMATE TO THE MINIMIZER,AND W(NG+I) HOLDS THE GRADIENT C AT THE BEST CURRENT ESTIMATE. C NX=N NG=NX+N C C TEST WHICH METHOD IS BEING USED. C IF NMETH=0, W(NRY+I) HOLDS THE RESTART Y VECTOR AND C W(NRD+I) HOLDS THE RESTART SEARCH VECTOR. C IF(NMETH.EQ.1)GO TO 10 NRY=NG+N NRD=NRY+N NCONS=5*N NCONS1=NCONS+1 NCONS2=NCONS+2 GO TO 20 C C IF NMETH=1,W(NCONS+I) HOLDS THE APPROXIMATE INVERSE HESSIAN. C 10 NCONS=3*N C C CALCULATETHE FUNCTION AND GRADIENT AT THE INITIAL C POINT AND INITIALIZE NRST,WHICH IS USED TO DETERMINE C WHETHER A BEALE RESTART IS BEING DONE. NRST=N MEANS THAT THIS C ITERATION IS A RESTART ITERATION. INITIALIZE RSW,WHICH INDICATES C THAT THE CURRENT SEARCH DIRECTION IS A GRADIENT DIRECTION. C 20 CASE = 0 CALL ZZEVAL(FUNCNM,N,X,F,G,CASE,IW,RW,DW) IFUN=IFUN+1 NRST=N RSW=.TRUE. C C CALCULATE THE INITIAL SEARCH DIRECTION , THE NORM OF X SQUARED, C AND THE NORM OF G SQUARED. DG1 IS THE CURRENT DIRECTIONAL C DERIVATIVE,WHILE XSQ AND GSQ ARE THE SQUARED NORMS. C GSQ = 0.0 DO 30 I=1,N GSQ = GSQ + G(I)*G(I) 30 CONTINUE CALL ZZCOPY ( N, G, 1, W, 1 ) CALL ZZSCAL ( N, -1.E0, W, 1 ) C!!!! CALL ZZSCAL ( N, -1.D0, W, 1 ) C C TEST IF THE INITIAL POINT IS THE MINIMIZER. C FRSTPT = .TRUE. CALL ZZTERM(FRSTPT,N,F,G,X,X,ACC,LESS) IF (LESS) RETURN DG1 = -GSQ C C BEGIN THE MAJOR ITERATION LOOP. NCALLS IS USED TO GUARANTEE THAT C AT LEAST TWO POINTS HAVE BEEN TRIED WHEN NMETH=0. FMIN IS THE C CURRENT FUNCTION VALUE. C 40 FMIN=F NCALLS=IFUN IF(TRACES(1))WRITE(TUN,*)'AT 40,D AND X ',W(1),W(2),X C C IF OUTPUT IS DESIRED,TEST IF THIS IS THE CORRECT ITERATION C AND IF SO, WRITE OUTPUT. C CALL ZZPRNT(N,X,F,G,SQRT(GSQ),1) C C BEGIN LINEAR SEARCH. ALPHA IS THE STEPLENGTH. C SET ALPHA TO THE NONRESTART CONJUGATE GRADIENT ALPHA. C 60 ALPHA=ALPHA*DG/DG1 C C IF NMETH=1 OR A RESTART HAS BEEN PERFORMED, SET ALPHA=1.0. C IF(NRST.EQ.1.OR.NMETH.EQ.1)ALPHA=1.0 C C IF IT IS THE FIRST ITERATION, SET ALPHA=1.0/DSQRT(GSQ), C WHICH SCALES THE INITIAL SEARCH VECTOR TO UNITY. C IF(RSW)ALPHA=1.0/ SQRT(GSQ) C!!!! IF(RSW)ALPHA=1.0/DSQRT(GSQ) C C THE LINEAR SEARCH FITS A CUBIC TO F AND DAL, THE FUNCTION AND ITS C DERIVATIVE AT ALPHA, AND TO FP AND DP,THE FUNCTION C AND DERIVATIVE AT THE PREVIOUS TRIAL POINT AP. C INITIALIZE AP ,FP,AND DP. C AP=0. FP=FMIN DP=DG1 C C SAVE THE CURRENT DERIVATIVE TO SCALE THE NEXT SEARCH VECTOR. C DG=DG1 C C UPDATE THE ITERATION. C C C CALCULATE THE CURRENT STEPLENGTH AND STORE THE CURRENT X AND G. C STEP=0. DO 70 I=1,N STEP=STEP+W(I)*W(I) NXPI=NX+I NGPI=NG+I W(NXPI)=X(I) 70 W(NGPI)=G(I) STEP= SQRT(STEP) C!!!! STEP=DSQRT(STEP) C C BEGIN THE LINEAR SEARCH ITERATION. C TEST FOR FAILURE OF THE LINEAR SEARCH. C IF(TRACES(1)) - WRITE(TUN,*)'BEFORE 80,STEP,DG,DP,FP,ALPHA,RSW= ', - STEP,DG,DP,FP,ALPHA,RSW IF(TRACES(1))WRITE(TUN,*)'ALSO,NCALLS,FMIN,GSQ,DG1 =', - NCALLS,FMIN,GSQ,DG1 80 IF(ALPHA*STEP.GT.EPS)GO TO 90 C C TEST IF DIRECTION IS A GRADIENT DIRECTION. C IF(.NOT.RSW)GO TO 20 NFLAG=2 RETURN C C CALCULATE THE TRIAL POINT. C 90 DO 100 I=1,N NXPI=NX+I 100 X(I)=W(NXPI)+ALPHA*W(I) IF(TRACES(1))WRITE(TUN,*)'AFTER 80=SEARCH',ALPHA,STEP,EPS,RSW,F, - FMIN,DAL,AT,AP,FP,DP C C EVALUATE THE FUNCTION AT THE TRIAL POINT. C CASE = 0 CALL ZZEVAL(FUNCNM,N,X,F,G,CASE,IW,RW,DW) IFUN = IFUN + 1 IF(TRACES(1))WRITE(TUN,*)'ZZEVAL GIVES F=',F,G(1),G(2) C C COMPUTE THE DERIVATIVE OF F AT ALPHA. C DAL=0.0 DO 120 I=1,N 120 DAL=DAL+G(I)*W(I) C C TEST WHETHER THE NEW POINT HAS A NEGATIVE SLOPE BUT A HIGHER C FUNCTION VALUE THAN ALPHA=0. IF THIS IS THE CASE,THE SEARCH C HAS PASSED THROUGH A LOCAL MAX AND IS HEADING FOR A DISTANT LOCAL C MINIMUM. C IF(F.GT.FMIN.AND.DAL.LT.0.)GO TO 160 C C IF NOT, TEST WHETHER THE STEPLENGTH CRITERIA HAVE BEEN MET. C IF(F.GT.(FMIN+.0001*ALPHA*DG).OR. ABS(DAL/DG) C!!!! IF(F.GT.(FMIN+.0001*ALPHA*DG).OR.DABS(DAL/DG) 1.GT.(.9))GO TO 130 C C IF THEY HAVE BEEN MET, TEST IF TWO POINTS HAVE BEEN TRIED C IF NMETH=0 AND IF THE TRUE LINE MINIMUM HAS NOT BEEN FOUND. C IF((IFUN-NCALLS).LE.1.AND. ABS(DAL/DG).GT.ACC.AND. C!!!! IF((IFUN-NCALLS).LE.1.AND.DABS(DAL/DG).GT.ACC.AND. 1NMETH.EQ.0)GO TO 130 GO TO 170 C C A NEW POINT MUST BE TRIED. USE CUBIC INTERPOLATION TO FIND C THE TRIAL POINT AT. C 130 U1=DP+DAL-3.0*(FP-F)/(AP-ALPHA) U2=U1*U1-DP*DAL IF(U2.LT.0.)U2=0. U2= SQRT(U2) C!!!! U2=DSQRT(U2) AT=ALPHA-(ALPHA-AP)*(DAL+U2-U1)/(DAL-DP+2.*U2) C C TEST WHETHER THE LINE MINIMUM HAS BEEN BRACKETED. C IF((DAL/DP).GT.0.)GO TO 140 C C THE MINIMUM HAS BEEN BRACKETED. TEST WHETHER THE TRIAL POINT LIES C SUFFICIENTLY WITHIN THE BRACKETED INTERVAL. C IF IT DOES NOT, CHOOSE AT AS THE MIDPOINT OF THE INTERVAL. C IF(AT.LT.(1.01*AMIN1(ALPHA,AP)).OR.AT.GT.(.99*AMAX1 C!!!! IF(AT.LT.(1.01*DMIN1(ALPHA,AP)).OR.AT.GT.(.99*DMAX1 1(ALPHA,AP)))AT=(ALPHA+AP)/2.0 GO TO 150 C C THE MINIMUM HAS NOT BEEN BRACKETED. TEST IF BOTH POINTS ARE C GREATER THAN THE MINIMUM AND THE TRIAL POINT IS SUFFICIENTLY C SMALLER THAN EITHER. C 140 CONTINUE IF(DAL .GT.0.0.AND.0.0.LT.AT.AND.AT.LT.(.99*AMIN1(AP,ALPHA))) C!!!! IF(DAL .GT.0.0.AND.0.0.LT.AT.AND.AT.LT.(.99*DMIN1(AP,ALPHA))) 1GO TO 150 C C TEST IF BOTH POINTS ARE LESS THAN THE MINIMUM AND THE TRIAL POINT C IS SUFFICIENTLY LARGE. C IF(DAL.LE.0.0.AND.AT.GT.(1.01*AMAX1(AP,ALPHA)))GO TO 150 C!!!! IF(DAL.LE.0.0.AND.AT.GT.(1.01*DMAX1(AP,ALPHA)))GO TO 150 C C IF THE TRIAL POINT IS TOO SMALL,DOUBLE THE LARGEST PRIOR POINT. C IF(DAL.LE.0.)AT=2.0*AMAX1(AP,ALPHA) C!!!! IF(DAL.LE.0.)AT=2.0*DMAX1(AP,ALPHA) C C IF THE TRIAL POINT IS TOO LARGE, HALVE THE SMALLEST PROIR POINT. C IF(DAL.GT.0.)AT=AMIN1(AP,ALPHA)/2.0 C!!!! IF(DAL.GT.0.)AT=DMIN1(AP,ALPHA)/2.0 C C SET AP=ALPHA, ALPHA=AT,AND CONTINUE SEARCH. C 150 AP=ALPHA FP=F DP=DAL ALPHA=AT GO TO 80 C C A RELATIVE MAX HAS BEEN PASSED.REDUCE ALPHA AND RESTART THE SEARCH. C 160 ALPHA=ALPHA/3. AP=0. FP=FMIN DP=DG GO TO 80 C C THE LINE SEARCH HAS CONVERGED. TEST FOR CONVERGENCE OF THE ALGORITHM. C 170 FRSTPT = .FALSE. CALL ZZTERM( FRSTPT,N,F,G,X,X,ACC,LESS ) GSQ = 0.0 DO 171 I = 1,N GSQ = GSQ + G(I)*G(I) 171 CONTINUE IF(TRACES(1))WRITE(TUN,*)'AFTER 170=ZZTERM ', LESS,ACC,G,X,ALPHA, - NMETH,GSQ,FMIN C IF(TRACES(1))WRITE(TUN,*)'ALSO ',NORM,TYPE IF( LESS )RETURN C C SEARCH CONTINUES. SET W(I)=ALPHA*W(I),THE FULL STEP VECTOR. C CALL ZZSCAL ( N, ALPHA, W, 1 ) C C COMPUTE THE NEW SEARCH VECTOR. FIRST TEST WHETHER A C CONJUGATE GRADIENT OR A VARIABLE METRIC VECTOR IS USED. C COMPUTE THE NEW SEARCH VECTOR. FIRST TEST WHETHER A C CONJUGATE GRADIENT OR A VARIABLE METRIC VECTOR IS USED. C IF(NMETH.EQ.1)GO TO 330 C C CONJUGATE GRADIENT UPDATE SECTION. C TEST IF A POWELL RESTART IS INDICATED. C RTST=0. DO 200 I=1,N NGPI=NG+I 200 RTST=RTST+G(I)*W(NGPI) IF( ABS(RTST/GSQ).GT.0.2)NRST=N C!!!! IF(DABS(RTST/GSQ).GT.0.2)NRST=N C C IF A RESTART IS INDICATED, SAVE THE CURRENT D AND Y C AS THE BEALE RESTART VECTORS AND SAVE D@Y AND Y@Y C IN W(NCONS+1) AND W(NCONS+2). C IF(NRST.NE.N)GO TO 220 IF(TRACES(1)) - WRITE(TUN,*)'RESTART, ABS(RTST/GSQ),N ', ABS(RTST/GSQ),N C!!!!- WRITE(TUN,*)'RESTART,DABS(RTST/GSQ),N ',DABS(RTST/GSQ),N W(NCONS+1)=0. W(NCONS+2)=0. DO 210 I=1,N NRDPI=NRD+I NRYPI=NRY+I NGPI=NG+I W(NRYPI)=G(I)-W(NGPI) W(NRDPI)=W(I) W(NCONS1)=W(NCONS1)+W(NRYPI)*W(NRYPI) 210 W(NCONS2)=W(NCONS2)+W(I)*W(NRYPI) C C CALCULATE THE RESTART HESSIAN TIMES THE CURRENT GRADIENT. C 220 U1=0.0 U2=0.0 DO 230 I=1,N NRDPI=NRD+I NRYPI=NRY+I U1=U1-W(NRDPI)*G(I)/W(NCONS1) 230 U2=U2+W(NRDPI)*G(I)*2./W(NCONS2)-W(NRYPI)*G(I)/W(NCONS1) U3=W(NCONS2)/W(NCONS1) DO 240 I=1,N NXPI=NX+I NRDPI=NRD+I NRYPI=NRY+I 240 W(NXPI)=-U3*G(I)-U1*W(NRYPI)-U2*W(NRDPI) IF(TRACES(1))WRITE(TUN,*)'RESTART SEARCH VECTOR',W(NX+1),W(NX+2) C C IF THIS IS A RESTART ITERATION,W(NX+I) CONTAINS THE NEW SEARCH C VECTOR. C IF(NRST.EQ.N)GO TO 300 C C NOT A RESTART ITERATION. CALCULATE THE RESTART HESSIAN C TIMES THE CURRENT Y. C U1=0. U2=0. U3=0. U4=0. DO 260 I=1,N NGPI=NG+I NRDPI=NRD+I NRYPI=NRY+I U1=U1-(G(I)-W(NGPI))*W(NRDPI)/W(NCONS1) U2=U2-(G(I)-W(NGPI))*W(NRYPI)/W(NCONS1) 1 +2.0*W(NRDPI)*(G(I)-W(NGPI))/W(NCONS2) 260 U3=U3+W(I)*(G(I)-W(NGPI)) STEP=0. DO 270 I=1,N NGPI=NG+I NRDPI=NRD+I NRYPI=NRY+I STEP=(W(NCONS2)/W(NCONS1))*(G(I)-W(NGPI)) 1 +U1*W(NRYPI)+U2*W(NRDPI) U4=U4+STEP*(G(I)-W(NGPI)) 270 W(NGPI)=STEP C C CALCULATE THE DOUBLY UPDATED HESSIAN TIMES THE CURRENT C GRADIENT TO OBTAIN THE SEARCH VECTOR. C U1=0.0 U2=0.0 DO 280 I=1,N U1=U1-W(I)*G(I)/U3 NGPI=NG+I 280 U2=U2+(1.0+U4/U3)*W(I)*G(I)/U3-W(NGPI)*G(I)/U3 DO 290 I=1,N NGPI=NG+I NXPI=NX+I 290 W(NXPI)=W(NXPI)-U1*W(NGPI)-U2*W(I) IF(TRACES(1))WRITE(TUN,*)'NOT RESTART,DIRECTION',W(NX+1),W(NX+2),N C C CALCULATE THE DERIVATIVE ALONG THE NEW SEARCH VECTOR. C 300 DG1=0. DO 310 I=1,N NXPI=NX+I W(I)=W(NXPI) 310 DG1=DG1+W(I)*G(I) IF(TRACES(1))WRITE(TUN,*)'AFTER 300,D,DG1 =',W(NX+1),W(NX+2),DG1 C C IF THE NEW DIRECTION IS NOT A DESCENT DIRECTION,STOP. C IF (DG1.GT.0.)GO TO 320 C C UPDATE NRST TO ASSURE AT LEAST ONE RESTART EVERY N ITERATIONS. C IF(NRST.EQ.N)NRST=0 NRST=NRST+1 RSW=.FALSE. IF(TRACES(1))WRITE(TUN,*)'DG1 LT.0,NRST,RSW ',DG1,NRST,RSW GO TO 40 C C ROUNDOFF HAS PRODUCED A BAD DIRECTION. C 320 NFLAG=3 RETURN C C A VARIABLE METRIC ALGORITM IS BEING USED. CALCULATE Y AND D@Y. C 330 U1=0.0 DO 340 I=1,N NGPI=NG+I W(NGPI)=G(I)-W(NGPI) 340 U1=U1+W(I)*W(NGPI) C C IF RSW=.TRUE.,SET UP THE INITIAL SCALED APPROXIMATE HESSIAN. C IF(.NOT.RSW)GO TO 380 C C CALCULATE Y@Y. C U2=0. DO 350 I=1,N NGPI=NG+I 350 U2=U2+W(NGPI)*W(NGPI) C C CALCULATE THE INITIAL HESSIAN AS H=(P@Y/Y@Y)*I C AND THE INITIAL U2=Y@HY AND W(NX+I)=HY. C IJ=1 U3=U1/U2 DO 370 I=1,N DO 360 J=I,N NCONS1=NCONS+IJ W(NCONS1)=0.0 IF(I.EQ.J)W(NCONS1)=U3 360 IJ=IJ+1 NXPI=NX+I NGPI=NG+I 370 W(NXPI)=U3*W(NGPI) U2=U3*U2 GO TO 430 C C CALCULATE W(NX+I)=HY AND U2=Y@HY. C 380 U2=0.0 DO 420 I=1,N U3=0.0 IJ=I IF(I.EQ.1)GO TO 400 II=I-1 DO 390 J=1,II NGPJ=NG+J NCONS1=NCONS+IJ U3=U3+W(NCONS1)*W(NGPJ) 390 IJ=IJ+N-J 400 DO 410 J=I,N NCONS1=NCONS+IJ NGPJ=NG+J U3=U3+W(NCONS1)*W(NGPJ) 410 IJ=IJ+1 NGPI=NG+I U2=U2+U3*W(NGPI) NXPI=NX+I 420 W(NXPI)=U3 C C CALCULATE THE UPDATED APPROXIMATE HESSIAN. C 430 U4=1.0+U2/U1 DO 440 I=1,N NXPI=NX+I NGPI=NG+I 440 W(NGPI)=U4*W(I)-W(NXPI) IJ=1 DO 450 I=1,N NXPI=NX+I U3=W(I)/U1 U4=W(NXPI)/U1 DO 450 J=I,N NCONS1=NCONS+IJ NGPJ=NG+J W(NCONS1)=W(NCONS1)+U3*W(NGPJ)-U4*W(J) 450 IJ=IJ+1 C C CALCULATE THE NEW SEARCH DIRECTION W(I)=-HG AND ITS DERIVATIVE. C DG1=0.0 DO 490 I=1,N U3=0.0 IJ=I IF(I.EQ.1)GO TO 470 II=I-1 DO 460 J=1,II NCONS1=NCONS+IJ U3=U3-W(NCONS1)*G(J) 460 IJ=IJ+N-J 470 DO 480 J=I,N NCONS1=NCONS+IJ U3=U3-W(NCONS1)*G(J) 480 IJ=IJ+1 DG1=DG1+U3*G(I) 490 W(I)=U3 C C TEST FOR A DOWNHILL DIRECTION. C IF(DG1.GT.0.)GO TO 320 RSW=.FALSE. GO TO 40 END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> cubcsg.f SUBROUTINE BBCUBC ( T, F, FP, TA, FA, FPA, LEFT, RIGHT, X, INTER ) C## A R G U M E N T S: LOGICAL INTER REAL T,F,FP,TA,FA,FPA,LEFT,RIGHT,X C!!!! DOUBLE PRECISION T,F,FP,TA,FA,FPA,LEFT,RIGHT,X C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: CUBC.F,V 1.11 91/11/22 11:27:36 BUCKLEY EXP $ C>RCS $LOG: CUBC.F,V $ C>RCS REVISION 1.11 91/11/22 11:27:36 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.10 90/07/31 10:49:13 BUCKLEY C>RCS ADDED REVISED BLAS. C>RCS C>RCS REVISION 1.9 89/06/30 13:25:08 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 17:15:26 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 12:39:13 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:55:18 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:54:26 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C GIVEN THE POINTS T AND TA, ALONG WITH THE FUNCTION VALUES C F AND FA AND SLOPES FP AND FPA AT EACH POINT, THIS ROUTINE C FINDS THE POINT X AT WHICH THE CUBIC FITTED TO THE DATA C HAS ITS MINIMUM. THE VALUES LEFT AND RIGHT DEFINE AN C INTERVAL. IF THERE IS NO MINIMUM OR IF IT LIES OUTSIDE THE C INTERVAL, X IS RETURNED AS ONE OF THE END POINTS, AS APPROPRIATE. C INTER IS RETURNED AS TRUE IF THE VALUE X RETURNED IS EQUAL TO C THAT OBTAINED FROM THE FORMULA INTERPOLATION. THE INTERPOLATION C IS COMPUTED FOLLOWING DETAILS GIVEN BY LEMARECHAL. C C## E N T R Y P O I N T S: BBCUBC THE NATURAL ENTRY C BBSCUB TO SET THE TRACE. C C## S U B R O U T I N E S: C C ABS, DBLE(REAL), MAX, MIN, SQRT... INTRINSIC C RD... A STATEMENT FUNCTION C C## P A R A M E T E R S: REAL ZERO, ONE, TWO, THREE C!!!! DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) REAL FOUR, FIVE, SIX, SEVEN C!!!! DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) REAL EIGHT, NINE, TEN C!!!! DOUBLE PRECISION EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 9D0, TEN = 10D0 ) INTEGER XEPS, XSMALL, XBIG PARAMETER ( XEPS = 1, XSMALL = 2, XBIG = 3 ) C## L O C A L D E C L: INTEGER TRU, STRU LOGICAL EXTREM, TRACE, STRACE, ORDER, ABIGGR, FIRST, PBIGGR REAL P, DISC, DUMMY C!!!! DOUBLE PRECISION P, DISC, DUMMY REAL SGN, APR, BPR, NUM, XC, RD, EPS, BIGGST, ZZMPAR C!!!! DOUBLE PRECISION SGN, APR, BPR, NUM, XC, RD, EPS, BIGGST, ZZMPAR REAL ALEFT, ARIGHT C!!!! DOUBLE PRECISION ALEFT, ARIGHT C## S A V E: SAVE TRU, TRACE, EPS, FIRST C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA TRU/6/, TRACE/.FALSE./, FIRST/.TRUE./ C## E X E C U T I O N C## E X E C U T I O N C---- A STATEMENT FUNCTION. RD(DUMMY) = REAL(DUMMY) C!!!! RD(DUMMY) = DBLE(DUMMY) C---- IF ( FIRST ) THEN EPS = SQRT(ZZMPAR(XBIG)) FIRST = .FALSE. ENDIF ALEFT = MIN(LEFT, RIGHT) ARIGHT = MAX(LEFT, RIGHT) IF ( TRACE ) THEN WRITE (TRU,*) ' [CUBC] T,F,FP, TA,FA,FPA->', T,F,FP, TA,FA,FPA WRITE (TRU,*) ' [CUBC] INTERVAL [',ALEFT,',',ARIGHT,']' ENDIF EXTREM = .FALSE. ORDER = LEFT .LE. RIGHT .EQV. T .LE. TA SGN = SIGN(ONE,TA-T) IF (TRACE) WRITE(TRU,*) ' [CUBC] ORDER->',ORDER,' SGN->',SGN IF ( T .EQ. TA ) THEN IF (TRACE) WRITE(TRU,*) ' [CUBC] POINTS EQUAL.' X = T INTER = .FALSE. ELSE P = DBLE(FP) + DBLE(FPA) - DBLE(THREE)*DBLE(FA-F)/DBLE(TA-T) IF ( SIGN(ONE,FPA) .NE. SIGN(ONE,FP) ) THEN DISC = DBLE(ONE) - (DBLE(FP)/P)*(DBLE(FPA/P)) DISC = ABS(P)*SQRT(DISC) ELSE IF (TRACE) WRITE(TRU,*) ' [CUBC] SIGN(FP)=SIGN(FPA).' BIGGST = MAX(ABS(FP),ABS(FPA),ABS(P)) ABIGGR = BIGGST .EQ. ABS(FPA) PBIGGR = BIGGST .EQ. ABS( P ) IF(TRACE)WRITE(TRU,*) ' [CUBC] P,BIGGST,EPS->',P,BIGGST,EPS IF (BIGGST .LE. EPS) THEN DISC = DBLE(P**2) - DBLE(FP)*DBLE(FPA) IF (TRACE) WRITE(TRU,*) ' [CUBC] P,DISC->', P, DISC ELSE IF ( PBIGGR ) THEN DISC = DBLE(P) - (DBLE(FPA)/DBLE(P))*DBLE(FP) ELSE IF ( ABIGGR ) THEN DISC = (DBLE(P)/DBLE(FPA))*DBLE(P) - DBLE(FP) ELSE DISC = (DBLE(P)/DBLE(FP))*DBLE(P) - DBLE(FPA) ENDIF IF (TRACE) WRITE(TRU,*) ' [CUBC] DISC->', DISC IF ( DISC .GE. 0 ) THEN IF (BIGGST .LE. EPS) THEN DISC = SQRT(DISC) ELSE DISC = SQRT(DISC)*SQRT(BIGGST) ENDIF IF (TRACE) WRITE(TRU,*) ' [CUBC] DISC->', DISC ELSE INTER = .FALSE. IF ( FP .LT. ZERO ) THEN X = ARIGHT ELSE X = ALEFT ENDIF IF (TRACE) WRITE(TRU,*) ' [CUBC] NO MINIMUM!' GOTO 90000 ENDIF ENDIF DISC = SGN*DISC IF (TRACE) WRITE(TRU,*) ' [CUBC] DISC->',DISC APR = DBLE(FP) + DBLE(FPA) + DBLE(TWO*P) BPR = DBLE(FP) + DBLE(P) IF (TRACE) WRITE(TRU,*) ' [CUBC] APR,BPR->',APR,BPR IF ( SGN*BPR .LT. ZERO ) THEN IF (TRACE) WRITE(TRU,*) ' [CUBC] USING REGULAR FORM.' X = T + FP*(TA-T)/RD(BPR-DISC) IF (TRACE) WRITE(TRU,*) ' [CUBC] PREDICT X->',X ELSE NUM = DISC + BPR IF (TRACE) WRITE(TRU,*) ' [CUBC] USING ALTERNATE FORM.' IF (TRACE) WRITE(TRU,*) ' [CUBC] NUM->',NUM IF ( ABS((T-TA)*NUM) .GE. (ARIGHT-ALEFT)*ABS(APR) ) THEN X = ARIGHT EXTREM = .TRUE. IF (TRACE) WRITE(TRU,*) ' [CUBC] CUT OFF TO X->',X ELSE X = T + NUM*(TA-T)/APR IF (TRACE) WRITE(TRU,*) ' [CUBC] PREDICT X->',X ENDIF ENDIF XC = X X = MAX(X,ALEFT ) X = MIN(X,ARIGHT) INTER = .NOT. EXTREM .AND. XC .EQ. X IF (TRACE) WRITE(TRU,*) ' [CUBC] X,XC,INTER,EXTREM->', - X,XC,INTER,EXTREM ENDIF GOTO 90000 C## E N T R Y BBSCUB: ENTRY BBSCUB (STRACE,STRU) TRACE = STRACE TRU = STRU RETURN C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF BBCUBC. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> dfltsg.f SUBROUTINE BBDFLT ( PFREQ, MAXF ) C## A R G U M E N T S: INTEGER PFREQ, MAXF C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: DFLT.F,V 1.12 91/12/31 14:52:48 BUCKLEY EXP $ C>RCS $LOG: DFLT.F,V $ C>RCS REVISION 1.12 91/12/31 14:52:48 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.11 91/11/22 11:28:33 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.10 90/07/31 10:49:33 BUCKLEY C>RCS ADDED REVISED BLAS. C>RCS C>RCS REVISION 1.9 89/06/30 13:12:45 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3 89/05/18 12:39:15 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:55:21 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:54:27 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE FIRST OBTAINS THE DEFAULT VALUES FOR INITIALIZING C THE ROUTINES ZZPRNT, ZZEVAL, ZZTERM AND BBLNIR. IT THEN C CALLS ENTRY POINTS IN EACH OF THESE ROUTINES TO SET THE INITIAL C VALUES NEEDED IN THOSE ROUTINES TO THOSE DEFAULT VALUES. C C## E N T R Y P O I N T S: THE NATURAL ENTRY BBDFLT C C## S U B R O U T I N E S: C C BBVALS TO OBTAIN THE DEFAULT VALUES C ZZP1ST ZZP2ST ENTRY POINTS TO ZZPRNT C ZZTSET ZZESET ZZESRT: ENTRY POINTS TO ZZTERM, ZZEVAL C BBLSET ENTRY POINT TO BBLNIR. C C## P A R A M E T E R S: INTEGER NL1, NL2, NLINF PARAMETER ( NL1 = 1, NL2 = 2, NLINF = 3 ) INTEGER NQUITS PARAMETER ( NQUITS = 4 ) INTEGER PGRAD, PSTEP, PSHXG, PFUNC PARAMETER ( PGRAD = 1, PSTEP = 2, PSHXG = 3, PFUNC = 4 ) INTEGER NINTS, NLOGS, NREALS, NTRACF PARAMETER ( NINTS = 14, NLOGS = 32, NREALS = 2, NTRACF = 15 ) INTEGER XDRVMD, XNORM, XSCALE, XLTRCU PARAMETER ( XDRVMD = 1, XNORM = 2, XSCALE = 3, XLTRCU = 4 ) INTEGER XETRCU, XPTRCU, XTTRCU PARAMETER ( XETRCU = 5, XPTRCU = 6, XTTRCU = 7 ) INTEGER XMETH, XQUADN, XALPS1, XSCGMM PARAMETER ( XMETH = 8, XQUADN = 9, XALPS1 = 10, XSCGMM = 11 ) INTEGER XHTEST, XUPDTT, XSTSTP PARAMETER ( XHTEST = 12,XUPDTT = 13, XSTSTP = 14 ) INTEGER XTRACE PARAMETER ( XTRACE = 1 ) INTEGER XTRF, XTRG, XTTRCE, XTRTST PARAMETER ( XTRF = 16, XTRG = 17, XTTRCE = 18, XTRTST = 19 ) INTEGER XGRAD, XPOINT, XTGRAD PARAMETER ( XGRAD = 20, XPOINT = 21, XTGRAD = 22 ) INTEGER XTSTEP, XTSHXG, XTFUNC, XRELF PARAMETER ( XTSTEP = 23,XTSHXG = 24, XTFUNC = 25, XRELF = 26 ) INTEGER XRELG, XFQUAD, XDIAGL PARAMETER ( XRELG = 27, XFQUAD = 28, XDIAGL = 29 ) INTEGER XSHNNO, XFRMRS, XFRCEF PARAMETER ( XSHNNO = 30,XFRMRS = 31, XFRCEF = 32 ) INTEGER XRO, XBETA PARAMETER ( XRO = 1, XBETA = 2 ) C## L O C A L D E C L: CHARACTER*(NQUITS) TESTS INTEGER INTS(NINTS) LOGICAL LOGS(NLOGS) REAL REALS(NREALS) C!!!! DOUBLE PRECISION REALS(NREALS) C## S A V E: NONE SELECTED. C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NONE ARE SET. C## E X E C U T I O N C## E X E C U T I O N C-----OBTAIN DEFAULTS. CALL BBVALS ( INTS, LOGS, REALS ) C-ZZEVAL. CALL ZZESET ( LOGS(XTRF),LOGS(XTRG),LOGS(XTRTST),INTS(XETRCU)) CALL ZZESRT ( INTS(XSCALE), INTS(XDRVMD), MAXF, 1 ) C-ZZPRNT. CALL ZZP1ST (INTS(XPTRCU),LOGS(XGRAD),LOGS(XPOINT), PFREQ ) CALL ZZP2ST (INTS(XPTRCU),LOGS(XGRAD),LOGS(XPOINT),0,.FALSE.,0) C-ZZTERM. TESTS = 'FFFF' IF (LOGS(XTGRAD)) TESTS(PGRAD:PGRAD) = 'T' IF (LOGS(XTSTEP)) TESTS(PSTEP:PSTEP) = 'T' IF (LOGS(XTSHXG)) TESTS(PSHXG:PSHXG) = 'T' IF (LOGS(XTFUNC)) TESTS(PFUNC:PFUNC) = 'T' CALL ZZTSET ( INTS(XNORM), TESTS, LOGS(XTTRCE), INTS(XTTRCU) ) C-BBLNIR. CALL BBLSET ( INTS(XMETH), INTS(XQUADN), INTS(XALPS1), - INTS(XSTSTP), INTS(XSCGMM), INTS(XHTEST), - INTS(XUPDTT), - REALS(XRO), REALS(XBETA), - LOGS(XFQUAD), LOGS(XDIAGL), LOGS(XSHNNO), - LOGS(XFRMRS), LOGS(XFRCEF), LOGS(XRELF), - LOGS(XRELG), - INTS(XLTRCU), LOGS(XTRACE) ) GOTO 90000 C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF BBDFLT. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> inihsg.f SUBROUTINE BBINIH ( N, X, G, H, NRMG, IDENTY, SCDIAG, UPDATT, - INNER, IW, RW, DW ) C## A R G U M E N T S: INTEGER N, UPDATT, IW(*) LOGICAL IDENTY, SCDIAG REAL X(N), G(N), H(N), NRMG C!!!! DOUBLE PRECISION X(N), G(N), H(N), NRMG EXTERNAL INNER DOUBLE PRECISION INNER, DW(*) REAL RW(*) C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C>RCS $HEADER: INIH.F,V 1.12 91/12/31 14:52:50 BUCKLEY EXP $ C>RCS $LOG: INIH.F,V $ C>RCS REVISION 1.12 91/12/31 14:52:50 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.11 91/11/19 15:34:56 BUCKLEY C>RCS FINAL SUBMISSION FOR TOMS C>RCS C>RCS REVISION 1.10 90/07/31 10:49:39 BUCKLEY C>RCS ADDED REVISED BLAS. C>RCS C>RCS REVISION 1.9 89/06/30 13:12:47 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3 89/05/18 12:39:17 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:55:24 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:54:27 BUCKLEY C>RCS INITIAL REVISION C>RCS C## D E S C R I P T I O N: C C THE PURPOSE OF THIS ROUTINE IS TO DEFINE THE INITIAL C MATRIX H[0]. THIS IS STORED IN THE FIRST N LOCATIONS OF THE C ARRAY H AND DEFINES A DIAGONAL MATRIX. C C TO BE MORE SPECIFIC, A DIAGONAL MATRIX H IS DEFINED WITH C ELEMENTS H(1,1), H(2,2), ... , H(N,N), BUT FOR STORAGE C CONVENIENCE, H IS ACTUALLY DEFINED AS A VECTOR OF N ELEMENTS C AND THESE N VALUES ARE STORED IN H(1),...,H(N). C C NOTE THAT, IF SCDIAG IS FALSE ON ENTRY, THEN H IS CHOSEN C TO BE THE IDENTITY AND NO VALUES ARE STORED IN THE ENTRIES OF H. C WHEN H IS THE IDENTITY, IDENTY IS SET TO TRUE. C C IF FACTORED FORM UPDATING IS BEING DONE, THEN THE SQUARE ROOTS C OF THE DIAGONAL ELEMENTS ARE STORED, SINCE THEY ARE THE ELEMENTS C OF Z, AND ZZ^T=H. C C ON ENTRY, THE CURRENT POINT X AND THE GRADIENT G AT X C MUST BE DEFINED, ALONG WITH THE 2-NORM (NRMG) OF G. C C BOTH X AND G ARE USED TO COMPUTE THE DIAGONAL SCALING C ENTRIES OF H. NRMG, THE NORM OF G, MAY BE USED AS WELL. C THE SCALING USED IS QUITE PRIMITIVE AND NOT C PARTICULARLY TO BE RECOMMENDED. THE MAIN POINT IS THAT THE C FACILITY IS AVAILABLE, AND ANYONE SO DESIRING CAN EASILY C IMPLEMENT THEIR OWN SCALING. THE DEFAULT IS THAT SCDIAG IS C FALSE, SO NO SCALING IS DONE. C C NOTE THAT INNER IS AVAILABLE, WHICH NEEDS IW, RW AND DW. IT CAN C BE USED TO COMPUTE ANY REQUIRED INNER PRODUCTS. IT IS UNUSED IN C THE CURRENT VERSION. C C## E N T R Y P O I N T S: BBINIH THE NATURAL ENTRY POINT. C## S U B R O U T I N E S: ABS INTRINSIC FUNCTION. C INNER INNER PRODUCT (ARGUMENT) C## P A R A M E T E R S: LOGICAL DONORM, NONORM PARAMETER ( DONORM = .TRUE., NONORM = .FALSE. ) INTEGER SUMFRM, PRDFRM, MJDFRM PARAMETER ( SUMFRM = 1, PRDFRM = 2, MJDFRM = 3 ) REAL ZERO, ONE, TWO, THREE C!!!! DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) REAL FOUR, FIVE, SIX, SEVEN C!!!! DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) REAL EIGHT, NINE, TEN C!!!! DOUBLE PRECISION EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 9D0, TEN = 10D0 ) C## L O C A L D E C L: INTEGER J C## S A V E: NONE SELECTED. C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NO DATA VALUES SET. C## E X E C U T I O N C## E X E C U T I O N IDENTY = .NOT. SCDIAG IF ( SCDIAG ) THEN C DEFINE DIAGONAL SCALING MATRIX. DO 1200 J=1,N IF ( G(J) .NE. ZERO ) THEN H(J) = ABS (X(J)/G(J)) ELSE H(J) = ABS (X(J)) ENDIF IF ( UPDATT .EQ. MJDFRM ) THEN H(J) = SQRT (H(J)) ENDIF 1200 CONTINUE ENDIF GOTO 90000 C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF BBINIH. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> linssg.f SUBROUTINE BBLINS (ALPHA, FV, DG, VALIDF, F0, DG0, AP, FP, DGP, - WIDTH, NOUPS, LSDONE, CT, NCALLS, QUADON ) C## A R G U M E N T S: LOGICAL NOUPS, LSDONE, QUADON, VALIDF INTEGER CT, NCALLS REAL FV, DG, ALPHA, F0, DG0, DGP, FP, AP, WIDTH C!!!! DOUBLE PRECISION FV, DG, ALPHA, F0, DG0, DGP, FP, AP, WIDTH C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: LINS.F,V 1.12 91/12/16 11:25:08 BUCKLEY EXP $ C>RCS $LOG: LINS.F,V $ C>RCS REVISION 1.12 91/12/16 11:25:08 BUCKLEY C>RCS MINOR FIX FOR TOMS. C>RCS C>RCS REVISION 1.11 91/11/22 11:29:58 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.10 90/07/31 10:49:45 BUCKLEY C>RCS ADDED REVISED BLAS. C>RCS C>RCS REVISION 1.9 89/06/30 13:27:36 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 17:15:29 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 12:39:18 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:55:26 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:54:27 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE PERFORMS ONE INTERNAL ITERATION OF THE LINE SEARCH. C C FIRST, NOTE THAT THE EXECUTION OF THIS ROUTINE IS VERY MUCH C INFLUENCED BY A NUMBER OF VARIABLES WHICH APPEAR IN THE C CALLING ROUTINE BBLNIR. FOR EACH MINIMIZATION PROBLEM, C THESE VALUES ARE DETERMINED ONCE AT THE BEGINNING OF BBLNIR C AND THEN DEFINED HERE BY CALLING AN ENTRY POINT BBLSST. C THEY DO NOT CHANGE FOR THE SERIES OF CALLS MADE TO BBLINS C FROM BBLNIR. C C THE VARIABLES SET THROUGH THE ENTRY POINT BBLSST HAVE THE C FOLLOWING MEANINGS: C C M THE NUMBER OF UPDATES ALLOWED. C ACC THE ACCURACY REQUIRED IN THE SOLUTION. C CG A FLAG WHICH IS TRUE WHEN A CONJUGATE GRADIENT C ALGORITHM IS IN USE (WHICH INVOLVES BOTH CG C AND QN STEPS) AND WHICH IS FALSE WHEN THERE IS C ENOUGH STORAGE TO USE A FULL QUASI-NEWTON METHOD. C USESHN THE SAME FLAG AS USESHN SET IN THE ENTRY C POINT BBLSET IN BBLNIR. C QUADIN THE SAME VALUE AS QUADIN SET IN THE ENTRY C POINT BBLSET IN BBLNIR. C LMSTQN A SPECIAL FLAG SET WHEN METH = 10000 AS DESCRIBED C IN BBLNIR. C FQUAD A FLAG SET WITH REGARDS TO THE FORCING OF A QUAD- C RATIC INTERPOLATION, AS DESCRIBED IN BBLNIR. C TR4, TR5, TR6 THREE TRACE FLAGS DESCRIBED IN BBLNIR. C TRU THE UNIT FOR TRACE OUTPUT, AS DESCRIBED IN BBLNIR. C C ALL THOSE QUANTITIES WHICH VARY FROM ITERATION TO ITERATION C WITHIN THE LINE SEARCH ARE PASSED IN THE MAIN CALLING C SEQUENCE TO BBLINS. WHAT THESE ARE, AND WHAT THIS ROUTINE DOES, C ARE THE FOLLOWING: C C ASSUME THAT THE CURRENT SEARCH IS ALONG A DIRECTION D FROM C A STARTING POINT X-BEG, AND THAT THE CURRENT POINT ALONG C THAT LINE IS X. ASSUME THAT THE PREVIOUS POINT CONSIDERED C ALONG THIS LINE WAS X-PREV; THUS, ON THE FIRST CALL FOR A C LINE SEARCH ALONG A GIVEN DIRECTION D FROM A POINT X-BEG, C X-PREV IS JUST X-BEG. THEN, ON ENTRY TO BBLINS: C C ALPHA IS THE STEP LENGTH TO X (SO X IS X-BEG + ALPHA*D). C FV IS THE FUNCTION VALUE AT X. C DG IS THE INNER PRODUCT OF D AND THE GRADIENT AT X. C VALIDF IS TRUE IF F AND DG ARE DEFINED AT ALPHA. C C F0 IS THE FUNCTION VALUE AT X-BEG. C DG0 IS THE INNER PRODUCT OF D AND THE GRADIENT AT X-BEG. C C AP IS ALPHA AT X-PREV. C FP IS THE FUNCTION VALUE AT THE PREVIOUS POINT X-PREV. C DGP IS THE INNER PRODUCT OF D AND THE GRADIENT AT X-PREV. C C NOUPS IS A FLAG WHICH IS TRUE ONLY WHEN A CG ALGORITHM HAS C BEEN CHOSEN AND WHEN NO UPDATES ARE BEING STORED. C C NCALLS IS A COUNT OF HOW MANY TIMES THE FUNCTION HAS BEEN C EVALUATED ALONG THIS DIRECTION D, INCLUDING THE C EVALUATION AT X, BUT NOT INCLUDING THE EVALUATION C AT X-BEG. C C QUADON IS INITIALLY FALSE, BUT IT IS SET TO TRUE WHEN A C POINT IS COMPUTED VIA INTERPOLATION AND ACCEPTED AS C THE NEXT TRIAL POINT. THIS IS USED TO PREVENT TERMIN- C ATION WITHOUT HAVING DONE AN INTERPOLATION. C C CT IS THE ITERATION NUMBER OF THE CURRENT DIRECTION D C AND OF THE POINT TO BE REACHED, NAMELY X. C C ON EXIT FROM BBLINS, THE FOLLOWING ARE DEFINED: C C LSDONE WILL BE RETURNED AS TRUE IF THE VALUE ALPHA INPUT C TO BBLINS DEFINES A POINT AT WHICH THE LINE SEARCH CAN C BE TERMINATED. OTHERWISE IT SHOULD BE RETURNED AS FALSE C AND A NEW TRIAL VALUE FOR ALPHA DETERMINED. C C WIDTH IS THE WIDTH OF THE INTERVAL BOUNDING AN ACCEPTABLE C VALUE OF ALPHA. IF NO UPPER BOUND IS KNOWN, WIDTH IS C THE DISTANCE BETWEEN THE CURRENT ALPHA AND THE LOWER C BOUND. C C ALPHA IF LSDONE IS FALSE, THIS CONTAINS THE NEXT VALUE C OF ALPHA TO BE CONSIDERED. IN THIS CASE, THE VALUES C FOR AP, DGP AND FP SHOULD HAVE BEEN UPDATED. C C AP, DGP, FP IF LSDONE IS FALSE, AND A NEW VALUE IS C DEFINED IN ALPHA, THEN THE "PREVIOUS" POINT BECOMES THE C POINT JUST CALCULATED, SO FP, DGP AND AP SHOULD BE C REDEFINED AS THE VALUES F, DG AND ALPHA INPUT TO C THIS ROUTINE. C NOTE THAT THESE VALUES ARE *NOT* UPDATED IF THERE WERE C NO VALID FUNCTION OR GRADIENT VALUES AT THE PREVIOUS C POINT. C C## E N T R Y P O I N T S: BBLINS ... THE NATURAL ENTRY POINT. C BBSLNS ... INITIALIZE FIXED ARGUMENTS. C C## S U B R O U T I N E S: BBCUBC FOR CUBIC INTERPOLATION. C C## P A R A M E T E R S: LOGICAL T, F PARAMETER ( T = .TRUE., F = .FALSE. ) CHARACTER*(*) TRUE, QT, FALSE, QF PARAMETER ( TRUE = 'TRUE', QT = 'T', FALSE = 'FALSE', QF = 'F' ) INTEGER ITRUE, IFALSE PARAMETER ( ITRUE = 1, IFALSE = 0 ) REAL RTRUE, RFALSE C!!!! DOUBLE PRECISION RTRUE, RFALSE PARAMETER ( RTRUE = 1.D0, RFALSE = 0.D0 ) REAL ZERO, ONE, TWO, THREE C!!!! DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) REAL FOUR, FIVE, SIX, SEVEN C!!!! DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) REAL EIGHT, NINE, TEN C!!!! DOUBLE PRECISION EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 9D0, TEN = 10D0 ) INTEGER SUMFRM, PRDFRM, MJDFRM PARAMETER ( SUMFRM = 1, PRDFRM = 2, MJDFRM = 3 ) REAL NERLY1, BITSML, SMALL C!!!! DOUBLE PRECISION NERLY1, BITSML, SMALL PARAMETER ( NERLY1=.9D0, BITSML=.1D0, SMALL = .0001D0 ) REAL EXTRAP, INITMG, XPNDMG C!!!! DOUBLE PRECISION EXTRAP, INITMG, XPNDMG PARAMETER ( EXTRAP = 10.D0, INITMG = .01D0, XPNDMG = 3.0D0 ) REAL MAXMG C!!!! DOUBLE PRECISION MAXMG PARAMETER ( MAXMG = .3D0 ) C## L O C A L D E C L: C-----CONTROL PARAMETERS FOR ENTRY BBSLNS. INTEGER M, QUADIN, TRU INTEGER SM, SQUDIN, STRU LOGICAL CG, USESHN, LMSTQN, FQUAD, TR4, TR5, TR6 LOGICAL SCG, SUSEHN, SLMTQN, SFQUAD, STR4, STR5, STR6 REAL ACC, SACC C!!!! DOUBLE PRECISION ACC, SACC C-----GENERAL DECLARATIONS. LOGICAL ACCEPT, FORCEQ, QNSTEP, QDONE, INTPT, TEST1 LOGICAL FIRST, LDATA, UDATA, INTERP, GOODP, TEST2 REAL LB, FLB, DGLB, UB, TP0, AT C!!!! DOUBLE PRECISION LB, FLB, DGLB, UB, TP0, AT REAL LEFT, RIGHT, SLICE, CURRMG C!!!! DOUBLE PRECISION LEFT, RIGHT, SLICE, CURRMG C## S A V E: SAVE M, QUADIN, TRU, CURRMG, GOODP SAVE CG, USESHN, LMSTQN, FQUAD, TR4, TR5, TR6 SAVE ACC, LB, FLB, DGLB, LDATA, UB, UDATA C## C O M M O N: NONE IS DEFINED. C## D A T A: NONE ARE SET. C## E X E C U T I O N C## E X E C U T I O N IF ( TR6 ) WRITE (TRU,*) ' ***[LINS]*** ENTERING WITH' - // ' NOUPS, LSDONE, QUADON, CT, NCALLS-> ', - NOUPS, LSDONE, QUADON, CT, NCALLS IF ( TR6 ) WRITE (TRU,*) ' [LINS] VALUES' - // ' M, QUADIN,CG,USESHN,LMSTQN,FQUAD,ACC-> ', - M, QUADIN,CG,USESHN,LMSTQN,FQUAD,ACC IF ( TR6 ) WRITE (TRU,99999) VALIDF, 0.0, F0, DG0, AP, FP, DGP, - ALPHA, FV, DG FIRST = NCALLS .EQ. 1 IF ( FIRST ) THEN LDATA = F LB = ZERO FLB = F0 DGLB = DG0 UDATA = F UB = ZERO GOODP = T CURRMG = INITMG ENDIF C TEST WHETHER THE STEPLENGTH CRITERIA HAVE BEEN MET. TP0 = F0 + SMALL*ALPHA*DG0 TEST1 = FV .LT. TP0 TEST2 = DG .GE. NERLY1*DG0 IF (TR5) WRITE (TRU,*) ' [LINS] TP0->',TP0 IF ( VALIDF ) THEN ACCEPT = TEST1 .AND. TEST2 ELSE ACCEPT = F ENDIF IF ( ACCEPT ) THEN IF ( TR6 ) WRITE(TRU,*) ' [LINS] ACCEPTED.' C THE BASIC ACCEPTANCE TEST HAS BEEN PASSED. WE MUST TEST C WHETHER THE POINT MAY BE IMMEDIATELY ACCEPTED, OR IF C IT IS NECESSARY TO FORCE ANOTHER STEP BECAUSE A REQUIRED C INTERPOLATION STEP HAS NOT YET BEEN DONE. C SEE IF QUADRATIC INTERPOLATION TO BE FORCED. IF ( CG .AND. USESHN ) THEN FORCEQ = T ELSE IF ( CG ) THEN QNSTEP = .NOT. NOUPS - .AND. ( QUADIN .GT. 0 ) - .AND. ( CT .LT. M+QUADIN ) FORCEQ = .NOT. QNSTEP .AND. QUADIN .LE. 3 ENDIF C SEE IF LINE SEARCH IS DONE. FIRST TEST IF AN INTERPOLATION C HAS BEEN DONE. USE THE APPROPRIATE MEANING OF AN C "INTERPOLATION", I.E. ACCORDING TO FQUAD, EITHER ACTUALLY C CHECK FOR A FORMAL INTERPOLATION, OR ELSE JUST DO AS SHANNO C AND MAKE SURE AT LEAST 2 POINTS HAVE BEEN CONSIDERED. QDONE = ( FQUAD .AND. QUADON ) .OR. - ( .NOT. FQUAD .AND. .NOT. FIRST ) .OR. - ( USESHN .AND. .NOT. FIRST ) LSDONE = - ( .NOT. CG ) - .OR. ( QDONE ) - .OR. ( LMSTQN ) C - .OR. ( TP3 .LE. ACC ) ??? IN NEW VERSION ??? - .OR. ( .NOT. FORCEQ ) IF ( .NOT. LSDONE ) THEN IF ( DG .GT. ZERO ) THEN UB = ALPHA UDATA = T ELSE LB = ALPHA LDATA = T FLB = FV DGLB = DG ENDIF ENDIF ELSE IF ( TR6 ) THEN WRITE(TRU,*) ' [LINS] NOT ACCEPTED; FV ', TEST1, TEST2, UDATA WRITE(TRU,99998) ' [LINS] REQ''D REDUCTION, F0-FV, SLOPE' - // ' LIMIT->', F0-TP0,F0-FV,NERLY1*DG0 ENDIF LSDONE = F IF ( .NOT. VALIDF ) THEN UB = ALPHA UDATA = F ELSE IF ( FV .GE. TP0 ) THEN UB = ALPHA UDATA = VALIDF ELSE LB = ALPHA FLB = FV DGLB = DG LDATA = VALIDF ENDIF ENDIF C ...OF "IF ACCEPTABLE". IF ( TR4 ) WRITE(TRU,*) ' [LINS] DONE? '// - 'ACCEPT,LSDONE,FORCEQ,QDONE,QNSTEP->', - ACCEPT,LSDONE,FORCEQ,QDONE,QNSTEP IF ( .NOT. LSDONE ) THEN C LINE SEARCH NOT DONE. A NEW POINT MUST BE TRIED. USE CUBIC C INTERPOLATION TO FIND THE TRIAL POINT AT. IF ( TR5 ) WRITE(TRU,*) ' [LINS] LB, LDATA,UB, UDATA->' , - LB, LDATA,UB, UDATA IF ( UB .NE. ZERO ) THEN IF ( .NOT. UDATA .OR. .NOT. GOODP ) THEN AT = LB + BITSML*(UB-LB) IF (TR5) WRITE(TRU,*) ' [LINS] TAKING MIDINTERVAL'// - ' ALPHA->', AT INTERP = F ELSE INTERP = T IF ( AP .GT. UB .AND. LDATA ) THEN AP = LB FP = FLB DGP = DGLB ENDIF ENDIF ELSE INTERP = F LEFT = ALPHA * (ONE+INITMG) RIGHT = EXTRAP * ALPHA CALL BBCUBC (ALPHA,FV,DG,AP,FP,DGP,LEFT,RIGHT,AT,INTPT) QUADON = INTPT IF (TR5) WRITE(TRU,*) ' [LINS] EXTRAPOLATING IN [',LEFT, - ',',RIGHT,'] TO GET ALPHA->',AT, - ' WITH EXACT INTERPOLATE->',INTPT ENDIF IF ( INTERP ) THEN IF ( GOODP ) THEN SLICE = CURRMG * (UB-LB) LEFT = LB + SLICE RIGHT = UB - SLICE CALL BBCUBC ( ALPHA, FV, DG, AP, FP, DGP, - LEFT, RIGHT, AT, INTPT ) QUADON = INTPT IF (TR5) WRITE(TRU,*) ' [LINS] INTERPOLATING IN [',LEFT, - ',',RIGHT,'] TO GET ALPHA->',AT, - ' WITH EXACT INTERPOLATE->',INTPT IF ( INTPT ) THEN CURRMG = INITMG ELSE CURRMG = MIN(MAXMG, CURRMG * XPNDMG) ENDIF ELSE AT = LB + BITSML* (UB-LB) IF (TR5) WRITE(TRU,*) ' [LINS] TAKING MIDINTERVAL'// - ' ALPHA->', ALPHA ENDIF ENDIF IF ( VALIDF ) THEN AP = ALPHA FP = FV DGP = DG ALPHA = AT GOODP = VALIDF ELSE ALPHA = AT GOODP = F ENDIF IF ( UB .NE. 0 ) THEN WIDTH = UB - LB ELSE WIDTH = ALPHA - LB ENDIF IF (TR5) WRITE(TRU,*) ' [LINS] EXIT WITH ALPHA->',ALPHA IF (TR4) WRITE(TRU,*) ' [LINS] EXIT WITH GOODP,QUADON->', - GOODP,QUADON IF (TR5) WRITE(TRU,*) ' [LINS] EXIT WITH WIDTH->',WIDTH ENDIF C ...OF "LINE SEARCH NOT DONE" GO TO 90000 C## E N T R Y BBSLNS: ENTRY BBSLNS ( SM, SQUDIN, STRU, - SCG, SUSEHN, SLMTQN, SFQUAD, - STR4, STR5, STR6, - SACC ) M = SM QUADIN = SQUDIN TRU = STRU CG = SCG USESHN = SUSEHN LMSTQN = SLMTQN FQUAD = SFQUAD TR4 = STR4 TR5 = STR5 TR6 = STR6 ACC = SACC RETURN C## E X I T 90000 IF (TR4 .OR. TR5 .OR. TR6) WRITE (TRU,*) ' ===[LEAVING LINS].' RETURN C## F O R M A T S: 99999 FORMAT ( ' (VALID DATA = ', L1, ') ALPHA ', - ' F DIR''L DERIVATIVE'/ - ' FIRST POINT ', 3G18.11 / - ' LAST POINT ', 3G18.11 / - ' CURRENT POINT ', 3G18.11 ) 99998 FORMAT ( A, 3G11.3 ) C## E N D OF BBLINS. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> lnirsg.f SUBROUTINE BBLNIR ( FUNCNM, N, X, FX, DECRF, G, ACC, STATUS, - INNER, D, XX, GG, H, HDIM, IW, RW, DW ) C## A R G U M E N T S: EXTERNAL FUNCNM, INNER INTEGER N, HDIM, STATUS, IW(*) REAL X(N),G(N),D(N),XX(N),GG(N),H(*) C!!!! DOUBLE PRECISION X(N),G(N),D(N),XX(N),GG(N),H(*) REAL FX, ACC, DECRF C!!!! DOUBLE PRECISION FX, ACC, DECRF DOUBLE PRECISION DW(*), INNER, FUNCNM REAL RW(*) C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: LNIR.F,V 2.4 91/12/16 11:31:53 BUCKLEY EXP $ C>RCS $LOG: LNIR.F,V $ C>RCS REVISION 2.4 91/12/16 11:31:53 BUCKLEY C>RCS MINOR FIX FOR TOMS. C>RCS C>RCS REVISION 2.3 91/11/22 11:30:00 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 2.2 90/08/06 16:24:49 BUCKLEY C>RCS ADDED TEST THAT ALL ARGUMENTS/PARAMETERS VALID. C>RCS C>RCS REVISION 2.1 90/07/31 10:43:08 BUCKLEY C>RCS ADDED REVISED BLAS. C>RCS C>RCS REVISION 2.0 90/07/17 14:58:51 BUCKLEY C>RCS MINOR FIX TO REMOVE UNUSED DBLE AND RD C>RCS ., C>RCS C>RCS REVISION 1.9 89/06/30 13:51:01 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3 89/05/18 12:39:19 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:55:28 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:54:28 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C---GENERAL COMMENTS. C C THE CALLING SEQUENCE IS DESCRIBED BELOW. THE PURPOSE OF THE C ALGORITHM IS TO FIND AN ESTIMATE OF A LOCAL MINIMUM OF A GIVEN C NONLINEAR FUNCTION F OF N REAL VARIABLES X(1),...,X(N). C THE PROGRAM USES ONE OF TWO METHODS: A QUASI-NEWTON ALGORITHM C OR A VARIABLE STORAGE CONJUGATE GRADIENT ALGORITHM. THIS CODE C IS INTENDED FOR PROBLEMS WITH MODERATE TO LARGE N, BUT IT WILL C ALSO WORK VERY WELL FOR SMALL N. C C THE PROGRAM IS AN EXTENSION OF THE ROUTINE CONMIN PUBLISHED C EARLIER BY SHANNO AND PHUA (SEE TOMS, DEC 1980, VOL. 6, NO. 4 ). C THE QUASI-NEWTON PART OF OUR CODE IS LOGICALLY EQUIVALENT TO THE C QUASI-NEWTON PART OF CONMIN, ALTHOUGH IT APPEARS SOMEWHAT DIFF- C ERENT BECAUSE WE HAVE USED THE SUPERIOR CODE AVAILABLE WITH C FORTRAN 77. IT PRODUCES IDENTICAL RESULTS. IF SUFFICIENT C STORAGE IS AVAILABLE, THE QUASI-NEWTON METHOD WILL BE USED. C THIS IS NOT TRUE IN CONMIN, AND MORE INFORMATION IS AVAILABLE C BELOW: SEE "METH" IN THE SECTION ABOUT ENTRY POINT VARIABLES. C C THE CONJUGATE GRADIENT METHOD IS DESCRIBED IN THE PAPER C "QN-LIKE VARIABLE STORAGE CONJUGATE GRADIENTS", WHICH HAS C APPEARED IN MATHEMATICAL PROGRAMMING. IT IS THIS PART OF THE C CODE WHICH IS THE REAL CONTRIBUTION OF THIS PROGRAM. IT IS C INTENDED TO BE A CONJUGATE GRADIENT CODE WHOSE PERFORMANCE WILL C IMPROVE AS THE STORAGE PROVIDED TO THE ROUTINE IS INCREASED. C C---ALGORITHM DESCRIPTION. C C HERE WE DESCRIBE THOSE DETAILS WHICH WILL AID IN UNDERSTANDING C SUBSEQUENT COMMENTS. FURTHER DETAILS SHOULD BE OBTAINED FROM C THE PAPER. ONLY THE CONJUGATE GRADIENT PART OF THE CODE WILL BE C DISCUSSED HERE AS IT IS THE ORIGINAL CONTRIBUTION. C C THE ALGORITHM STARTS FROM AN INITIAL POINT X[0], WHICH MUST BE C GIVEN. THE INITIAL SEARCH PROCEEDS ALONG A DIRECTION D[1] TO C X[1]. WE REFER TO D[1] AS A RESTART STEP, AND TO X[1] AS A C RESTART POINT. THE ALGORITHM IS IN TWO PARTS: A QUASI-NEWTON C PART AND A CONJUGATE GRADIENT PART. LET X[R] DENOTE A RESTART C POINT (OF WHICH THE FIRST IS X[1]). AT A RESTART POINT, A QUASI- C NEWTON UPDATE IS CALCULATED, SAY H[1], WHICH IS AN UPDATE OF H[0] C (NORMALLY THE IDENTITY), AND THE CURRENT POINT IS RELABELLED AS C X[1] (IF IT ISN'T ALREADY). THE UPDATE MATRIX IS SAVED BY STORING C 2 VECTORS AND 2 SCALARS. THE POINT X[R] MARKS THE START OF THE C QUASI-NEWTON PART. C C AT EACH SUBSEQUENT POINT X[2],X[3],..., A NEW UPDATE IS FORMED, C NAMELY H[2],H[3],..., AND A NEW SEARCH DIRECTION IS FORMED AS C D[I+1] = - H[I]*G[I]. EACH UPDATE MATRIX H[I] IS DEFINED AS AN C UPDATE OF THE PREVIOUS MATRIX H[I-1] AND H[I] IS SAVED BY STOR- C ING AN ADDITIONAL 2 VECTORS AND 2 SCALARS. WHEN THE UPDATE C TERMS WHICH HAVE BEEN STORED HAVE USED ALL OF THE STORAGE WHICH C IS AVAILABLE, WE END THE QUASI-NEWTON PART. THUS THE QUASI-NEWTON C PART EXTENDS FROM X[1] TO X[M+1], ASSUMING THAT THERE IS ROOM C FOR M UPDATE TERMS. UPON REACHING X[M+1], WE SWITCH TO THE C CONJUGATE GRADIENT PART. C C THE CG PART CONTINUES IN MUCH THE SAME WAY, WITH DIRECTIONS C D[I+1] = -H[I]*G[I]. THE DIFFERENCE IS THAT AT EACH STEP, THE C UPDATE MATRIX H[I] (FOR I>M) IS DEFINED AS AN UPDATE OF H[M], C AND INDEED H[I] IS NEITHER STORED NOR EXPLICITLY CALCULATED. C WHETHER ONE IS IN THE QUASI-NEWTON PART OR CONJUGATE GRADIENT C PART ALSO HAS RAMIFICATIONS IN THE STRATEGY EMPLOYED IN THE C LINE SEARCH. THIS IS EXPLAINED IN THE MATHEMATICAL PROGRAMMING C PAPER AND IN THE CODE. C C THE CG PART CONTINUES UNTIL IT IS DECIDED TO DO A RESTART. C SUPPOSE THAT WE HAVE JUST COMPLETED THE LINE SEARCH TO REACH C A POINT X[I]. IN CERTAIN CIRCUMSTANCES, WHICH ARE EXPLAINED C IN THE PAPER AND BELOW, WE WILL DECLARE X[I] TO BE A RESTART C POINT, IN WHICH CASE WE WILL REFER TO IT AS X[R], AND IN FACT C WE WILL RELABEL IT AS X[1]. THE STEP LEADING TO X[R] WILL C BE REFERRED TO AS A RESTART STEP. NOTE THAT THE INITIAL STEP C FROM X[0] ALONG D[1] IS THE FIRST RESTART STEP, AND X[1] C IS THE FIRST RESTART POINT. UPON DECLARING X[R] TO BE A C RESTART POINT, WE DECLARE THE CG PART ENDED, AND WE START C THE QN PART AGAIN. C C---CALLING SEQUENCE. ( THE SECTION "REVERSE COMMUNICATION" BELOW C EXPLAINS SOME EXTENSIONS TO THE CALL. ) C C ON ENTRY TO BBLNIR: C C FUNCNM THE NAME OF THE EVALUATION SUBROUTINE WHICH DEFINES C THE FUNCTION TO BE MINIMIZED. A SUBROUTINE TO C EVALUATE THE FUNCTION MUST BE PROVIDED AND IT C MUST HAVE THE SAME CALLING SEQUENCE AS IN THE C EXAMPLE PROVIDED AND AS EXPLAINED IN ZZEVAL. C C N THE PROBLEM DIMENSION, I.E. THE NUMBER OF VARIABLES C IN THE PROBLEM. BOTH X AND G MUST THEREFORE BE C OF DIMENSION N. C C X A VECTOR OF LENGTH N WHICH CONTAINS AN INITIAL C GUESS AT THE MINIMUM. THUS ON ENTRY X IS THE C VECTOR REFERRED TO AS X[0]. C C FX, G THESE MAY BE REQUIRED ON INPUT, ACCORDING TO THE C VALUE OF STATUS, BELOW. C C DECRF THIS MAY BE AN ESTIMATE OF THE EXPECTED DECREASE IN C THE FUNCTION VALUE. IF SUCH A VALUE IS NOT KNOWN, C THEN DECRF MAY BE SET TO BE < 0 AND IT WILL BE IGNORED. C IT CAN HOWEVER BE VERY HELPFUL TO HAVE AN ESTIMATE C OF !F(X0)-F(X*)!, WHERE X0 IS THE INITIAL POINT AND C F(X*) IS THE FUNCTION VALUE AT THE MINIMUM X*. NOTE C THAT IT IS OFTEN POSSIBLE TO ESTIMATE DECRF WITHOUT C KNOWLEDGE OF X*. IN PARTICULAR, IF F(X*) IS EXPECTED C TO BE 0, THEN DECR MAY BE SET TO ZERO AND F(X0) WILL C BE USED AS AN ESTIMATE OF THE EXPECTED REDUCTION IN F. C C ACC THE ACCURACY DESIRED IN THE FINAL ESTIMATE OF THE C MINIMUM. SEE ZZTERM FOR MORE INFORMATION. C C STATUS THIS IS A CODE TO INDICATE THE ROUTINE'S STATUS C ON ENTRY AND EXIT. THE CODE IS AN INTEGER VALUE. THE C VALUES NORMALLY USED ARE GIVEN BELOW THE NAME USED C FOR THE CODE. THE INTEGER VALUES MAY BE CHANGED BY C USING THE ENTRY POINT BBLIDF BELOW. ON ENTRY, WE HAVE: C C = NORMFG THIS IS JUST LIKE THE CASE STATUS=NORMAL, EXCEPT C (-1) THAT IT INDICATES THAT, UPON ENTRY TO BBLNIR, C THE FUNCTION AND GRADIENT VALUES AT THE INITIAL C POINT X ARE ALREADY AVAILABLE. C = NORMAL AN "ORDINARY" CALL. MINIMIZE THE FUNCTION AND C (0) CALL ZZEVAL WHEN FUNCTION AND/OR GRADIENT C VALUES ARE REQUIRED. C = RCSTRT THIS IS AN INITIAL CALL INDICATING THAT REVERSE C (1) COMMUNICATION IS TO BE USED; SEE BELOW. C = RCRPT THIS IS A SECONDARY CALL WITH REVERSE COMMUNI- C (2) CATION; SEE BELOW, AS WELL AS STATUS=RCNOFG. C = RCNOFG THIS IS ALSO A SECONDARY CALL WITH REVERSE C (3) COMMUNICATION, BUT IT INDICATES THAT THE MAIN C ROUTINE WAS UNABLE TO PROVIDE THE DESIRED FUNCTION C AND/OR GRADIENT VALUE. C C HDIM THIS IS AN INTEGER VALUE GIVING THE NUMBER OF LOCA- C TIONS OF STORAGE AVAILABLE IN H. IN THE DEFAULT C CASE (SEE METH BELOW), THIS WILL DETERMINE THE C METHOD USED. IF HDIM IS LARGE ENOUGH, A QUASI- C NEWTON METHOD WILL BE USED. OTHERWISE, A CONJUGATE C GRADIENT METHOD WILL BE USED WITH AS MANY UPDATES C BEING STORED AS IS POSSIBLE. C C TEMPORARY WORK AREAS: C C D, XX, GG, H C C IW NOTE THAT THE THREE ARRAYS IW, RW AND DW ARE NOT C RW TOUCHED BY THE MINIMIZATION ALGORITHM. THEY ARE PROVIDED C DW TO FACILITATE COMMUNICATION BETWEEN THE USERS CALLING C ROUTINE AND THE FUNCTION EVALUATION ROUTINE WHICH THE C USER MUST ALSO PROVIDE. THERE IS ONE VECTOR PROVIDED C OF EACH BASIC NUMERIC TYPE. THE AVAILABILITY OF THESE C ARRAYS MAY OFTEN PRECLUDE THE NECESSITY OF USING C REVERSE COMMUNICATION. THEY ARE PROVIDED THEREFORE IN C THE CALLING SEQUENCE OF THE USER FUNCTION EVALUATION C ROUTINE, AND WILL BE PASSED BOTH IN AND BACK WITHOUT C CHANGE BY THE MINIMIZATION ALGORITHM. C C INNER THIS IS THE NAME OF THE DOUBLE PRECISION FUNCTION FOR C COMPUTING INNER PRODUCTS. SEE THE COMMENTS IN BBMULT. C C UPON EXIT FROM BBLNIR: C C X THE FINAL ESTIMATE OF THE MINIMUM WHICH WAS FOUND, C PROVIDED THAT STATUS IS ZERO. IF STATUS IS NOT C ZERO, THE VALUES IN X, FX AND G MAY BE UNRELIABLE. C C FX THE FUNCTION VALUE AT THE FINAL ESTIMATE X. C C G THE GRADIENT VALUE AT THE FINAL ESTIMATE X. C C STATUS AGAIN, THE INTEGER IS THE INTEGER CODE NORMALLY USED C UNLESS REDEFINED VIA THE ENTRY BBLSDF. C C = DONE NORMAL TERMINATION: AN ACCURATE SOLUTION APPEARS TO C (0) HAVE BEEN FOUND. C = NOSTOR EXECUTION NEVER BEGAN BECAUSE THERE WAS INSUFFICIENT C (-1) STORAGE ALLOCATED. THE MINIMUM REQUIREMENT FOR HDIM C IS 0. SEE BBVSCG AND "METH" BELOW. C = IPMIN THE INITIAL FX OR G WAS A CRITICAL POINT. C (-2) C = IPUNDF THE INITIAL FX OR G WAS UNDEFINED. C (-3) C = BDMETH EXECUTION NEVER BEGAN BECAUSE AN INVALID METHOD WAS C (-4) SPECIFIED. THIS WOULD NEVER HAPPEN IN NORMAL USE. C = LSFAIL THE LINE SEARCH FAILED. THIS IS PROBABLY BECAUSE TOO C (-5) HIGH AN ACCURACY REQUIREMENT WAS GIVEN FOR THE C MACHINE IN USE, OR BECAUSE THE FUNCTION AND/OR C GRADIENT EVALUATIONS ARE INCORRECTLY CODED. THIS C EXIT IS MORE LIKELY WHEN FINITE DIFFERENCES C ARE BEING USED TO CALCULATE DERIVATIVES. C = NODESC A NON-DESCENT SEARCH DIRECTION WAS GENERATED. THIS C (-6) CAN ONLY BE DUE TO ROUNDOFF AND THE CAUSE IS C POSSIBLY THE SAME AS FOR STATUS = LSFAIL. C = XSFUNC EXECUTION HALTED WHEN MORE THAN THE ALLOWED NUMBER C (-7) OF FUNCTION EVALUATIONS WAS ATTEMPTED. C = PSBACK THE PASS-THROUGH CALL WAS SUCCESSFUL C (-8) C = RABORT AN ABORT WAS REQUESTED BY THE FUNCTION EVALUATION C (-9) ROUTINE. C = RCXX THESE ARE USED FOR REVERSE COMMUNICATION; SEE BELOW. C C---REVERSE COMMUNICATION: C C IN SOME APPLICATIONS IT MAY NOT BE APPROPRIATE TO OBTAIN C FUNCTION VALUES BY CALLING THE ROUTINE ZZEVAL. BEFORE CONCLUDING C THIS HOWEVER, ONE SHOULD READ THE COMMENTS ABOVE ON THE ARRAYS C IW, RW AND DW. C C IN THE CASE THAT THOSE ARRAYS ARE NOT APPROPRIATE, AN ALTERNATIVE C IS TO USE REVERSE COMMUNICATION. THE ARGUMENTS TO BBLNIR HAVE C THE SAME MEANINGS AS ABOVE, WITH THE FOLLOWING MODIFICATIONS. C C 1. ON THE INITIAL CALL TO BBLNIR, STATUS MUST BE SET TO RCSTRT, C AND FX AND G MUST CONTAIN THE VALUE OF THE FUNCTION AND C GRADIENT AT THE POINT X WHICH IS SPECIFIED AS THE STARTING C POINT FOR THE MINIMIZATION. C C 2. WHEN BBVSCG REQUIRES FURTHER FUNCTION AND GRADIENT VALUES, C IT WILL RETURN TO THE CALLING PROGRAM WITH C STATUS = RCF(1), RCFG(2) OR RCG(3) C WITH X CONTAINING A SET OF N COORDINATES. IN THIS CASE, C THE CALLING PROGRAM MUST OBTAIN THE VALUE OF THE FUNCTION C AND/OR THE GRADIENT AT THE SPECIFIED POINT X, AND THEN CALL C BBVSCG AGAIN WITH THESE VALUES IN FX AND G. NONE OF THE OTHER C PARAMETERS MUST BE ALTERED EXCEPT THAT STATUS MUST C TO SET TO RCRPT OR TO RCNOFG BEFORE CALLING BBVSCG AGAIN. C AGAIN, THE INTEGER CODES MAY BE CHANGED BY CALLING AN ENTRY C POINT BBLSDF BEFORE USING BBLNIR. C C 3. EXECUTION OF BBVSCG WILL TERMINATE AS USUAL, AND ANY VALUE C OF STATUS OTHER THAN RCF, RCFG OR RCG ON RETURN MUST BE C TAKEN AS A SIGNAL TO QUIT. C C NOTE THAT BBLNIR IS NORMALLY CALLED VIA BBVSCG, AND RETURN C TO THE MAIN ROUTINE IS THEREFORE ALSO THROUGH BBVSCG. THAT IS C NO PROBLEM, FOR BBVSCG WILL CHECK FOR THE USE OF REVERSE C COMMUNICATION. IF BBLNIR IS BEING CALLED DIRECTLY BY THE USER, C ONE MUST BE CAREFUL TO DO ALL INITIALIZATION BEFORE THE FIRST C CALL TO BBLNIR, EVEN IF ONE IS USING REVERSE COMMUNICATION. C C---I/O. C C INPUT: C C THERE IS NO INPUT REQUIRED. ALL INFORMATION NEEDED BY THE C ROUTINE IS TAKEN FROM THE CALLING SEQUENCE OR FROM THE ENTRY C POINT CALL TO BBLSET. C C OUTPUT: C C THE CURRENT VERSION IS SET UP TO PRINT THE INITIAL GUESS C X[0] AND THE SOLUTION. ALL OUTPUT IS ON UNIT 6. C C IF IT IS DESIRED, THIS OUTPUT MAY BE DELETED OR MORE C EXTENSIVE OUTPUT MAY BE OBTAINED. THE BASIC CONTROL IS DONE C IN THE ROUTINE ZZPRNT AND MAY BE ALTERED BY USING THE ENTRY C POINT ZZP1ST INTO ZZPRNT. SEE THE EXTERNAL DOCUMENTATION C AND THE LISTING OF ZZPRNT. C C OTHER OUTPUT MAY BE OBTAINED BY TURNING ON VARIOUS TRACES C AS IS DESCRIBED LATER IN THIS LISTING. C C---IMPLEMENTATION NOTES. C C 1. THE ROUTINE USES A MACHINE DEPENDENT CONSTANT EPS. THIS IS C DETERMINED BY CALLING THE ROUTINE ZZMPAR. CONSULT THAT C ROUTINE FOR MORE INFORMATION. C THE ONLY OTHER MACHINE DEPENDENCE IS IN THE USE OF A TIMING C ROUTINE. THIS IS ISOLATED IN ZZSECS WHICH CAN BE EASILY C ALTERED OR REMOVED. C C 2. BOTH SINGLE AND DOUBLE PRECISION VERSIONS ARE SUPPLIED. THIS C VERSION IS IN ONE SPECIFIC PRECISION. TO GET THE ALTERNATE C PRECISION, USE THE PROGRAM CONVERT AND CHANGE FROM MODE C "A" TO MODE "B". ALTERNATELY, IF YOU HAVE A GOOD EDITOR, C LOOK FOR LINES BEGINNING "C!!!!" AND INTERCHANGE ALL BUT THE C FIRST 5 CHARACTERS OF THOSE LINES WITH THE CORRESPONDING C CHARACTERS OF THE IMMEDIATELY PRECEDING LINE. C C 3. THERE ARE A NUMBER OF CONTROL PARAMETERS WHICH ARE INITIALIZED C IN DATA STATEMENTS BELOW, BUT WHICH CAN BE CHANGED BY C CALLING THE ENTRY POINT BBLSET WITH NEW VALUES. ALL HAVE C DEFAULT VALUES AND THERE IS NO NEED TO CHANGE ANY OF THEM. C PERSONS WISHING TO EXPERIMENT WITH THE CODE MAY CHANGE THEM C IF DESIRED, SO THEY ARE EXPLAINED BELOW. SUCH CHANGES ARE C NOT RECOMMENDED UNLESS YOU ARE VERY FAMILIAR WITH THE METHOD. C C 4. ALL OUTPUT IN ON UNIT 6. IF THAT IS NOT SATISFACTORY, THAT C MAY BE CHANGED. THE UNIT IS DEFINED IN THE ROUTINE ZZPRNT AND C MORE INFORMATION MAY BE OBTAINED FROM THE LISTING OF ZZPRNT. C C 5. WHEN DEVELOPING THIS CODE, IT WAS FOUND USEFUL TO INCLUDE C SOME ABILITY TO TRACE PARTS OF THE CODE WITH SOME APPROPRIATE C OUTPUT. THIS IS STILL IN THE CODE, BUT IT IS TURNED OFF. TO C TURN IT ON, SET ALL OR SOME OF THE TRACE PARAMETERS TR1,..., C TR10 TO .TRUE. . THEY ARE CURRENTLY DEFAULTED TO .FALSE. C THEY MAY BE CHANGED THROUGH THE ENTRY POINT BBLSET. C C 6. PERHAPS THE CHOICE OF LANGUAGE SHOULD BE JUSTIFIED. FIRST, I C THINK IT IS IMPERATIVE, IF FORTRAN IS TO BE CHOSEN, THAT THE C 1977 DIALECT BE USED. THE JUSTIFICATION FOR THE USE OF THE C '77 STRUCTURED STATEMENTS IS NOW PART OF ALMOST ANY COMPUTING C SCIENCE CURRICULUM. THE CURRENT VERSION OF THE CODE HAS BEEN C STRUCTURED TO FACILITATE CONVERSION TO THE NEW STANDARD C (FORTRAN 88) CURRENTLY BEING PROPOSED BY ISO/IEC JCT1/SC22/WG5. C C 7. I DID NOT WRITE THIS CODE IN PASCAL, FIRST, BECAUSE PASCAL IS C STILL NOT AS UNIVERSAL AS FORTRAN, AND SECOND, BECAUSE OF A C NUMBER OF SERIOUS SHORTCOMINGS IN THE STANDARD LANGUAGE WHICH C ARE QUITE RELEVANT WHEN PROVIDING GENERAL PURPOSE SOFTWARE C (SEE GROGONO, PROGRAMMING IN PASCAL, ED. 1, SECTION 10.5). C PL/I WAS NEVER CONSIDERED, AND APL IS A NON-STARTER WHEN IT C COMES TO SOFTWARE SUCH AS THIS. ALGOL 68 WOULD HAVE BEEN C NICE BUT IT IS NOT WIDELY USED. IN THE FUTURE EITHER C ADA OR THE NEXT FORTRAN STANDARD WOULD HAVE MADE BETTER C ALTERNATIVES BECAUSE OF THEIR FEATURES DESIGNED C SPECIFICALLY FOR SOFTWARE DEVELOPMENT. C C 8. THE CODE CONTAINS A NUMBER OF DECISION VARIABLES, I.E. THOSE C SET THROUGH BBLSET. THESE HAVE A DEFINITE EFFECT ON THE C EXECUTION OF THE CODE AND WERE USED FOR THE EXPERIMENTAL C TESTING DOCUMENTED IN THE PAPER DESCRIBING THE ALGORITHM. C IT COULD BE SUGGESTED THAT THESE SHOULD BE REMOVED FOR A C PUBLICATION VERSION, AND TO SOME EXTENT I WOULD AGREE WITH C THAT. HOWEVER, I HAVE NOT REMOVED THEM, AND I WOULD LIKE TO C GIVE THE FOLLOWING JUSTIFICATION: C C (A) SINCE THE CODE REQUIRES O(MN) OPERATIONS FOR EACH C ITERATION, THE REMOVAL OF A FEW LOGICAL DECISIONS WOULD C HAVE A NEGLIGIBLE EFFECT ON THE EXECUTION SPEED. C C (B) THE USER NEED NOT BE CONCERNED WITH ANY OF THE POSSIBLE C CHOICES, FOR DEFAULT VALUES ARE PROVIDED FOR ALL OF THEM. C C (C) SOME PEOPLE MIGHT CHOOSE TO EXPERIMENT WITH THE CODE, C AND THAT WOULD BE GREATLY FACILITATED BY LEAVING IT AS IT IS. C C 9. WHERE THE EFFECT ON EXECUTION SPEED IS NOT LIKELY TO BE C SIGNIFICANT, I HAVE OFTEN OPTED FOR CODING IN A FASHION C WHICH GIVES THE GREATEST CLARITY TO THE CODE, RATHER THAN C SEEKING THE SLICKEST OR QUICKEST WAY. FOR EXAMPLE, THE USE C OF LOGICALS SUCH AS MAXPAS (IN BBLINS) COULD EASILY BE C ELIMINATED, BUT I THINK THE CODE AS IT IS IS PARTICULARLY C CLEAR. ALSO NOTE THAT WITH AN OPTIMIZING COMPILER, WRITING C THE CODE AS IT IS SHOULD HAVE NO EFFECT AT ALL ON EXECUTION C SPEED. IN FACT, WITHIN LOOPS (SUCH AS DO 3200 IN BBUPDT) C I HAVE QUITE DELIBERATELY WRITTEN THEM WITH FULL AND RE- C PEATED SUBSCRIPT REFERENCES IN ORDER TO GIVE A GOOD OPTI- C MIZING COMPILER THE BEST OPPORTUNITY TO GENERATE EFFICIENT C CODE. FINALLY, NOTE THAT THE TRACE REFERRED TO ABOVE (IN 5) C WILL ALSO HAVE LITTLE EFFECT ON EXECUTION SPEED AS LONG C AS IT IS TURNED OFF. C C 10. THE ROUTINES ZZPRNT, ZZTERM AND ZZPRNT ARE NOT CENTRAL TO C THE MINIMIZATION PROCESS. THEY PERFORM CERTAIN USEFUL C AUXILIARY TASKS, AND HAVE CERTAIN FACILITIES WHICH SOME C USERS MAY WISH TO TAKE ADVANTAGE OF. THERE IS SOME PRICE C TO HAVING THESE SEPARATE ROUTINES, BUT IT IS AGAIN SMALL C COMPARED TO THE OVERALL COMPUTATION. THEY CAN EASILY BE C REMOVED IF THAT IS FELT TO BE ESSENTIAL. C C 11. COMMON WAS USED IN MANY PLACES IN AN EARLY VERSION OF C THIS ROUTINE IN ORDER TO AVOID UNNECESSARILY LONG CALLING C SEQUENCES. THERE ARE SOME WHO OBJECT TO THE USE OF COMMON, C AND THERE IS ONE INSTALLATION WHERE THE USE OF COMMON IS C (I HAVE BEEN TOLD) ESSENTIALLY FORBIDDEN, SO THE CURRENT C VERSION USES NO COMMON. INSTEAD, ENTRY POINTS, WHICH ARE C PART OF THE STANDARD FOR FORTRAN 77, ARE USED TO AVOID THE C UNPLEASANTNESS OF LONG CALLS. NOTE THOUGH THAT THE CODE IS C STRUCTURED SO THAT IT CAN BE USED IN MOST INSTANCES WITHOUT C ANY NEED TO BE AWARE OF THIS FACT. C C---THE ENTRY POINT B B L S E T : C C ( METH, QUADIN, ALPIS1, SCGAMM, ...INTEGERS C HTEST, UPDATT, C RO, BETA, ...REALS C FQUAD, SCDIAG, SHANNO, FROMRS, FORCER, ...LOGICALS C RELF, RELG, C TRU, STRACE ) ...TRACES C C THE FOLLOWING VARIABLES ARE PARAMETERS WHICH AFFECT EXECUTION OF C THE ALGORITHM. THESE CONTROL PARAMETERS HAVE DEFAULT VALUES WHICH C CAN BE CHANGED BY CALLING THE ENTRY POINT BBLSET WITHIN THIS C ROUTINE BBLNIR. THERE SHOULD NORMALLY BE NO NEED TO CHANGE C ANY OF THESE PARAMETERS, SINCE ALL HAVE DEFAULTS DEFINED IN C THE DATA SECTION BELOW. THESE ARE FOR EXPERIMENTAL PURPOSES. C THE VALUES IN ( ) ARE THE DEFAULT VALUES. C C ...INTEGERS C C METH = -3 USE THE ORDINARY CG ALGORITHM WITH M=0. C (0) = -2 USE THE QN ALGORITHM. CHECK STORAGE IS SUFFICIENT. C = -1 USE THE CG ALGORITHM WITH AS MANY UPDATE TERMS AS ARE C AVAILABLE, BUT AT MOST N. C = 0 USE THE QN ALGORITHM IF THERE IS ENOUGH STORAGE; C OTHERWISE USE A CG ALGORITHM WITH AS MANY UPDATE C TERMS AS ARE AVAILABLE. THIS IS THE ONLY CASE NEEDED; C THE OTHER CASES ARE FOR EXPERIMENTAL PURPOSES. C > 0 USE THE CG ALGORITHM WITH THE NUMBER OF TERMS SPECI- C FIED BY METH. IF THIS IS MORE THAN THE NUMBER AVAIL- C ABLE, USE THE MAXIMUM POSSIBLE. MORE THAN N TERMS C MAY BE USED. IF METH IS SET TO BE >= 10000 ( SEE C SPECQN ), THIS IS TREATED AS A SPECIAL CASE, AND C CERTAIN SPECIAL STATEGIES ARE FOLLOWED. THIS CASE C IS JUST FOR EXPERIMENTAL PURPOSES. SEE METH = -3 TO C SPECIFY NO UPDATES. C C QUADIN THIS DETERMINES IN WHAT CIRCUMSTANCES A QUADRATIC C (2) INTERPOLATION MUST BE DONE BEFORE A LINE SEARCH CAN C BE DEEMED COMPLETE. THE FUNDAMENTAL IDEA IS THAT A C QUADRATIC INTERPOLATION MUST BE DONE ON LINE SEARCHES C IN CONJUGATE GRADIENT METHODS. C C = 0 QUAD. INT. FORCED ON EVERY STEP. C = 1 QUAD. INT. FORCED ON D[M+1] AND LATER STEPS. C = 2 QUAD. INT. FORCED ON D[M+2] AND LATER STEPS. C = 3 QUAD. INT. FORCED ON D[M+3] AND LATER STEPS. C > 3 QUAD. INT. IS NEVER FORCED. C C ALPIS1 THIS DETERMINES IN WHAT CIRCUMSTANCES A LINE SEARCH C (1) IS BEGUN WITH THE STEP OF LENGTH 1, I.E. WITH ALPHA = 1, C WHICH IS NORMALLY THE STRATEGY FOR QUASI-NEWTON C METHODS. C C = 0 ALPHA = 1 IS NEVER USED INITIALLY. C = 1 ALPHA = 1 USED ON STEPS BEFORE D[M+1] (NOT INCLUSIVE) C = 2 ALPHA = 1 USED ON STEPS BEFORE D[M+2] (NOT INCLUSIVE) C = 3 ALPHA = 1 USED ON STEPS BEFORE D[M+3] (NOT INCLUSIVE) C > 3 ALPHA = 1 IS INITIAL CHOICE ON ALL STEPS. C C STSTEP 1 THEN IMPLEMENT THE SCALING OF THE CONJUGATE GRADIENT C (2) DIRECTIONS, WHICH IS REFLECTED IN THE INITIAL C CHOICE OF ALPHA, USING THE FORMULA GIVEN BY C FLETCHER AND USED IN HIS VA08. C 2 THEN USE THE FORMULA APPEARING IN CONMIN AND USED C BY POWELL IN VA14. C C SCGAMM THE SO-CALLED GAMMA SCALING OF OREN AND SPEDICATO, C (1) WHICH IS DESCRIBED BY SHANNO, MAY BE USED AT EACH UPDATE C STEP. THIS CAN IN FACT BE DONE ONLY IF THE BFGS C UPDATE IS BEING USED, I.E. IF BETA = 1. NO EXTRA C STORAGE IS NEEDED TO IMPLEMENT THIS SCALING. C C = 0 THEN DO NOT USE THIS SCALING C = 1 THEN USE THIS JUST ON THE FIRST QN UPDATE. C = 2 THEN USE THIS FOR ALL QN UPDATES. C C HTEST = 0 THEN DO NOT USE ANY RESTART TEST. C (1) = 1 JUST USE POWELL'S SIMPLE TEST (I.E. H = I ) C = 2 USE THE RESTART TEST WHICH INVOLVES THE MATRIX C H AS DESCRIBED IN THE PAPER. C C UPDATT = 1 USE THE SUM FORM OF UPDATING. C = 2 USE NOCEDAL'S PRODUCT FORM. C = 3 USE POWELL'S FACTORED FORM. C C ...REALS C C RO THIS IS THE PARAMETER OF THE SAME NAME FROM THE PAPER C (.2) WHICH CONTROLS THE RESTART TEST, I.E. IF C TAU[I] > RO, A RESTART WILL BE DONE. C C BETA THIS IS THE SCALAR PARAMETER FOR THE BROYDEN UPDATE C (1.0) FAMILY. IT IS DEFAULTED TO 1, SO THAT THE BFGS C UPDATE FORMULA IS OBTAINED. C C ...LOGICALS C C FQUAD TRUE THEN THE APPLICATION OF QUADIN, AS DESCRIBED ABOVE, C (F) IS DECIDED BY MONITORING WHETHER THE PART OF THE C CODE WHICH DOES THE ACTUAL INTERPOLATION HAS BEEN C ENTERED OR NOT. C FALSE THEN THE STRATEGY USED BY SHANNO IN CONMIN IS C FOLLOWED, I.E. ANY COMPUTATION OF A NEW ALPHA COUNTS, C WHICH MAY INCLUDE A NON-INTERPOLATION STEP. THIS C IS IMPLEMENTED BY SIMPLY CHECKING NCALLS, AND INCRE- C MENTING NCALLS EACH TIME THE FUNCTION IS EVALUATED. C C DIAGNL TRUE H0 IS TAKEN TO BE A DIAGONAL MATRIX WHICH IS AVAIL- C (F) ABLE IN THE FIRST N LOCATIONS OF THE ARRAY H. C NOTE THAT THIS INCREASES THE STORAGE REQUIREMENT C FOR H BY N LOCATIONS. C FALSE OTHERWISE, H0 = I, AND IT IS OF COURSE NOT STORED. C C SHANNO TRUE THEN, IN THE CASE WHEN THERE IS EXACTLY ONE UPDATE, C (F) MAKE SURE THAT THE DETAILS OF IMPLEMENTATION ARE EXACT- C LY THE SAME AS IN THE CONJUGATE GRADIENT SECTION OF C SHANNO'S CONMIN. THIS WILL OVERRIDE CERTAIN SETTINGS C OF THE OTHER PARAMETERS. IN FACT, THE SAME RESULTS C SHOULD BE OBTAINED BY SETTING THE OTHER PARAMETERS C APPROPRIATELY. C C FALSE THEN IMPLEMENT ACCORDING TO THE LOGIC DEFINED HERE. C C FROMRS TRUE THEN A RESTART IS FORCED AFTER N STEPS FROM THE C (F) LAST RESTART POINT X[R] (WHICH IS X[1]). C FALSE THEN A RESTART IS NOT FORCED UNTIL N STEPS HAVE C BEEN DONE FROM THE BEGINNING OF THE CG PART, C I.E. FROM X[M+1]. C C FORCEF TRUE THEN A RESTART IS FORCED AT THE END OF A STEEPEST C (T) DESCENT STEP, I.E. THE STEP ALONG D[1] FROM C X[0] IS ALWAYS CONSIDERED A RESTART STEP. C NOTE THAT WHEN M=0 THIS RESULTS IN THE C STEEPEST DESCENT ALGORITHM. C FALSE THEN SUCH A RESTART IS NOT FORCED. INSTEAD, THE C STEP FROM X[0] IS JUST CONSIDERED PART OF A C CONJUGATE GRADIENT SEQUENCE (WITH H = H[0], WHICH C IS NORMALLY I), AND A RESTART IS DONE ONLY C WHEN FORCED BY N STEPS HAVING BEEN TAKEN WITH C NO RESTART, OR BY THE RESTART TEST. THIS MAKES C THE INITIAL CYCLE LIKE THE M=0 CASE. NOTE C THAT WHEN M=0 THIS RESULTS IN AN ORDINARY CG C ALGORITHM, BUT IMPLEMENTED AS IN [1]. C C RELF TRUE THESE TWO VALUES DETERMINE WHETHER TERMINATION C RELG TRUE TESTS ARE RELATIVE TO THE INITIAL FUNCTION AND C GRADIENT VALUES OR NOT. SEE ZZTERM FOR MORE C INFORMATION. C C ...TRACES C C TRU THIS IS THE UNIT TO RECEIVE TRACE OUTPUT. IT IS C (6) IGNORED UNLESS SOME TRACE FLAGS ARE ON. C C STRACE THIS SETS THE 15 TRACE FLAGS TR1,...,TR15 WHICH ARE C EXPLAINED BELOW. C C---ENTRY POINT BBVGET ( CNTRST, M, CNTFOR ) . C C THIS ENTRY POINT IS PROVIDED AS A MEANS OF RETURNING CERTAIN C STATISTICS ON THE EXECUTION OF BBLNIR WHICH MAY BE OF INTEREST. C THE FOLLOWING VALUES ARE AVAILABLE. C C CNTRST A COUNT OF THE NUMBER OF RESTARTS WHICH TOOK PLACE. C M THE NUMBER OF UPDATE TERMS ACTUALLY USED. C CNTFOR COUNT THE NUMBER OF RESTARTS FORCED BY HTEST. C C---TRACE FLAGS. C C TR1 ARGUMENTS ON INPUT C TR2 INFORMATION RE STEP TYPES, EG QN VS CG. C TR3 LINE SEARCH: EACH ALPHA USED. C TR4 LOGICAL FLAGS. C TR5 INTERMEDIATE REAL VALUES. C TR6 LOGICAL FLOW. C TR7 RESTART AND UPDATE INFORMATION. C TR8 INTERMEDIATE VALUES IN BBMULT AND BBLNIR. C TR9 POINT X AND DIRECTION D AT START OF EACH ITERATION. C (THIS OVERRIDES TR10=FALSE) C TR10 INCLUDE VECTORS WITH OUTPUT WHERE APPROPRIATE C TR11 POINT IN CUBIC SEARCH C TR12 CURRENTLY UNUSED. C TR13 CURRENTLY UNUSED. C TR14 CURRENTLY UNUSED. C TR15 CURRENTLY UNUSED. C C---SOME OF THE MORE IMPORTANT VARIABLES: C C CT COUNT ITERATIONS FROM THE LAST RESTART; THE RESTART C POINT IS COUNTED AS NUMBER 1. C LMSTQN A SPECIAL TEST CASE: CG METHOD WITH > N UPDATES, SO C VIRTUALLY QN METHOD. SOME SPECIAL CONSIDERATIONS. C IT IS SET TO TRUE IF METH >= 10000 ON ENTRY. C RSTEP IF TRUE, THIS IS THE RESTART STEP; AT THE END OF THIS C STEP WE GET THE RESTART POINT X[R]. THIS WILL FORCE C A RESTART AND RETURN THE CODE TO THE "QN" PART. C LASTPT THE LAST POINT WHICH CAN BE REACHED BEFORE A RESTART C MUST BE FORCED BECAUSE OF THE NUMBER OF STEPS TAKEN. C STEEPD IF TRUE, THIS STEP IS IN A STEEPEST DESCENT DIRECTION. C THIS HAPPENS ONLY INITIALLY, OR IN THE CASE OF C NUMERICAL DIFFICULTIES OR WHEN M=0. C QNPART IF TRUE, THIS STEP IS IN THE QN PART OF THE ALGORITHM. C THUS QNPART IS TRUE FROM X[1] TO X[M+1]. C CNTRST COUNT THE RESTARTS (FOR INFORMATION ONLY). C M THIS IS THE MAXIMUM NUMBER OF UPDATE TERMS ALLOWED. C NCALLS THIS IS THE NUMBER OF FUNCTIONS EVALUATIONS DONE DURING C EACH LINE SEARCH. C NUPS THIS COUNTS THE NUMBER OF QN UPDATES CURRENTLY STORED. C ONEUPD THIS IS TRUE IF M = 1. C ALPHA THE LINE SEARCH STEP LENGTH. C C## E N T R Y P O I N T S: C C BBLNIR ... THE NATURAL ENTRY POINT. C BBLSET ... AN ENTRY TO ALTER CONTROL PARAMETERS. C BBVGET ... AN ENTRY TO GET RESTART COUNTS. C BBLFDF ... AN ENTRY TO REDEFINE THE EVALUATION CODES FOR ZZEVAL. C BBLIDF ... AN ENTRY TO REDEFINE THE ENTRY STATUS CODES. C BBLRDF ... AN ENTRY TO REDEFINE THE RETURN CODES FROM ZZEVAL. C BBLSDF ... AN ENTRY TO REDEFINE EXIT STATUS CODES. C C## S U B R O U T I N E S: C C ABS, MAX, MIN, ACOS INTRINSIC FUNCTIONS. C FUNCNM, INNER EXTERNAL PROCEDURES PASSED AS ARGUMENTS. C C HERE, A NAME IN [..] IS AN ENTRY POINT IN THE GIVEN ROUTINE. C C BBINIH INITIAL DIAGONAL MATRIX C BBCUBC [BBSCUB] CUBIC INTERPOLATION C BBLINS [BBSLNS] LINE SEARCH LOOP C BBMULT [BBSMLT] MATRIX VECTOR MULTIPLICATION WITH SUMS C BBNOCE [BBSNOC] MATRIX VECTOR MULTIPLICATION WITH PRODUCTS C BBUPDT [BBSUPD] UPDATE H C C ZZEVAL,ZZPRNT,ZZTERM OPTIONAL, AS EXPLAINED IN "IMPLEMENTATION C NOTES" ABOVE. C C ZZMPAR RETURNS MACHINE PRECISION. C ZZINNR, ZZNRM2 INNER PRODUCT, 2-NORM OF VECTOR(S) C ZZSECS (INDIRECT) USED IN ZZEVAL AND ZZPRNT. C C## P A R A M E T E R S: INTEGER SPECQN PARAMETER ( SPECQN = 10000 ) LOGICAL DONORM, NONORM PARAMETER ( DONORM = .TRUE., NONORM = .FALSE. ) INTEGER JUSTF, BOTH, JUSTG, NOOP PARAMETER ( JUSTF = 1, BOTH = 0, JUSTG = -1, NOOP = 2 ) LOGICAL T, F PARAMETER ( T = .TRUE., F = .FALSE. ) CHARACTER*(*) TRUE, QT, FALSE, QF PARAMETER ( TRUE = 'TRUE', QT = 'T', FALSE = 'FALSE', QF = 'F' ) INTEGER ITRUE, IFALSE PARAMETER ( ITRUE = 1, IFALSE = 0 ) REAL RTRUE, RFALSE C!!!! DOUBLE PRECISION RTRUE, RFALSE PARAMETER ( RTRUE = 1.D0, RFALSE = 0.D0 ) INTEGER GAMOFF, GAMONE, GAMALL PARAMETER ( GAMOFF = 0, GAMONE = 1, GAMALL = 2 ) INTEGER XEPS, XSMALL, XBIG PARAMETER ( XEPS = 1, XSMALL = 2, XBIG = 3 ) REAL ZERO, ONE, TWO, THREE C!!!! DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) REAL FOUR, FIVE, SIX, SEVEN C!!!! DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) REAL EIGHT, NINE, TEN C!!!! DOUBLE PRECISION EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 9D0, TEN = 10D0 ) REAL TENTH, FIFTH, HALF C!!!! DOUBLE PRECISION TENTH, FIFTH, HALF PARAMETER ( TENTH = .1D0, FIFTH = .2D0, HALF = .5D0 ) REAL RPT9, RPT8, RD29 C!!!! DOUBLE PRECISION RPT9, RPT8, RD29 PARAMETER ( RPT9 = .9D0, RPT8 = .8D0, RD29 = 1D0/29D0 ) REAL R11, R12, R13, R14 C!!!! DOUBLE PRECISION R11, R12, R13, R14 PARAMETER ( R11 = 11D0, R12 = 12D0, R13 = 13D0,R14 = 14D0) REAL R15, R16, R17, R18 C!!!! DOUBLE PRECISION R15, R16, R17, R18 PARAMETER ( R15 = 15D0, R16 = 16D0, R17 = 17D0,R18 = 18D0) REAL R19, R20, R25, R29 C!!!! DOUBLE PRECISION R19, R20, R25, R29 PARAMETER ( R19 = 19D0, R20 = 20D0, R25 = 25D0,R29 = 29D0) REAL R32, R36, R40, R42 C!!!! DOUBLE PRECISION R32, R36, R40, R42 PARAMETER ( R32 = 32D0, R36 = 36D0, R40 = 40D0,R42 = 42D0) REAL R45, R49 C!!!! DOUBLE PRECISION R45, R49 PARAMETER ( R45 = 45D0, R49 = 49D0 ) REAL R50, R56, R84, R90 C!!!! DOUBLE PRECISION R50, R56, R84, R90 PARAMETER ( R50 = 50D0, R56 = 56D0, R84 = 84D0,R90 = 90D0) REAL R100, R180, R200 C!!!! DOUBLE PRECISION R100, R180, R200 PARAMETER ( R100 = 100D0, R180 = 180D0, R200 = 200D0 ) REAL R256, R360, R400 C!!!! DOUBLE PRECISION R256, R360, R400 PARAMETER ( R256 = 256D0, R360 = 360D0, R400 = 400D0 ) REAL R600, R681, R991 C!!!! DOUBLE PRECISION R600, R681, R991 PARAMETER ( R600 = 600D0, R681 = 681D0, R991 = 991D0 ) REAL R1162, R2324 C!!!! DOUBLE PRECISION R1162, R2324 PARAMETER ( R1162 = 1162D0, R2324 = 2324D0 ) REAL R10000, R40000 C!!!! DOUBLE PRECISION R10000, R40000 PARAMETER ( R10000 = 10000D0, R40000 = 40000D0 ) C THE RETURN CODES TO BE USED BY THE FUNCTION EVALUATION ROUTINE C TO INDICATE TO THE MINIMIZATION ROUTINE WHETHER OR NOT THE CALL C WAS SUCCESSFUL. INTEGER COK, CABORT, CLIMIT PARAMETER ( COK = 0, CABORT = -1, CLIMIT = -2 ) INTEGER CNOF, CNOG, CNOFG PARAMETER ( CNOF = -3, CNOG = -4, CNOFG = -5 ) C--ON ENTRY: INTEGER CNORML, CRCSTR, CRCRPT, CRCNFG PARAMETER ( CNORML = 0, CRCSTR = 1, CRCRPT = 2, CRCNFG = 3 ) INTEGER CNRMFG, CPSTHR PARAMETER ( CNRMFG = -1, CPSTHR = -2 ) C--ON EXIT: INTEGER CDONE, CRCF, CRCFG, CRCG PARAMETER ( CDONE = 0, CRCF = 1, CRCFG = 2, CRCG = 3 ) INTEGER CNSTOR, CIPMIN, CIPUNF, CBDMTH PARAMETER ( CNSTOR = -1, CIPMIN = -2, CIPUNF = -3, CBDMTH = -4 ) INTEGER CLSFAL, CNODSC, CXSFNC, CPSBCK PARAMETER ( CLSFAL = -5, CNODSC = -6, CXSFNC = -7, CPSBCK = -8 ) INTEGER CRABRT, CUSERV PARAMETER ( CRABRT = -9, CUSERV = -10 ) INTEGER FLETCH, SHNPOW PARAMETER ( FLETCH = 1, SHNPOW = 2 ) INTEGER BRZBR1, BRZBR2, BRZBR3, BRZBR4 PARAMETER ( BRZBR1 = 3, BRZBR2 = 4, BRZBR3 = 5, BRZBR4 = 6 ) INTEGER SUMFRM, PRDFRM, MJDFRM PARAMETER ( SUMFRM = 1, PRDFRM = 2, MJDFRM = 3 ) LOGICAL CMPALL PARAMETER ( CMPALL = T ) REAL NERLY1 C!!!! DOUBLE PRECISION NERLY1 PARAMETER ( NERLY1 = RPT9 ) C## L O C A L D E C L: C-----CONTROL PARAMETERS FOR ENTRY POINT BBLSET. INTEGER METH, QUADIN, ALPIS1, SCGAMM, TRU, HTEST, UPDATT INTEGER SMETH, SQUAD, SALPH1, SSGAMM, STRACU, SHTEST, SUPDAT INTEGER STSTEP INTEGER SSTSTP REAL RO, BETA, SRO, SBETA C!!!! DOUBLE PRECISION RO, BETA, SRO, SBETA LOGICAL FQUAD, DIAGNL, SHANNO, FORCEF, FROMRS LOGICAL SFQUAD, SDIAG, SSHANN, SFORCE, SFROMR LOGICAL RELF, SRELF, RELG, SRELG LOGICAL TR1, TR2, TR3, TR4, TR5, TR6, TR7, TR8, TR9 LOGICAL TR10, TR11, TR12, TR13, TR14, TR15 LOGICAL STRACE(15), ANYTR C-----CONTROLS FOR ENTRY POINTS BBLDDF, BBLIDF, BBLFDF, BBLRDF, BBLSDF. INTEGER SANAL, SDIFF, STEST, SFIRST INTEGER SDOF, SDOG, SDOFG, SNONE, DOF, DOG, DOFG, NONE INTEGER SNRMFG, SNORML, SRCSTR, SRCRPT, SRCNFG, SPSTHR INTEGER NORMFG, NORMAL, RCSTRT, RCRPT, RCNOFG, PSTHRU INTEGER SDONE, SRCF, SRCFG, SRCG, SNSTOR, SIPMIN, SPSBCK INTEGER DONE, RCF, RCFG, RCG, NOSTOR, IPMIN, PSBACK INTEGER SIPUNF, SBDMTH, SLSFAL, SNODSC, SXSFNC, SRABRT, SUSERV INTEGER IPUNDF, BDMETH, LSFAIL, NODESC, XSFUNC, RABORT, USERV INTEGER SOK, SABORT, SLIMIT, SNOF, SNOG, SNOFG INTEGER OK, ABORT, LIMIT, NOF, NOG, NOFG C-----GENERAL DECLARATIONS. INTEGER BASE, CT, INCR, INSTAT, CASE, OTSTAT INTEGER I, J, K, KJ, LASTPT, NCALLS, NUPS, STORAG LOGICAL STEEPD, LESS, QNPART, SCDIAG, RSTEP, ONEUPD, IDENTY LOGICAL LMSTQN, LSDONE, CG, QNSTEP, TOOSML, FRSTRM, BAD LOGICAL FORCER, USESHN, FORCE1, NOUPS, COLD, QUADON, FIRST LOGICAL VALIDF, TESTR, NOPRNT REAL FP, FMIN, ALPHA, AP, DGLAST, DG0, ZZMPAR, ANGLE C!!!! DOUBLE PRECISION FP, FMIN, ALPHA, AP, DGLAST, DG0, ZZMPAR, ANGLE REAL DGP, DGAL, NRMD, NRMG, FLAST, EPS, ETA C!!!! DOUBLE PRECISION DGP, DGAL, NRMD, NRMG, FLAST, EPS, ETA REAL TP0, TP1, TP2, NRMX, ACOS, PI, RADS, WIDTH, DUMMY C!!!! DOUBLE PRECISION TP0, TP1, TP2, NRMX, ACOS, PI, RADS, WIDTH, DUMMY REAL STG, UTG, NU, SIGMA, GAMMA, MU C!!!! DOUBLE PRECISION STG, UTG, NU, SIGMA, GAMMA, MU C-----DECLARATIONS FOR COUNTS AT ENTRY POINT. INTEGER M, CNTRST, MUPS, NRESTR, CNTFOR, NFORCE C## S A V E: C ALL VARIABLES MUST BE SAVED DUE TO THE POSSIBLE USE OF C REVERSE COMMUNICATION. SAVE C## C O M M O N: NONE IS DEFINED. C## D A T A: NONE ARE SET. DATA METH /0/, QUADIN /2/, ALPIS1 /2/, SCGAMM /1/, HTEST /1/ DATA UPDATT /1/, STSTEP /2/ DATA RO/ 0.2D0 /, BETA / 1.0D0 / DATA FQUAD /F/, DIAGNL/F/, SHANNO/F/, FROMRS/F/, FORCEF/T/ DATA RELF /T/, RELG /T/ DATA TRU /6/ DATA DOF/JUSTF/, DOG/JUSTG/, DOFG/BOTH/, NONE/NOOP/ DATA NORMFG/CNRMFG/, NORMAL/CNORML/, RCSTRT/CRCSTR/, - RCRPT /CRCRPT/, RCNOFG/CRCNFG/, PSTHRU/CPSTHR/ DATA DONE /CDONE/, RCF /CRCF/, RCFG /CRCFG/, RCG/CRCG/ - NOSTOR/CNSTOR/, IPMIN /CIPMIN/, IPUNDF/CIPUNF/, - BDMETH/CBDMTH/, LSFAIL/CLSFAL/, NODESC/CNODSC/, - RABORT/CRABRT/, XSFUNC/CXSFNC/, USERV /CUSERV/, - PSBACK/CPSBCK/ DATA OK/ COK/, ABORT/CABORT/, LIMIT/CLIMIT/ DATA NOF/CNOF/, NOFG/CNOFG/, NOG/CNOG/ DATA FIRST/T/ C## E X E C U T I O N C## E X E C U T I O N C-----DEFINE TWO STATEMENT FUNCTIONS. BAD() = CASE .EQ. ABORT .OR. CASE .EQ. LIMIT .OR. CASE .EQ. NOF - .OR. CASE .EQ. NOFG .OR. CASE .EQ. NOG ANGLE(DUMMY) = RADS*ACOS(DUMMY) C-------------------------------------- OK = DONE INSTAT = STATUS IF ( INSTAT .EQ. PSTHRU ) THEN CASE = NONE CALL ZZEVAL (FUNCNM, N, X, FX, G, CASE, IW, RW, DW ) IF ( BAD() ) THEN OTSTAT = RABORT ELSE OTSTAT = PSBACK ENDIF NOPRNT = T GOTO 90000 ENDIF C>>>>>>>>>> P H A S E 0: DESCRIBE PHASES.<<<<<<<<<<<<<<<<<<<<<<<<<<<<< C THE CODE IS IN "PHASES". THE FLOW IS FORWARD TO THE END IN EACH C PHASE. ALL PHASES ARE EXITED ONLY AT THE END OF THE PHASE AND C FLOW PROCEEDS TO THE START OF ANOTHER PHASE, OR IT EXITS THE C ALGORITHM TO STATEMENT 90000. C C THERE IS ONE EXCEPTION, A JUMP TO 92000 AND A RETURN IN PHASE VII C IF REVERSE COMMUNICATION IS BEING USED, ALONG WITH A REENTRY C FROM THE TOP OF PHASE I BACK TO CONTINUE FROM THE POINT OF EXIT C AT 2150. C>>>>>>>>>> P H A S E I: INITIAL SET UP.<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< IF ( ANYTR ) THEN WRITE ( TRU, * ) 'TRACE FLAGS', TR1,TR2,TR3,TR4,TR5,TR6,TR7, - TR8,TR9,TR10,TR11,TR12,TR13,TR14,TR15 ENDIF IF ( FIRST ) THEN PI = ACOS(-ONE) RADS = R180/PI FIRST = F ENDIF NOPRNT = F IF ( INSTAT .EQ. RCRPT .OR. INSTAT .EQ. RCNOFG ) THEN C THIS IS A SUPPLEMENTARY CALL WITH REVERSE COMMUNICATION. OTSTAT = OK VALIDF = INSTAT .EQ. RCRPT GOTO 2150 ENDIF C CHECK ALL PARAMETER SETTINGS VALID. OTSTAT = OK IF ( INSTAT .NE. NORMFG .AND. INSTAT .NE. NORMAL .AND. - INSTAT .NE. RCSTRT ) THEN OTSTAT = 1 + OK ELSE IF ( N .LE. 1 ) THEN OTSTAT = 2 + OK ELSE IF ( ACC .LE. ZERO ) THEN OTSTAT = 3 + OK ELSE IF ( TRU .LE. 0 ) THEN OTSTAT = 4 + OK ELSE IF ( QUADIN .LT. 0 ) THEN OTSTAT = 5 + OK ELSE IF ( ALPIS1 .LT. 0 ) THEN OTSTAT = 6 + OK ELSE IF ( STSTEP .NE. 1 .AND. STSTEP .NE. 2 ) THEN OTSTAT = 7 + OK ELSE IF ( SCGAMM .LT. 0 .OR. SCGAMM .GT. 2 ) THEN OTSTAT = 8 + OK ELSE IF ( HTEST .LT. 0 .OR. HTEST .GT. 2 ) THEN OTSTAT = 9 + OK ELSE IF ( UPDATT .LT. 1 .OR. UPDATT .GT. 3 ) THEN OTSTAT = 10 + OK ENDIF IF ( OTSTAT .NE. OK ) THEN XX(1) = OTSTAT - OK OTSTAT = USERV NOPRNT = T GOTO 90000 ENDIF C INITIALIZE STATUS, CNTRST, ETC. CNTRST = 0 NFORCE = 0 SCDIAG = DIAGNL EPS = FIVE * ZZMPAR(XEPS) C ALLOW FOR DIAGONAL SCALING MATRIX H0. IF ( SCDIAG ) THEN BASE = N ELSE BASE = 0 ENDIF C DETERMINE THE NUMBER OF UPDATES WHICH CAN BE STORED AND C DETERMINE STORAGE REQUIREMENTS. CHOOSE THE METHOD. LMSTQN = F STORAG = ( N*(N+1) ) / 2 IF ( UPDATT .EQ. SUMFRM ) THEN INCR = 2*N + 2 ELSE IF ( UPDATT .EQ. PRDFRM ) THEN INCR = 2*N + 1 ELSE IF ( UPDATT .EQ. MJDFRM ) THEN INCR = 4*N + 1 BASE = BASE + 2*N ENDIF M = (HDIM - BASE) / INCR IF ( METH .EQ. 0 ) THEN IF ( HDIM .GE. STORAG ) THEN CG = F M = -1 ELSE CG = T M = MIN ( M, N ) ENDIF ELSE IF ( METH .EQ. -3 ) THEN CG = T M = 0 ELSE IF ( METH .EQ. -2 ) THEN CG = F M = -1 IF ( HDIM .LT. STORAG ) THEN NOPRNT = T OTSTAT = NOSTOR ENDIF ELSE IF ( METH .EQ. -1 ) THEN CG = T M = MIN ( M, N ) ELSE IF ( METH .GT. 0 ) THEN CG = T M = MIN ( M, METH ) IF ( METH .GE. SPECQN ) LMSTQN = T ELSE NOPRNT = T OTSTAT = BDMETH M = -1 ENDIF IF ( CG ) THEN NOUPS = M .EQ. 0 ONEUPD = M .EQ. 1 USESHN = SHANNO .AND. ONEUPD .AND. UPDATT .EQ. SUMFRM ELSE ONEUPD = F USESHN = T ENDIF IF ( HDIM .LT. BASE ) THEN NOPRNT = T OTSTAT = NOSTOR ENDIF C INITIALIZE FIXED ARGUMENTS INTO SUBROUTINES. CALL BBSLNS ( M, QUADIN, TRU, CG, USESHN, LMSTQN, FQUAD, - TR4, TR5, TR6, ACC ) C CALL BBSMLT ( TR8, TR10, SCDIAG, SCGAMM, TRU, BASE, INCR, BETA ) CALL BBSNOC ( TR8, TR10, SCDIAG, SCGAMM, TRU, BASE, INCR ) CALL BBSCUB ( TR11, TRU ) CALL BBSMJD ( TR8, TR10, TRU) CALL BBSUPD ( M, BASE, INCR, SCGAMM, - CG, SCDIAG, USESHN, FROMRS, TR7, TR2, TR10, TRU) IF ( OTSTAT .EQ. OK .AND. INSTAT .EQ. NORMAL ) THEN C GET INITIAL FUNCTION VALUE (UNLESS REVERSE COMMUNICATION). CASE = DOFG CALL ZZEVAL (FUNCNM, N, X, FX, G, CASE, IW, RW, DW ) IF ( BAD() ) THEN IF ( CASE .EQ. LIMIT ) THEN OTSTAT = XSFUNC ELSE IF ( CASE .EQ. ABORT ) THEN OTSTAT = RABORT ELSE NOPRNT = T OTSTAT = IPUNDF ENDIF ENDIF ENDIF IF ( OTSTAT .EQ. OK ) THEN NRMG = INNER ( N, G, G, DONORM, IW, RW, DW ) IF (TR8 .AND. .NOT. TR1) - WRITE (TRU,*) ' [LNIR] NORM OF G->', NRMG C INITIALIZE THE TERMINATION TESTS. IF ( RELF ) THEN FP = FX ELSE FP = ONE ENDIF IF ( RELG) THEN DGP = NRMG ELSE DGP = ONE ENDIF CALL ZZTINT ( FP, DGP ) IF ( TR1 ) THEN WRITE (TRU,99999) N, HDIM, ACC, INSTAT IF ( DECRF .EQ. ZERO ) THEN WRITE (TRU,99997) FX ELSE IF ( DECRF .LT. ZERO ) THEN WRITE (TRU,99996) DECRF ELSE WRITE (TRU,99995) DECRF ENDIF WRITE (TRU,99994) - METH, QUADIN, ALPIS1,STSTEP,SCGAMM,HTEST,UPDATT, - RO,BETA, - FQUAD, SCDIAG, SHANNO,FROMRS, FORCEF,RELF,RELG, - LMSTQN, CG, USESHN, ONEUPD, - EPS,FP,DGP IF ( CG ) THEN WRITE (TRU,99992) M ELSE WRITE (TRU,99993) STORAG ENDIF IF ( INSTAT .EQ. RCSTRT .OR. INSTAT .EQ. NORMFG ) - WRITE(TRU,99998) FX, NRMG ENDIF C TEST IF THE INITIAL POINT IS THE MINIMIZER. FRSTRM = T CALL ZZTERM ( FRSTRM, N, FX, G, X, X, ACC, LESS ) IF ( LESS ) OTSTAT = IPMIN ENDIF IF ( OTSTAT .NE. OK ) THEN GOTO 90000 ENDIF C>>>>>>>>>> P H A S E II: "COLD START" WITH STEEPEST DESCENT.<<<<<<<<< C CALCULATE THE INITIAL SEARCH DIRECTION. DG0 IS THE CURRENT C DIRECTIONAL DERIVATIVE OF F ALONG D, WHILE NRMG IS THE NORM OF G. C C INITIALIZE CT, WHICH IS USED TO DETERMINE WHETHER A BEALE C RESTART SHOULD BE DONE. I.E. A RESTART MUST BE FORCED AFTER C N STEPS WITHOUT ONE (EXCEPT IN THE SPECIAL CASE "LMSTQN"). INIT- C IALIZE STEEPD, WHICH INDICATES THAT THE CURRENT SEARCH DIRECTION C IS A NEGATIVE GRADIENT DIRECTION. THE CURRENT POINT IS X[0]. 20 STEEPD = T COLD = T CT = 0 IF ( CG ) THEN LASTPT = N NUPS = 0 QNPART = F ENDIF CALL ZZPRNT ( N, X, FX, G, NRMG, 1 ) CALL BBINIH ( N, X, G, H, NRMG, IDENTY, SCDIAG, UPDATT, - INNER, IW, RW, DW ) C GET INITIAL SEARCH DIRECTION. IF ( .NOT. CG ) THEN CALL ZZCOPY ( N, G, 1, D, 1 ) ELSE IF ( UPDATT .EQ. SUMFRM ) THEN CALL BBMULT(H, G, D, N, NUPS, T, IDENTY, INNER, IW, RW, DW ) ELSE IF ( UPDATT .EQ. PRDFRM ) THEN CALL BBNOCE( H, G, D, N, CT, M, IDENTY, GG, INNER,IW,RW,DW) ELSE IF ( UPDATT .EQ. MJDFRM ) THEN CALL BBPOWL(H, G, D, N, NUPS, M, IDENTY, SCDIAG,INNER,IW,RW,DW) ENDIF CALL ZZSCAL ( N, -ONE, D, 1 ) NRMD = INNER ( N, D, D, DONORM, IW, RW, DW ) DG0 = INNER ( N, D, G, NONORM, IW, RW, DW ) C>>>>>>>>>> P H A S E III: START ITERATION ALONG D[CT].<<<<<<<<<<<<<<<< C BEGIN THE MAJOR ITERATION LOOP. NCALLS IS USED TO GUARANTEE THAT C AT LEAST TWO POINTS HAVE BEEN TRIED WHEN METH=CG (SEE FQUAD). C FMIN IS THE CURRENT FUNCTION VALUE. FORCE A RESTART AFTER C N STEPS. OUTPUT (IF DESIRED) AT START OF EACH ITERATION. 1600 FMIN = FX NCALLS = 0 NRMX = MAX ( ONE, REAL(INNER (N,X,X,DONORM,IW,RW,DW)) ) C!!!! NRMX = MAX ( ONE, INNER (N,X,X,DONORM,IW,RW,DW) ) QUADON = F IF ( TR8 ) WRITE (TRU,*) ' [LNIR] NORM OF X->', NRMX IF ( TR9 ) WRITE (TRU,*) ' [LNIR] X->',X IF ( TR8 ) WRITE (TRU,*) ' [LNIR] NORM OF D->', NRMD IF ( TR9 ) WRITE (TRU,*) ' [LNIR] D->',D C SET CT TO THE INDEX OF THE POINT TO WHICH THE SEARCH WILL LEAD. C = THE INDEX OF THE CURRENT SEARCH DIRECTION. CT = CT + 1 C>>>>>>>>>> P H A S E IV: INITIALIZE ALPHA FOR LINE SEARCH.<<<<<<<<<<<< LSDONE = F IF ( TR4 ) WRITE(TRU,*) ' [LNIR] START LS->' IF ( TR4 ) WRITE(TRU,*) ' CT,QNPART,LMSTQN,STEEPD,COLD,USESHN->', - CT,QNPART,LMSTQN,STEEPD,COLD,USESHN IF ( TR5 ) THEN IF ( ABS(DG0) .LE. NRMG*NRMD ) THEN WRITE(TRU,*) ' [LNIR] ANGLE OF D TO -G->', - ANGLE(-DG0/(NRMG*NRMD)) ,' DEGREES' ELSE WRITE(TRU,*) ' [LNIR] WARNING...ON ANGLE OF D TO -G'// - ' WE HAVE DG0 > NRMG*NRMD ->', DG0,NRMG*NRMD ENDIF ENDIF IF ( COLD ) THEN IF ( TR6 ) WRITE(TRU,*) ' [LNIR] FIRST CASE ALPHA.' C --FIRST ITERATION. SCALE STEP TO ONE. USE ESTIMATE DECRF. IF ( DECRF .EQ. ZERO ) THEN TP1 = TWO * ABS(FX) / NRMG ELSE IF ( DECRF .GT. ZERO ) THEN TP1 = TWO * DECRF / NRMG ELSE TP1 = ONE ENDIF IF ( CG .AND. SCDIAG ) THEN ALPHA = TP1 ELSE ALPHA = TP1 / NRMG ENDIF ELSE IF ( CG ) THEN IF ( USESHN ) THEN IF ( CT .EQ. M+1 ) THEN IF ( TR6 ) WRITE(TRU,*) ' [LNIR] ALPHA IS ONE.' ALPHA = ONE ELSE IF ( TR6 ) WRITE(TRU,*) ' [LNIR] SHANNO SCALE ALPHA.' ALPHA = ALPHA * ( DGLAST / DG0 ) ENDIF ELSE QNSTEP = .NOT. NOUPS - .AND. ( ALPIS1 .GT. 0 ) - .AND. ( CT .LT. M + ALPIS1 ) FORCE1 = LMSTQN .OR. QNSTEP .OR. ( ALPIS1 .GT. 3 ) IF ( FORCE1 ) THEN IF ( TR6 ) WRITE(TRU,*) ' [LNIR] FORCE ALPHA TO 1.' ALPHA = ONE ELSE IF ( STSTEP .EQ. FLETCH ) THEN IF (TR6) WRITE(TRU,*) ' [LNIR] FLETCHER SCALE ALPHA.' ALPHA = ALPHA * TWO * (FX - FLAST) / (DG0) ELSE IF ( STSTEP .EQ. SHNPOW ) THEN IF (TR6)WRITE(TRU,*) ' [LNIR] SH./POW. SCALE ALPHA' ALPHA = ALPHA * (DGLAST / DG0) ENDIF ENDIF ENDIF ELSE C THIS IS THE QN CASE. ALPHA = ONE ENDIF IF (TR6)WRITE(TRU,*) ' [LNIR] END OF PHASE IV, ALPHA = ',ALPHA C>>>>>>>>>> P H A S E V: INITIALIZE LINE SEARCH.<<<<<<<<<<<<<<<<<<<<<<< C THE LINE SEARCH FITS A CUBIC TO FX AND DGAL, THE FUNCTION AND ITS C DERIVATIVE AT ALPHA, AND TO FP AND DGP, THE FUNCTION AND ITS DERI- C VATIVE AT THE PREVIOUS TRIAL POINT AP, WHERE THE DERIVATIVES ARE C ALONG D. INITIALIZE AP, FP AND DGP. AP = ZERO FP = FMIN DGP = DG0 C SAVE THE CURRENT DERIVATIVE ALONG D AND THE FUNCTION VALUE TO C SCALE THE INITIAL STEP ALONG THE NEXT SEARCH VECTOR. DGLAST = DG0 FLAST = FMIN C STORE THE CURRENT X AND G. CALL ZZCOPY ( N, X, 1, XX, 1 ) CALL ZZCOPY ( N, G, 1, GG, 1 ) C THIS NEXT LITTLE LOOP AVOIDS THE POSSIBILITY OF A C RIDICULOUSLY SMALL VALUE FOR ALPHA. 1900 IF ( FX+ ALPHA*DG0 .LT. FX + NERLY1*ALPHA*DG0 ) THEN WIDTH = ALPHA ELSE ALPHA = TWO * ALPHA GOTO 1900 ENDIF C>>>>>>>>>> P H A S E VI: TEST FOR LINE SEARCH FAILURE.<<<<<<<<<<<<<<<< 2000 CONTINUE IF ( TR3 ) WRITE(TRU,*) ' [LNIR] LS ALPHA->',ALPHA IF ( TR5 ) WRITE(TRU,*) ' [LNIR] VALUES: AP,FP,DGP,DGLAST,DG0,' - //'FLAST,FMIN,NRMD->' IF ( TR5 ) WRITE(TRU,*) AP,FP,DGP,DGLAST,DG0,FLAST,FMIN,NRMD IF ( USESHN ) THEN TOOSML = ALPHA * NRMD .LE. EPS ELSE TOOSML = WIDTH * NRMD .LE. EPS * NRMX ENDIF IF ( TOOSML ) THEN C THIS IS AN ABNORMALLY SMALL STEP. TEST IF THE DIRECTION C IS A GRADIENT DIRECTION. IF NOT, TRY ONE BEFORE ABORTING C THE RUN; I.E. DO A TOTAL RESTART FROM SCRATCH UNLESS THIS C STEP IS ALREADY A STEEPEST DESCENT STEP FROM A COLD START. IF ( TR6 ) WRITE(TRU,*) ' [LNIR] ALPHA TOO SMALL.' IF ( TR8 ) WRITE(TRU,*) ' [LNIR] EPS,WIDTH->', EPS,WIDTH IF ( COLD ) THEN OTSTAT = LSFAIL GOTO 90000 ELSE GOTO 20 ENDIF ENDIF C>>>>>>>>>> P H A S E VII: LINE SEARCH LOOP.<<<<<<<<<<<<<<<<<<<<<<<<<<< C LSDONE IS SET TO TRUE WHEN THE LINE SEARCH IS DEEMED COMPLETE. C EACH LOOP DETERMINES A NEW VALUE FOR ALPHA AND RETURNS TO 2000 C UNLESS THE SEARCH HAS BEEN DEEMED COMPLETE. C COMPUTE THE NEW TRIAL POINT. CALL ZZCOPY ( N, XX, 1, X, 1 ) CALL ZZAXPY ( N, ALPHA, D, 1, X, 1 ) C EVALUATE THE FUNCTION AT THE TRIAL POINT. IF ( INSTAT .EQ. RCSTRT .OR. INSTAT .EQ. RCRPT - .OR. INSTAT .EQ. RCNOFG ) THEN C EXIT FOR REVERSE COMMUNICATION. (RE-ENTRY WILL BE TO 2150) NOPRNT = T OTSTAT = RCFG GOTO 90000 ELSE CASE = DOFG VALIDF = T CALL ZZEVAL (FUNCNM, N, X, FX, G, CASE, IW, RW, DW ) IF ( BAD() ) THEN IF ( CASE .EQ. LIMIT ) THEN OTSTAT = XSFUNC ELSE IF ( CASE .EQ. ABORT ) THEN OTSTAT = RABORT ELSE VALIDF = F ENDIF ENDIF ENDIF 2150 IF ( OTSTAT .EQ. OK ) THEN NCALLS = NCALLS + 1 C COMPUTE THE DIRECTIONAL DERIVATIVE OF F ALONG D AT ALPHA. DGAL = INNER ( N, D, G, NONORM, IW, RW, DW ) NRMG = INNER ( N, G, G, DONORM, IW, RW, DW ) IF ( TR5 ) WRITE (TRU,*) ' [LNIR] NORM OF G->', NRMG IF ( TR5 ) THEN IF ( ABS(DGAL) .LE. NRMG*NRMD ) THEN WRITE(TRU,*) ' [LNIR] ANGLE OF D TO -G->', - ANGLE(-DGAL/(NRMG*NRMD)) ,' DEGREES' ELSE WRITE(TRU,*) ' [LNIR] WARNING...ON ANGLE OF D TO -G'// - ' WE HAVE DGAL > NRMG*NRMD ->', DGAL,NRMG*NRMD ENDIF ENDIF IF (TR5) WRITE(TRU,*)' [LNIR] SEARCH: ALPHA,NRMD,EPS,FX->', - ALPHA,NRMD,EPS,FX IF (TR10 .AND. TR5) WRITE(TRU,*) ' [LNIR] X->', X CALL BBLINS ( ALPHA, FX, DGAL, VALIDF, FMIN, DGLAST, AP, FP, - DGP, WIDTH, NOUPS, LSDONE, CT, NCALLS, QUADON, UPDATT ) IF ( .NOT. LSDONE ) THEN C CHECK POINTS NOT ACTUALLY IDENTICAL FROM ROUNDOFF. DO 2500 I = 1,N TP0 = XX(I) + ALPHA*D(I) IF ( TP0 .NE. XX(I) .AND. TP0 .NE. X(I) ) THEN GOTO 2600 ENDIF 2500 CONTINUE C IF IDENTICAL, THEN FORCE TERMINATION WITH ERROR. WIDTH = ZERO 2600 GOTO 2000 ENDIF ELSE GOTO 90000 ENDIF C FLOW CONTINUES TO PHASE VIII IF THE LINE SEARCH IS DONE C OR RETURNS TO 2000 IF NOT. C>>>>>>>>>> P H A S E VIII: TERMINATION TEST.<<<<<<<<<<<<<<<<<<<<<<<<<< FRSTRM = F CALL ZZTERM ( FRSTRM, N, FX, G, X, XX, ACC, LESS ) IF ( TR7 ) WRITE(TRU,*) ' [LNIR] TERM? LESS->',LESS IF ( .NOT. LESS ) THEN CALL ZZPRNT ( N, X, FX, G, NRMG, 1 ) ELSE GOTO 90000 ENDIF C>>>>>>>>>> P H A S E IX: TEST IF RESTART NEEDED.<<<<<<<<<<<<<<<<<<<<<< C SEARCH CONTINUES. SET D(CT)=ALPHA*D(CT), SO THE FULL STEP VECTOR C S IS IN D. ALSO COMPUTE NRMG. CALL ZZSCAL ( N, ALPHA, D, 1 ) C CHECK IF A RESTART IS TO BE FORCED. FORCER = CG .AND. UPDATT .EQ. SUMFRM - .AND. ( .NOT. LMSTQN ) - .AND. ( (CT .GT. LASTPT) .OR. (STEEPD .AND. FORCEF) ) IF (TR7)WRITE(TRU,*) ' [LNIR] FORCER, CT,LASTPT,STEEPD,FORCEF->', - FORCER, CT,LASTPT,STEEPD,FORCEF IF ( CG .AND. UPDATT .EQ. SUMFRM ) THEN C DETERMINE WHICH PART OF THE ALGORITHM WE ARE IN C FOR NEXT STEP. QNPART = ( FORCER .AND. M .NE. 0 ) - .OR. ( QNPART .AND. CT .LE. M ) TESTR = .NOT. QNPART .AND. CT .GT. M+1 ELSE IF ( CG .AND. UPDATT .EQ. PRDFRM ) THEN QNPART = T ELSE IF ( CG .AND. UPDATT .EQ. MJDFRM ) THEN QNPART = T ENDIF IF ( FORCER ) THEN RSTEP = T ELSE IF - ( CG .AND. UPDATT .EQ. SUMFRM - .AND. (TESTR) - .AND. HTEST .NE. 0 ) THEN IF ( TR7 ) WRITE(TRU,*) ' [LNIR] CG PART: RESTART?' C MUST BE IN CG SEQUENCE, SO MUST CHECK IF C RESTART IS NEEDED ACCORDING TO POWELL CRITERION. CAN APPLY C IN METRIC DEFINED BY H OR BY I; I.E. USING G'*H*G, OR C G'*G. COMPUTE VALUES FOR RESTART TEST. IF ( HTEST .EQ. 2 .AND. .NOT. USESHN ) THEN C POWELL'S TEST WITH H AS CURRENTLY DEFINED. C USE XX AS TEMPORARY STORAGE FOR H*G. CALL BBMULT (H, G, XX, N, NUPS, T, IDENTY, INNER, IW, RW,DW) TP1 = INNER ( N, XX, GG, NONORM, IW, RW, DW ) TP2 = INNER ( N, XX, G, NONORM, IW, RW, DW ) ELSE C THE ORDINARY TEST; ESSENTIALLY POWELL'S TEST WITH H = I . TP1 = INNER ( N, G, GG, NONORM, IW, RW, DW ) TP2 = NRMG**2 ENDIF IF ( TR7 ) WRITE(TRU,*) ' [LNIR] RESTART IF TP1(',TP1, - ') > RO*TP2 (',RO*TP2,')' C SET RESTART FLAG IF TAU[CT] > RO; NOTE THAT TAU = TP1/TP2 C BUT THE TEST IS DONE WITHOUT THE DIVIDE. RSTEP = ABS(TP1) .GT. ABS(RO*TP2) IF ( RSTEP ) NFORCE = NFORCE + 1 ELSE IF ( TR7 ) WRITE (TRU,*) ' [LNIR] NO RESTART TEST.' RSTEP = F ENDIF C>>>>>>>>>> P H A S E X: UPDATE FOR NEXT STEP.<<<<<<<<<<<<<<<<<<<<<<<<< C WE NOW CALL A ROUTINE TO UPDATE H FROM ITS VALUE AT C THE LAST POINT TO ITS VALUE AT THE POINT WHICH WE HAVE C JUST REACHED AT THE END OF THIS LINE SEARCH. THE DETAILS C OF THE UPDATING ARE IN BBUPDT. NOTE THAT, IN THE CG CASE, C THE NEGATIVE OF THE NEXT SEARCH DIRECTION MUST ALSO BE C RETURNED. CALL ZZAXPY ( N, -ONE, G, 1, GG, 1 ) CALL ZZSCAL ( N, -ONE, GG, 1 ) ETA = INNER ( N, D, GG, NONORM, IW, RW, DW ) CALL BBUPDT (N, G, D, XX, GG, H, ETA, CT, CNTRST, LASTPT, - IDENTY, NUPS, STEEPD, RSTEP, QNPART, ALPHA, - STG, UTG, NU, UPDATT, INNER, IW,RW,DW) C>>>>>>>>>> P H A S E XI: COMPUTE NEW DIRECTION.<<<<<<<<<<<<<<<<<<<<< IF ( CG ) THEN C FIRST GET THE NEGATIVE OF THE NEW SEARCH DIRECTION INTO XX. IF ( RSTEP ) THEN CALL BBMULT ( H, G, XX, N, NUPS, CMPALL, IDENTY, - INNER, IW, RW, DW ) ELSE IF ( UPDATT .EQ. SUMFRM ) THEN C NOTE THAT U=H*Y IS IN XX FROM UPDATE. C COMPUTE H^*G BY PUTTING H*G INTO GG AND THEN WORKING IN C THE NEW UPDATE TERM. THIS MUST BE DONE SEPARATELY SINCE THE C NEW UPDATE MAY NOT BE SAVED. NOTE THAT THIS IS NOT AN INIT- C IAL STEP, SO WE ONLY DO THE GAMMA SCALING IF SCGAMM=GAMALL. CALL BBMULT (H, G, GG, N, NUPS, T, IDENTY, INNER, IW,RW,DW) IF ( QNPART ) THEN CALL ZZCOPY ( N, GG, 1, XX, 1 ) ELSE IF ( SCGAMM .EQ. GAMALL ) THEN SIGMA = ( TWO*STG/ETA) - (UTG/NU) MU = -STG/NU GAMMA = ETA/NU ELSE SIGMA = ( (ONE + NU/ETA)*STG - UTG ) / ETA MU = -STG/ETA GAMMA = ONE ENDIF C NOW COMPUTE H^*G INTO XX. CALL ZZSCAL ( N, MU, XX, 1 ) CALL ZZAXPY ( N, SIGMA, D, 1, XX, 1 ) CALL ZZAXPY ( N, GAMMA, GG, 1, XX, 1 ) ENDIF ELSE IF ( UPDATT .EQ. PRDFRM ) THEN CALL BBNOCE ( H, G, XX, N, CT, M, IDENTY, GG, - INNER, IW, RW, DW ) ELSE IF ( UPDATT .EQ. MJDFRM ) THEN CALL BBPOWL ( H, G, XX, N, NUPS, M, IDENTY, SCDIAG, - INNER, IW, RW, DW ) ENDIF CALL ZZCOPY ( N, XX, 1, D, 1 ) CALL ZZSCAL ( N, -ONE, D, 1 ) C CALCULATE THE DERIVATIVE DG0 ALONG THE NEW SEARCH VECTOR D. DG0 = INNER ( N, D, G, NONORM, IW, RW, DW ) NRMD = INNER ( N, D, D, DONORM, IW, RW, DW ) IF ( TR7 ) WRITE(TRU,*) ' [LNIR] NEW D USING CG.' ELSE C QN CASE: CALCULATE THE NEW SEARCH DIRECTION D(CT+1) = -H!*G C AND THE DIRECTIONAL DERIVATIVE DG0 = D'G OF F ALONG D. C H! IS IN H. DO 8000 K=1,N TP0 = ZERO KJ = K DO 7600 J=1,K-1 TP0 = TP0 - H(KJ)*G(J) KJ = KJ + (N-J) 7600 CONTINUE DO 7800 J=K,N TP0 = TP0 - H(KJ)*G(J) KJ = KJ + 1 7800 CONTINUE D(K) = TP0 8000 CONTINUE NRMD = INNER ( N, D, D, DONORM, IW, RW, DW ) DG0 = ZERO DO 8200 K = 1,N DG0 = DG0 + G(K)*D(K) 8200 CONTINUE ENDIF C ...FOR THE COMPUTATION OF D. C TEST FOR A DOWNHILL DIRECTION. IF ( DG0 .GE. ZERO ) THEN IF ( ANYTR ) THEN WRITE (TRU,*) ' [LNIR] ***FAILING*** NONDOWNHILL DIRECTION!' WRITE (TRU,*) ' ***DG0->',DG0,'***' ENDIF OTSTAT = NODESC ELSE STEEPD = NOUPS .AND. RSTEP ENDIF IF ( OTSTAT .NE. OK ) THEN GOTO 90000 ELSE COLD = F GOTO 1600 ENDIF C## E N T R Y BBLSET: ENTRY BBLSET ( SMETH, SQUAD, SALPH1, SSTSTP, SSGAMM, SHTEST, - SUPDAT, SRO, SBETA, - SFQUAD, SDIAG, SSHANN, SFROMR, SFORCE, - SRELF, SRELG, - STRACU, STRACE ) METH = SMETH QUADIN = SQUAD ALPIS1 = SALPH1 STSTEP = SSTSTP SCGAMM = SSGAMM HTEST = SHTEST UPDATT = SUPDAT RO = SRO BETA = SBETA FQUAD = SFQUAD DIAGNL = SDIAG SHANNO = SSHANN FROMRS = SFROMR FORCEF = SFORCE RELF = SRELF RELG = SRELG TRU = STRACU TR1 = STRACE( 1) TR2 = STRACE( 2) TR3 = STRACE( 3) TR4 = STRACE( 4) TR5 = STRACE( 5) TR6 = STRACE( 6) TR7 = STRACE( 7) TR8 = STRACE( 8) TR9 = STRACE( 9) TR10 = STRACE(10) TR11 = STRACE(11) TR12 = STRACE(12) TR13 = STRACE(13) TR14 = STRACE(14) TR15 = STRACE(15) ANYTR= TR1 .OR. TR2 .OR. TR3 .OR. TR4 .OR. TR5 - .OR. TR6 .OR. TR7 .OR. TR8 .OR. TR9 .OR. TR10 - .OR. TR11 .OR. TR12 .OR. TR13 .OR. TR14 .OR. TR15 RETURN C## E N T R Y BBLDDF: C SET CODES FOR DERIVATIVE EVALUATION MODES. ENTRY BBLDDF ( SANAL, SDIFF, STEST, SFIRST ) CALL ZZEDDF ( SANAL, SDIFF, STEST, SFIRST ) CALL BBDVAL ( SANAL ) RETURN C## E N T R Y BBLFDF: C SET CODES FOR FUNCTION/GRADIENT EVALUATION CHOICES C *PASSED TO* FUNCTION EVALUATION ROUTINE. ENTRY BBLFDF ( SDOF, SDOG, SDOFG, SNONE ) DOF = SDOF DOG = SDOG DOFG = SDOFG NONE = SNONE CALL ZZEFDF ( DOF, DOG, DOFG, NONE ) RETURN C## E N T R Y BBLIDF: C SET VALUES FOR STATUS *PASSED INTO* BBLNIR. ENTRY BBLIDF ( SNRMFG, SNORML, SRCSTR, SRCRPT, SRCNFG, SPSTHR ) NORMFG = SNRMFG NORMAL = SNORML RCSTRT = SRCSTR RCRPT = SRCRPT RCNOFG = SRCNFG PSTHRU = SPSTHR CALL BBVIDF ( SNRMFG, SNORML, SRCSTR, SRCRPT, SRCNFG, SPSTHR ) RETURN C## E N T R Y BBLSDF: C SET VALUES FOR STATUS *RETURNED BY* BBLNIR. ENTRY BBLSDF ( SDONE, SRCF, SRCFG, SRCG, SNSTOR, SIPMIN, - SIPUNF, SBDMTH, SLSFAL, SNODSC, SXSFNC, SRABRT, SUSERV, - SPSBCK ) DONE = SDONE RCF = SRCF RCFG = SRCFG RCG = SRCG NOSTOR = SNSTOR IPMIN = SIPMIN IPUNDF = SIPUNF BDMETH = SBDMTH LSFAIL = SLSFAL NODESC = SNODSC XSFUNC = SXSFNC RABORT = SRABRT USERV = SUSERV PSBACK = SPSBCK CALL BBVSDF ( SDONE, SRCF, SRCFG, SRCG, SNSTOR, SIPMIN, - SIPUNF, SBDMTH, SLSFAL, SNODSC, SXSFNC, SRABRT, SUSERV, - SPSBCK ) RETURN C## E N T R Y BBLRDF: C SET VALUES FOR CODES *RETURNED BY* FUNCTION EVALUATION ROUTINE. ENTRY BBLRDF ( SOK, SABORT, SLIMIT, SNOF, SNOG, SNOFG ) OK = SOK ABORT = SABORT LIMIT = SLIMIT NOF = SNOF NOG = SNOG NOFG = SNOFG CALL ZZERDF ( SOK, SABORT, SLIMIT, SNOF, SNOG, SNOFG ) RETURN C## E N T R Y BBVGET: ENTRY BBVGET ( NRESTR, MUPS, CNTFOR ) NRESTR = CNTRST IF ( CG ) THEN MUPS = M ELSE MUPS = -1 ENDIF CNTFOR = NFORCE RETURN C## E X I T 90000 IF ( .NOT. NOPRNT ) CALL ZZPRNT ( N, X, FX, G, NRMG, -1 ) STATUS = OTSTAT RETURN C## F O R M A T S: 99999 FORMAT ( ' **** BBLNIR ENTERED AND INITIALIZATION COMPLETE ****'/ - / - ' DIMENSION = ', I5, T40, - ' MEMORY AVAILABLE IS ', I7/ - ' ACCURACY REQUESTED = ', G15.7, T40, - ' STATUS ON ENTRY IS ', I2 ) 99998 FORMAT ( ' ON ENTRY, VALUES WERE DEFINED FOR FX AS ',G25.17/ - ' AND FOR THE NORM OF G AS ',G25.8 ) 99997 FORMAT ( ' EXPECTED REDUCTION IN F EQUALS INITIAL FUNCTION', - ' VALUE OF ',G15.7 ) 99996 FORMAT ( ' EXPECTED REDUCTION IN F IS UNKNOWN (DECRF=',G8.1,')') 99995 FORMAT ( ' EXPECTED REDUCTION IN F IS ',G15.7 ) 99994 FORMAT ( ' INTEGER CONTROL SETTINGS METH QUADIN ALPIS1 STSTEP', - ' SCGAMM HTEST UPDATT'/ - ' ', 7I7/ - ' REAL CONTROL VALUES RO = ', G15.7, ' BETA = ',G15.7/ - ' LOGICAL CONTROL VALUES FQUAD SCDIAG SHANNO FROMRS'/ - ' ', 4L7 / - ' FORCEF RELF RELG '/ - ' ', 3L7 / - / - ' THE FOLLOWING HAVE BEEN SET DURING INITIALIZATION ' / - ' LMSTQN (',L1,'); CG (', L1,'); USESHN (',L1, - '); ONEUPD (',L1,')'/ - ' MACHINE RELATIVE ACCURACY EPS = ', E8.2/ - ' TERMINATION RELATIVE TO ', G14.7,'(F); ',G14.7,'(G)' ) 99993 FORMAT ( ' STORAGE OF ', I6, ' SUFFICIENT; USING QN ALGORITHM.' /) 99992 FORMAT ( ' STORAGE LIMITED; USING ', I3, ' UPDATES.' /) C## E N D OF BBLNIR. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> mjdpsg.f SUBROUTINE BBMJDP ( DIAG, U, W, Z, PHI, VV, DELT, GAM, Y, - V, HV, N, NUPS, I, M, SCDIAG, IDENTY, INNER, IW, RW, DW ) C## A R G U M E N T S: INTEGER N, NUPS, I, M, IW(*) LOGICAL IDENTY, SCDIAG REAL V(N), HV(N), DIAG(N), W(N), Z(N), U(N) C!!!! DOUBLE PRECISION V(N), HV(N), DIAG(N), W(N), Z(N), U(N) REAL PHI(0:M-1), VV(N,0:M-1), DELT(N,0:M-1) C!!!! DOUBLE PRECISION PHI(0:M-1), VV(N,0:M-1), DELT(N,0:M-1) REAL Y(N,0:M-1), GAM(N,0:M-1) C!!!! DOUBLE PRECISION Y(N,0:M-1), GAM(N,0:M-1) EXTERNAL INNER DOUBLE PRECISION DW(*), INNER REAL RW(*) C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C>RCS $HEADER: MJDP.F,V 1.12 91/12/16 12:00:37 BUCKLEY EXP $ C>RCS $LOG: MJDP.F,V $ C>RCS REVISION 1.12 91/12/16 12:00:37 BUCKLEY C>RCS MINOR FIX FOR TOMS. C>RCS C>RCS REVISION 1.11 91/11/22 11:30:55 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.10 90/07/31 10:49:56 BUCKLEY C>RCS ADDED REVISED BLAS. C>RCS C>RCS REVISION 1.9 89/06/30 13:12:48 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3 89/05/18 12:39:22 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:55:32 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:54:29 BUCKLEY C>RCS INITIAL REVISION C>RCS C## D E S C R I P T I O N: C GIVEN THE QUASI NEWTON UPDATE MATRIX H (IN ZZ' FORM) AND C GIVEN THE VECTOR V, THIS ROUTINE COMPUTES C C HV = H * V . C C IT ALSO RETURNS THE INTERMEDIATE VALUE U = Z' * V. C C IT ASSUMES HERE THAT Z REPRESENTS THE MATRIX Z[I] AT THE C POINT X[I]. C C THE DESCRIPTION OF THE ARGUMENTS IS GIVEN IN BBPOWL. C C------TRACES: NOTE THAT THE TRACE PARAMETERS WILL BE THE SAME C FOR EACH CALL TO BBMJDP DURING ANY PARTICULAR MINIMIZATION C PROBLEM, SO THEY ARE SET JUST ONCE THROUGH AN ENTRY POINT. C C THESE WILL BE ON THE UNIT TRU. C VECTORS ARE TRACED ONLY IF TRV IS TRUE AS WELL. C C## E N T R Y P O I N T S: BBMJDP THE NATURAL ENTRY POINT. C BBSMJD FOR UNCHANGING ARGUMENTS. C## S U B R O U T I N E S: INNER (PASSED AS ARGUMENT) C MAX, MIN, SQRT ...INTRINSIC C## P A R A M E T E R S: LOGICAL DONORM, NONORM PARAMETER ( DONORM = .TRUE., NONORM = .FALSE. ) REAL ZERO, ONE, TWO, THREE C!!!! DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) REAL FOUR, FIVE, SIX, SEVEN C!!!! DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) REAL EIGHT, NINE, TEN C!!!! DOUBLE PRECISION EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 9D0, TEN = 10D0 ) C## L O C A L D E C L: INTEGER K, J INTEGER LOWROW, HIROW REAL ZETA, TMP C!!!! DOUBLE PRECISION ZETA, TMP C----- VARIABLES FOR THE ENTRY POINT. LOGICAL TR, STR, TRV, STRV INTEGER TRU, STRACN C## S A V E: SAVE TR, TRV, TRU C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NO DATA VALUES SET. C## E X E C U T I O N C## E X E C U T I O N IF ( TR ) WRITE (TRU,*) ' ***[MJDP ENTERED]***' IF ( TR ) WRITE (TRU,*) ' [MJDP] SCDIAG,N,NUPS,I,M,IDENTY=', - SCDIAG,N,NUPS,I,M,IDENTY IF ( NUPS .EQ. 0 ) THEN DO 100 K = 1,N IF (SCDIAG) THEN TMP = DIAG(K) ELSE TMP = ONE ENDIF U(K) = TMP*V(K) HV(K) = TMP**2 * V(K) 100 CONTINUE ELSE IF ( TR .AND. TRV ) THEN CALL ZZWMAT( 0,' [MJDP] Y',ONE,Y,ZERO,Y,N,1,N,1,I, - 'F',9,4,1,80,TRU) ENDIF IF (SCDIAG) THEN TMP = Y(N,0)*DIAG(N) ELSE TMP = Y(N,0) ENDIF DO 200 K = 1,N HV(K) = ZERO 200 CONTINUE IF ( TR .AND. TRV ) THEN CALL ZZWMAT(0,' [MJDP] DELT',ONE,DELT,ZERO,DELT,N,1,N,1,I, - 'F',9,4,1,80,TRU) CALL ZZWMAT(0,' [MJDP] GAM',ONE,GAM,ZERO,GAM,N,1,N,1,I, - 'F',9,4,1,80,TRU) ENDIF CALL ZZCOPY( N, DELT(1,0), 1, VV(1,0), 1 ) CALL ZZSCAL( N, -TMP*GAM(N,0), VV(1,0), 1 ) VV(N,0) = TMP + VV(N,0) PHI(0) = Y(N,0)**2 DO 4000 K = N, 3-I, -1 C K-1 IS STARTING COLUMN ALONG BOTTOM LEVEL OF TABLE LOWROW = MAX(0,2-K) HIROW = MIN(I-1,N-K) IF(TR) WRITE(TRU,*) ' [MJDP] OUTER LOOP: K=',K DO 3000 J = LOWROW, HIROW C J IS CURRENT LEVEL IN TABLE, SO THAT C J+K-1=K-1+J IS CURRENT COLUMN AND C J+K IS NEXT COLUMN TO RIGHT C WE ARE COMPUTING Z FOR ROW J+1 IF(TR) WRITE(TRU,*) ' [MJDP] INNER LOOP: J=',J ZETA = SQRT( PHI(J)/(PHI(J)+Y(K+J-1,J))**2 ) IF ( J .EQ. 0 ) THEN IF (SCDIAG) THEN TMP = DIAG(K-1) ELSE TMP = ONE ENDIF CALL ZZCOPY ( N, DELT(1,0), 1, W, 1 ) CALL ZZSCAL ( N, -GAM(K-1,0)*TMP, W, 1 ) W(K-1) = TMP + W(K-1) ELSE IF ( J+K .EQ. 2 ) THEN C IN COLUMN 1 SINCE J+K-1=1 IF (TR) WRITE(TRU,*) ' [MJDP] CREATING Z FROM ', - 'DELT SUB ', J-1 TMP = INNER (N,GAM(1,J),DELT(1,J-1),NONORM,IW,RW,DW) CALL ZZCOPY ( N, DELT(1,J-1), 1, W, 1 ) CALL ZZAXPY ( N, -TMP, DELT(1,J), 1, W, 1 ) ELSE TMP = INNER (N, GAM(1,J), Z, NONORM,IW,RW,DW) CALL ZZCOPY ( N, Z, 1, W, 1 ) CALL ZZAXPY ( N, -TMP, DELT(1,J), 1, W, 1 ) ENDIF IF(TR) WRITE(TRU,*) ' [MJDP] COMPUTING Z' CALL ZZCOPY ( N, W, 1, Z, 1 ) CALL ZZAXPY ( N, Y(K+J-1,J)/PHI(J), VV(1,J), 1, Z, 1 ) CALL ZZSCAL ( N, ZETA, Z, 1 ) IF ( J+K .GT. 2 ) THEN IF(TR) WRITE(TRU,*) ' [MJDP] UPDATING VV, PHI',J, - ' WITH Y; LEVEL ',K+J-1 CALL ZZAXPY ( N, Y(K+J-1,J), W, 1, VV(1,J), 1 ) PHI(J) = PHI(J) + Y(K+J-1,J)**2 ENDIF 3000 CONTINUE J = HIROW + 1 IF ( J .LT. I ) THEN IF(TR) WRITE(TRU,*) ' [MJDP] INITIALIZING VV',J TMP = INNER(N, GAM(1,J), Z, NONORM,IW,RW,DW) CALL ZZCOPY ( N, Z, 1, VV(1,J), 1 ) CALL ZZAXPY ( N, -TMP, DELT(1,J), 1, VV(1,J), 1 ) CALL ZZSCAL ( N, Y(N,J), VV(1,J), 1 ) PHI(J) = Y(N,J)**2 ELSE IF(TR) WRITE(TRU,*) ' [MJDP] TOP ROW: UPDATING U AT', - K+I-1 U(K+I-1) = INNER (N, Z, V, NONORM, IW, RW, DW ) CALL ZZAXPY ( N, U(K+I-1), Z, 1, HV, 1 ) IF(TR) THEN IF ( TRV ) THEN CALL ZZWMAT(0,' [MJDP] Z',ONE,Z,ZERO,Z,N,1,N,1,1, - 'F',9,4,1,80,TRU) IF ( K-1+I .LE. I .AND. K-1+I .GE. 2) THEN WRITE(TRU,*) ' [MJDP] CHECKING...I,K,K-1+I,' - ,'1-K=' ,I,K,K-1+I,1-K TMP = Z(1)/DELT(1,1-K) CALL ZZWMAT(0,'Z-DELT1-K',ONE,Z,-TMP, - DELT(1,1-K), N,1,N,1,1,'F',9,4,1,80,TRU) ENDIF ENDIF TMP = INNER(N, GAM(1,J), Z, NONORM,IW,RW,DW) WRITE(TRU,*) ' [MJDP] ZT*GAM[',J,']=',TMP ENDIF ENDIF 4000 CONTINUE IF(TR) WRITE(TRU,*) ' [MJDP] TOP ROW: UPDATING U AT 1', - ' WITH DELT SUB ',I-1 U(1) = INNER( N, DELT(1,I-1), V, NONORM, IW, RW, DW ) CALL ZZAXPY ( N, U(1), DELT(1,I-1), 1, HV, 1 ) ENDIF GOTO 90000 C## E N T R Y BBSMJD: ENTRY BBSMJD ( STR, STRV, STRACN) TR = STR TRV = STRV TRU = STRACN RETURN C## E X I T 90000 IF ( TR ) WRITE (TRU,*) ' ===[LEAVING MJDP].' RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF BBMJDP. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> multsg.f SUBROUTINE BBMULT ( H, V, HV, N, NUPS, CMPALL, IDENTY, INNER, - IW, RW, DW ) C## A R G U M E N T S: INTEGER N, NUPS, IW(*) LOGICAL IDENTY, CMPALL REAL H(*), V(N), HV(N) C!!!! DOUBLE PRECISION H(*), V(N), HV(N) EXTERNAL INNER DOUBLE PRECISION DW(*), INNER REAL RW(*) C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: MULT.F,V 1.13 91/12/31 14:53:05 BUCKLEY EXP $ C>RCS $LOG: MULT.F,V $ C>RCS REVISION 1.13 91/12/31 14:53:05 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.12 91/12/16 11:37:19 BUCKLEY C>RCS MINOR FIX FOR TOMS. C>RCS C>RCS REVISION 1.11 91/11/19 15:33:35 BUCKLEY C>RCS FINAL SUBMISSION FOR TOMS C>RCS C>RCS REVISION 1.10 90/07/31 10:50:01 BUCKLEY C>RCS ADDED REVISED BLAS. C>RCS C>RCS REVISION 1.9 89/06/30 13:12:49 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3 89/05/18 12:39:23 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:55:34 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:54:29 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C GIVEN THE QUASI NEWTON UPDATE MATRIX H (IN SUM FORM) AND C GIVEN THE VECTOR V, THIS ROUTINE COMPUTES C C HV = H * V . C C-----NOTE THAT A NUMBER OF PARAMETERS WHICH WILL BE THE SAME C FOR EACH CALL TO BBMULT DURING ANY PARTICULAR MINIMIZATION C PROBLEM ARE SET JUST ONCE THROUGH AN ENTRY POINT. C C------EACH UPDATE TERM OF H REQUIRES 2N+2 ENTRIES OF H. THE ORDER IS C C NU(I), ETA(I), U(I) AND S(I). C C EACH BLOCK OF 2N+2 ENTRIES IS CALLED A "TERM" OF THE UPDATE. C C H IS THE MATRIX DEFINED AT THE CURRENT POINT I AND C H^ DENOTES THE MATRIX OBTAINED BY UPDATING H. C C HERE N = THE DIMENSION OF THE PROBLEM C S = X[I] - X[I-1] = ALPHA * D C Y = G[I] - G[I-1] C U = H * Y C NU = Y' * H * Y C ETA = S' * Y C C NOTE THAT THIS ROUTINE USES S' TO DENOTE THE TRANSPOSE OF THE C COLUMN VECTOR S, SO THAT S'*Y, FOR EXAMPLE, IS A SCALAR. THE C SUBSCRIPT [I] IS DROPPED IN MOST OF THE SUBSEQUENT DESCRIPTION. C C IN FACT, ALL INNER PRODUCTS (AND 2-NORMS) ARE COMPUTED BY CALLING C THE PROCEDURE INNER, WHICH IS PASSED AS AN ARGUMENT TO BBMULT. C BY DEFAULT THEN, IF ZZINNR IS PASSED IN FOR INNER, NORMAL C EUCLIDEAN INNER PRODUCTS AND NORMS ARE OBTAINED FOR S'*Y=(S,Y) C AND OTHER INNER PRODUCTS. HOWEVER THE USER MAY REPLACE ZZINNR C WITH ANY SUITABLE ROUTINE OF HIS CHOICE. IN THIS CASE, INNER C MAY MAKE USE OF THE DATA IN THE VECTORS IW, RW AND DW. C C--NUPS = NUMBER OF TERMS IN THE UPDATE MATRIX H. C C IF NUPS = 0, H IS JUST H0 AND H * V IS JUST H0*V. C IN PARTICULAR, IF H0 = I THIS GIVES H*V = V. C C--CMPALL IS A FLAG WHICH CONTROLS THE COMPUTATION TO BE DONE. C TRUE COMPUTE H*V USING ALL THE TERMS WHICH DEFINE H. C FALSE COMPUTE BY ADDING JUST ONE LAST TERM; I.E. WE COMPUTE C (H^)*V, ASSUMING THAT H*V WAS DONE EARLIER AND IS IN HV, C AND THAT H^ IS THE UPDATE OF H DEFINED BY THE LAST TERM. C C--IDENTY IS TRUE TO INDICATE THAT H0 = I; THIS MAY BE TRUE C EVEN IF SCDIAG IS TRUE. C C-------- IN THE ENTRY POINT... C C--BETA IS THE PARAMETER DEFINING THE BROYDEN FAMILY OF UPDATES. C THE FORM USED AT EACH POINT IS C H^ = H(DFP) + BETA * NU * W'W C SO THAT BETA = 1 GIVES THE BFGS UPDATE. C C--SCDIAG IF .TRUE., H0 IS TAKEN TO BE A DIAGONAL MATRIX WHICH IS C AVAILABLE IN THE FIRST N LOCATIONS OF THE ARRAY H. C OTHERWISE H0 = I, AND IT IS OF COURSE NOT STORED. C C--SCGAMM C =GAMALL THEN THE SO-CALLED GAMMA SCALING OF OREN AND C SPEDICATO, WHICH IS DESCRIBED BY SHANNO, IS USED AT EACH C UPDATE STEP. THIS CAN IN FACT BE DONE ONLY IF THE BFGS C UPDATE IS BEING USED, I.E. IF BETA = 1. NO EXTRA STORAGE C IS NEEDED TO IMPLEMENT THIS SCALING. C C =GAMONE THEN SCALING IS DONE, AS JUST DESCRIBED FOR SCGAMM=GAMALL, C BUT IT ONLY APPLIES TO THE FIRST UPDATE TERM. C C =GAMOFF THEN NO SCALING IS DONE. C C--INCR IS THE CONSTANT 2N+2, THE LENGTH OF EACH TERM. C BASE IS THE NO. OF LOCATIONS FOR THE DIAG. H0, EITHER 0 OR N. C C--TRACES TURN ON TR TO SEE NU, ETA, GAMMA, HV AND S'V. C THESE WILL BE ON THE UNIT TRACUN. C VECTORS ARE TRACED ONLY IF TRV IS TRUE AS WELL. C C## E N T R Y P O I N T S: BBMULT THE NATURAL ENTRY POINT. C BBSMLT SET FIXED PARAMETERS. C## S U B R O U T I N E S: INNER (ARGUMENT) C## P A R A M E T E R S: REAL ZERO, ONE, TWO, THREE C!!!! DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) REAL FOUR, FIVE, SIX, SEVEN C!!!! DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) REAL EIGHT, NINE, TEN C!!!! DOUBLE PRECISION EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 9D0, TEN = 10D0 ) LOGICAL DONORM, NONORM PARAMETER ( DONORM = .TRUE., NONORM = .FALSE. ) INTEGER GAMOFF, GAMONE, GAMALL PARAMETER ( GAMOFF = 0, GAMONE = 1, GAMALL = 2 ) C## L O C A L D E C L: INTEGER COUNT, IU, K, PTNU, IS, I, II REAL NU, ETA, UV, SV, GAMMA, MU, SIGMA C!!!! DOUBLE PRECISION NU, ETA, UV, SV, GAMMA, MU, SIGMA C-----VARIABLES FOR THE ENTRY POINT. LOGICAL TR, TRV , SCDIAG LOGICAL STR , STRV, SSCDAG INTEGER SCGAMM, INCR, BASE, TRACUN INTEGER SSCGAM, SINCR, SBASE, STRACN REAL BETA, SBETA C!!!! DOUBLE PRECISION BETA, SBETA C## S A V E: SAVE TR, TRV, SCDIAG, SCGAMM, INCR, BASE, TRACUN, BETA C## C O M M O N: NONE IS DEFINED. C## D A T A: NONE ARE SET. C## E X E C U T I O N C## E X E C U T I O N IF ( TR ) WRITE (TRACUN,*) ' ***[MULT ENTERED]***' C INITIALIZE COUNTERS AND INITIALIZE FOR VARIOUS H0. IF (.NOT. CMPALL) THEN COUNT = NUPS PTNU = BASE + 1 + INCR*(NUPS-1) ELSE C SET HV = H0 * V, WHERE H0 IS THE INITIAL POSITIVE C DEFINITE MATRIX, WHICH MAY BE EITHER THE IDENTITY C OR A DIAGONAL SCALING MATRIX. IF (SCDIAG .AND. .NOT. IDENTY) THEN DO 200 K=1,N HV(K) = H(K) * V(K) 200 CONTINUE ELSE CALL ZZCOPY ( N, V, 1, HV, 1 ) ENDIF COUNT = 1 PTNU = BASE + 1 ENDIF C COMPUTE THE TERMS OF THE PRODUCT. DO 4000 I= COUNT, NUPS NU = H(PTNU) ETA = H(PTNU+1) IU = PTNU + 1 IS = IU + N IF ( TR ) WRITE (TRACUN,*) ' [MULT] NU,ETA,PTNU,NUPS->', - NU,ETA,PTNU,NUPS C COMPUTE UV = U' * V AND SV = S' * V. UV = ZERO SV = ZERO C$DOACROSS SHARE(H,V,IU,IS), REDUCTION(UV,SV), CHUNK=2000 C DO 3000 II = 1,N C UV = UV + H(IU+II)*V(II) C SV = SV + H(IS+II)*V(II) C3000 CONTINUE UV = INNER ( N, H(IU+1), V, NONORM, IW, RW, DW ) SV = INNER ( N, H(IS+1), V, NONORM, IW, RW, DW ) IF ( TR ) WRITE ( TRACUN, * ) ' [MULT] SV->', SV IF ( TR ) WRITE ( TRACUN, * ) ' [MULT] UV->', UV C COMPUTE NEXT TERM AND ADD INTO HV. USE GENERAL FORM C H(DFP) + BETA* NU*W'*W. BETA = 1 GIVES A BFGS UPDATE. C IF GAMMA-SCALING IS REQUIRED, SET GAMMA = ETA/NU, AND USE THE C MODIFIED UPDATE FORMULA WHICH CAN BE DERIVED FROM SHANNO'S C WORK. AGAIN, THIS ONLY APPLIES TO THE BFGS UPDATE. IF ( (BETA .EQ. ONE) - .AND. ( ( SCGAMM .EQ. GAMALL ) - .OR. (SCGAMM .EQ. GAMONE .AND. I .EQ. 1)) ) THEN GAMMA = ETA/NU IF ( TR ) WRITE (TRACUN, * ) ' [MULT] GAMMA->',GAMMA CALL ZZSCAL ( N, GAMMA, HV, 1 ) MU = - SV/NU SIGMA = (TWO*SV/ETA) - (UV/NU) ELSEIF ( BETA .EQ. ONE ) THEN MU = - SV/ETA SIGMA = - ( ONE + NU/ETA )*MU - UV/ETA ELSE MU = ( (BETA - ONE)*UV/NU ) - ( BETA*SV/ETA ) SIGMA = SV* (ETA + BETA*NU)/(ETA*ETA) - (BETA*UV/ETA) ENDIF IF ( TR ) WRITE (TRACUN, * ) ' [MULT] MU,SIGMA->',MU,SIGMA C$DOACROSS SHARE(MU,SIGMA, IU,IS,HV,H), CHUNK=2000 C DO II = 1,N C HV(II) = HV(II) + MU*H(IU+II) + SIGMA*H(IS+II) C ENDDO CALL ZZAXPY ( N, MU, H(IU+1), 1, HV, 1 ) CALL ZZAXPY ( N, SIGMA, H(IS+1), 1, HV, 1 ) IF ( TRV .AND. TR ) WRITE (TRACUN, * ) ' [MULT] H*V->',HV PTNU = PTNU + INCR 4000 CONTINUE GOTO 90000 C## E N T R Y BBSMLT: ENTRY BBSMLT ( STR, STRV, SSCDAG, SSCGAM, - STRACN, SBASE, SINCR, SBETA ) TR = STR TRV = STRV SCDIAG = SSCDAG SCGAMM = SSCGAM TRACUN = STRACN BASE = SBASE INCR = SINCR BETA = SBETA RETURN C## E X I T 90000 IF ( TR ) WRITE (TRACUN,*) ' ===[LEAVING MULT].' RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF BBMULT. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> nocesg.f SUBROUTINE BBNOCE ( H, V, HV, N, ITER, M, IDENTY, ARO, - INNER, IW, RW, DW ) C## A R G U M E N T S: INTEGER N, ITER, M, IW(*) LOGICAL IDENTY REAL H(*), V(N), HV(N), ARO(N) C!!!! DOUBLE PRECISION H(*), V(N), HV(N), ARO(N) EXTERNAL INNER DOUBLE PRECISION DW(*), INNER REAL RW(*) C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: NOCE.F,V 1.12 91/12/31 14:53:06 BUCKLEY EXP $ C>RCS $LOG: NOCE.F,V $ C>RCS REVISION 1.12 91/12/31 14:53:06 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.11 91/11/22 11:32:22 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.10 90/07/31 10:50:07 BUCKLEY C>RCS ADDED REVISED BLAS. C>RCS C>RCS REVISION 1.9 89/06/30 13:27:37 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 17:15:35 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 12:39:25 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:55:35 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:54:29 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C GIVEN THE QUASI NEWTON UPDATE MATRIX H (IN PRODUCT FORM) AND C GIVEN THE VECTOR V, THIS ROUTINE COMPUTES C C HV = H * V . C C IT IS BASED ON THE SUM FORM VERSION OF THIS ROUTINE, BBMULT. C C-----NOTE THAT A NUMBER OF PARAMETERS WHICH WILL BE THE SAME C FOR EACH CALL TO BBNOCE DURING ANY PARTICULAR MINIMIZATION C PROBLEM ARE SET JUST ONCE THROUGH AN ENTRY POINT. C C------EACH UPDATE TERM OF H REQUIRES 2N+1 ENTRIES OF H. THE ORDER IS C C ETA(I), S(I) AND Y(I). C C EACH BLOCK OF 2N+1 ENTRIES IS CALLED A "TERM" OF THE UPDATE. C C HERE N = THE DIMENSION OF THE PROBLEM C S = X[I] - X[I-1] = ALPHA * D C Y = G[I] - G[I-1] C ETA = S' * Y C THESE UPDATES ARE STORED IN CIRCULAR, I.E. WRAPAROUND, FASHION C IN THE AVAILABLE STORAGE. C C SEE BBMULT REGARDING THE USE OF INNER AND FOR OTHER COMMENTS. C SOME SUPPLEMENTARY COMMENTS TO THOSE IN BBMULT FOLLOW. C C--ITER ITERATION NUMBER OF CURRENT POINT X[ITER] C--M NUMBER OF UPDATES WHICH CAN BE STORED C--ARO A SCRATCH VECTOR C C--BETA IS THE PARAMETER DEFINING THE BROYDEN FAMILY C OF UPDATES. BETA MUST BE 1 FOR PRODUCT UPDATES. C C--SCGAMM THE VALUE GAMALL IS NOT ALLOWED WITH PRODUCT FORM UPDATES, C ALTHOUGH THE VALUE GAMONE IS PERMITTED. C C--CMPALL IS NOT IMPLEMENTED. C C--INCR IS THE CONSTANT 2N+1, THE LENGTH OF EACH TERM. C C--TRACES TURN ON TR TO SEE HV. THIS WILL BE ON THE UNIT TRACUN. C NOTE THAT TRV SEPARATELY CONTROLS TRACING OF VECTORS. C VECTORS ARE TRACED ONLY IF TRV IS TRUE AS WELL. C C## E N T R Y P O I N T S: BBNOCE THE NATURAL ENTRY POINT. C BBSNOC SET FIXED PARAMETERS. C## S U B R O U T I N E S: MOD, MIN INTRINSICS C## P A R A M E T E R S: LOGICAL DONORM, NONORM PARAMETER ( DONORM = .TRUE., NONORM = .FALSE. ) INTEGER GAMOFF, GAMONE, GAMALL PARAMETER ( GAMOFF = 0, GAMONE = 1, GAMALL = 2 ) C## L O C A L D E C L: INTEGER COUNT, K, IS, I, IY, IETA, LAST REAL SV, BETAK, NU C!!!! DOUBLE PRECISION SV, BETAK, NU C-----VARIABLES FOR THE ENTRY POINT. LOGICAL TR, TRV, SCDIAG LOGICAL STR, STRV, SSCDAG INTEGER SCGAMM, INCR, BASE, TRACUN INTEGER SSCGAM, SINCR, SBASE, STRACN C## S A V E: SAVE TR, TRV, SCDIAG, SCGAMM, INCR, BASE, TRACUN C## C O M M O N: NONE IS DEFINED. C## D A T A: NO VALUES ARE SET. C## E X E C U T I O N C## E X E C U T I O N IF ( TR ) WRITE (TRACUN,*) ' ***[NOCE ENTERED]***' C INITIALIZE COUNTERS. COUNT = MIN (ITER,M) IF ( ITER .GT. 0 ) THEN C DO THE FIRST ITERATION OF THE FIRST HALF OF NOCEDAL'S RECURSION. LAST = MOD(ITER-1,M) IETA = BASE + LAST*INCR +1 IS = IETA + 1 IY = IS + N - 1 LAST = LAST + 1 SV = INNER ( N, H(IS), V, NONORM, IW, RW, DW ) ARO(LAST) = SV / H(IETA) CALL ZZCOPY ( N, V, 1, HV, 1 ) CALL ZZAXPY ( N, -ARO(LAST), H(IY+1), 1, HV, 1 ) C DO THE REMAINING ITERATIONS OF THE FIRST HALF. DO 200 I = 1,COUNT-1 IETA = IETA - INCR IF ( IETA .LE. BASE ) IETA = IETA + M*INCR IS = IETA + 1 IY = IS + N - 1 LAST = LAST - 1 IF ( LAST .EQ. 0 ) LAST = M SV = INNER ( N, H(IS), HV, NONORM, IW, RW, DW ) ARO(LAST) = SV/H(IETA) CALL ZZAXPY ( N, -ARO(LAST), H(IY+1), 1, HV, 1 ) 200 CONTINUE ENDIF C SET HV = H0 * HV, WHERE H0 IS THE INITIAL POSITIVE C DEFINITE MATRIX, WHICH MAY BE EITHER THE IDENTITY C OR A DIAGONAL SCALING MATRIX. IF ( ITER .GT. 0 ) THEN IF (SCDIAG .AND. .NOT. IDENTY) THEN DO 220 K=1,N HV(K) = H(K) * HV(K) 220 CONTINUE ENDIF IF ( SCGAMM .EQ. GAMONE ) THEN NU = INNER ( N, H(IY+1), H(IY+1), NONORM, IW, RW, DW ) CALL ZZSCAL ( N, H(IETA)/NU, HV, 1 ) ENDIF ELSE IF ( SCDIAG .AND. .NOT. IDENTY ) THEN DO 230 K=1,N HV(K) = H(K) * V(K) 230 CONTINUE ELSE CALL ZZCOPY ( N, V, 1, HV, 1 ) ENDIF C COMPUTE THE TERMS OF THE SECOND HALF OF THE PRODUCT. IS = IS - 1 IY = IY + 1 DO 4000 I= 1, COUNT BETAK = INNER ( N, H(IY), HV, NONORM, IW, RW, DW ) CALL ZZAXPY( N, (ARO(LAST) - BETAK/H(IETA)), H(IS+1), 1, HV, 1) LAST = MOD(LAST,M) + 1 IETA = IETA + INCR IF ( IETA .GT. BASE+M*INCR ) IETA = BASE + 1 IS = IETA IY = IS + N + 1 4000 CONTINUE IF ( TRV .AND. TR ) WRITE (TRACUN, * ) ' [NOCE] H*V->',HV GOTO 90000 C## E N T R Y BBSNOC: ENTRY BBSNOC ( STR, STRV, SSCDAG, - SSCGAM, STRACN, SBASE, SINCR ) TR = STR TRV = STRV SCDIAG = SSCDAG SCGAMM = SSCGAM TRACUN = STRACN BASE = SBASE INCR = SINCR RETURN C## E X I T 90000 IF ( TR ) WRITE (TRACUN,*) ' ===[LEAVING NOCE].' RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF BBNOCE. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> powlsg.f SUBROUTINE BBPOWL ( H, V, HV, N, NUPS, I, M, IDENTY, SCDIAG, - INNER, IW, RW, DW ) C## A R G U M E N T S: INTEGER N, NUPS, I, M, IW(*) LOGICAL IDENTY, SCDIAG REAL H(*), V(N), HV(N) C!!!! DOUBLE PRECISION H(*), V(N), HV(N) EXTERNAL INNER DOUBLE PRECISION DW(*), INNER REAL RW(*) C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C>RCS $HEADER: POWL.F,V 1.12 91/12/31 14:53:07 BUCKLEY EXP $ C>RCS $LOG: POWL.F,V $ C>RCS REVISION 1.12 91/12/31 14:53:07 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.11 91/11/22 11:33:11 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.10 90/07/31 10:50:11 BUCKLEY C>RCS ADDED REVISED BLAS. C>RCS C>RCS REVISION 1.9 89/06/30 13:12:51 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3 89/05/18 12:39:26 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:55:37 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:54:30 BUCKLEY C>RCS INITIAL REVISION C>RCS C## D E S C R I P T I O N: C GIVEN THE QUASI NEWTON UPDATE MATRIX H (IN ZZ' FORM) AND C GIVEN THE VECTOR V, THIS ROUTINE COMPUTES C C HV = H * V . C C IT ALSO RETURNS THE INTERMEDIATE VALUE U = Z' * V. IT IS C STORED AS PART OF H, SPECIFICALLY, WHERE IT WILL EVENTUALLY C BECOME THE ROTATION VECTOR Y. C C IT ASSUMES HERE THAT Z REPRESENTS THE MATRIX Z[I] AT THE C POINT X[I]. C C-----THE ACTUAL WORK OF DOING THE UPDATE IS DONE IN BBMJDP. THIS C ROUTINE SERVES TO SHORTEN THE CALL TO BBMJDP. IN PARTICULAR, C THE MATRIX H IS BROKEN UP INTO THE CONSTITUENT PARTS REQUIRED C FOR THE COMPUTATION, NAMELY DIAGONAL, U, W, Z, PHI, V, C DELTA, GAMMA AND Y. IT MAKES FOR MUCH MORE CONVENIENT C NAMES IN BBMJDP. C C NUPS IS THE CURRENT NUMBER OF UPDATES C M IS THE MAXIMAL NUMBER OF UPDATES C C------EACH UPDATE TERM OF H REQUIRES 3N ENTRIES OF H, NAMELY C C Y(I), DELT(I) AND GAM(I). C C EACH SET OF 3N ENTRIES DEFINES A "TERM" OF THE UPDATE. C C HERE N = THE DIMENSION OF THE PROBLEM C STEP = X[I] - X[I-1] = ALPHA * D C DGRAD= G[I] - G[I-1] C R = SQRT (STEP' * DGRAD) C C AND THIS DEFINES THE VALUES C C DELT = STEP / R C GAM = DGRAD/ R C C THE VECTOR Y DEFINES THE ORTHOGONAL ROTATIONS. C C CALCULATION OF HV ALSO REQUIRES USE OF SEVERAL TEMPORARY C AREAS, NAMELY C VV AN M BY N MATRIX C W AN N VECTOR C Z AN N VECTOR C PHI AN M VECTOR C C SEE BBMULT REGARDING THE USE OF INNER AND FOR OTHER COMMENTS. C SUPPLEMENTARY COMMENTS FOLLOW. C C--BETA IS THE PARAMETER DEFINING THE BROYDEN FAMILY C OF UPDATES. ONLY BETA = 1 (FROM BBMULT) IS IMPLEMENTED. C C--SCGAMM THIS IS NOT IMPLEMENTED. CF. BBMULT C C--IDENTY SEE BBMSUM. C SCDIAG C C## E N T R Y P O I N T S: THE NATURAL ENTRY BBPOWL. C## S U B R O U T I N E S: BBMJDP IMPLEMENTS THE UPDATES. C## P A R A M E T E R S: NONE ARE DEFINED. C## L O C A L D E C L: INTEGER DIAG, U, W, Z, PHI, VV INTEGER DELT, GAM, Y LOGICAL FIRST C## S A V E: SAVE W, U, DIAG, Z, PHI, VV, DELT, GAM, Y, FIRST C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA FIRST/.TRUE./ C## E X E C U T I O N C## E X E C U T I O N IF ( FIRST ) THEN FIRST = .FALSE. DIAG = 1 IF ( SCDIAG ) THEN Y = DIAG + N ELSE Y = DIAG ENDIF DELT = Y + M*N GAM = DELT + M*N VV = GAM + M*N PHI = VV + M*N W = PHI + M Z = W + N ENDIF U = Y + N*NUPS WRITE (6,*) ' INDICES' WRITE (6,*) ' DIAG,Y,U,DELT,GAM,VV,PHI,W,Z', - DIAG,Y,U,DELT,GAM,VV,PHI,W,Z CALL BBMJDP ( H(DIAG), H(U), H(W), H(Z), H(PHI), H(VV), - H(DELT), H(GAM), H(Y), - V, HV, N, NUPS, I, M, SCDIAG, IDENTY, INNER, IW, RW, DW ) GOTO 90000 C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF BBPOWL. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> updtsg.f SUBROUTINE BBUPDT ( N, G, S, XX, Y, H, ETA, CT, CNTRST, LASTPT, - IDENTY, NUPS, STEEPD, RSTEP, QNPART, ALPHA, - STG, UTG, NU, UPDATT, INNER, IW, RW, DW ) C## A R G U M E N T S: INTEGER N, CT, CNTRST, LASTPT, NUPS, UPDATT, IW(*) LOGICAL STEEPD, RSTEP, QNPART, IDENTY REAL G(N), S(N), XX(N), Y(N), H(*) C!!!! DOUBLE PRECISION G(N), S(N), XX(N), Y(N), H(*) REAL ALPHA, ETA, STG, UTG, NU C!!!! DOUBLE PRECISION ALPHA, ETA, STG, UTG, NU EXTERNAL INNER DOUBLE PRECISION DW(*), INNER REAL RW(*) C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C>RCS $HEADER: UPDT.F,V 2.3 91/12/31 14:53:08 BUCKLEY EXP $ C>RCS $LOG: UPDT.F,V $ C>RCS REVISION 2.3 91/12/31 14:53:08 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 2.2 91/11/22 11:33:52 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 2.1 90/08/02 13:38:57 BUCKLEY C>RCS REMOVED DOUBLE DECLARATIONS; MINOR FIX C>RCS C>RCS REVISION 2.0 90/07/31 12:04:18 BUCKLEY C>RCS FIXED LONG LINES. C>RCS C>RCS REVISION 1.10 90/07/31 10:50:16 BUCKLEY C>RCS ADDED REVISED BLAS. C>RCS C>RCS REVISION 1.9 89/06/30 13:12:52 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3 89/05/18 12:39:27 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:55:39 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:54:30 BUCKLEY C>RCS INITIAL REVISION C>RCS C## D E S C R I P T I O N: C C THE BASIC PURPOSE OF THIS ROUTINE IS TO COMPUTE THE VALUE OF C THE UPDATE MATRIX H FOR THE NEW POINT. C C NOTE THAT THERE ARE SEVERAL VARIABLES DEFINED IN THE MAIN C ROUTINE BBLNIR WHICH AFFECT THIS ROUTINE. HOWEVER, SINCE C THEY ARE INVARIANT BETWEEN CALLS TO BBUPDT, THEY ARE SET ONCE C WITH A CALL TO THE ENTRY POINT BBSUPT AND THEY ARE RETAINED FROM C CALL TO CALL WITH A NUMBER OF SAVE VARIABLES. C C ON ENTRY THE FOLLOWING VALUES ARE REQUIRED. C C N THE DIMENSION OF THE PROBLEM. C G THE GRADIENT AT THE NEW POINT X. C S THE STEP TAKEN ON THE ITERATION JUST COMPLETED. C XX MAY BE USED AS A SCRATCH VECTOR; ALSO SEE BELOW. C Y THE CHANGE IN GRADIENT FROM THE PREVIOUS POINT. C THIS MAY ALSO BE USED AS A SCRATCH VECTOR. C ETA = S'Y OVER LAST STEP C H THE CURRENT MATRIX H. C C INNER SEE THE DISCUSSION IN BBMULT. C C IN ADDITION, IF CG IS TRUE (SEE THE ENTRY POINT BBSUPT), C THE FOLLOWING VALUES MUST BE DEFINED. C C CT THE ITERATION NUMBER C CNTRST THE NUMBER OF RESTARTS DONE. C NUPS THE NUMBER OF TERMS DEFINING THE CURRENT UPDATE MATRIX. C ALPHA STEP LENGTH; NEEDED BY POWELL C STEEPD A FLAG WHICH IS TRUE WHEN THE LAST SEARCH DIRECTION C WAS ALONG THE DIRECTION OF STEEPEST DESCENT. C RSTEP A FLAG WHICH IS TRUE WHEN THIS IS A RESTART POINT. C THIS FLAG WILL ALWAYS BE FALSE WHEN CG IS FALSE. C IDENTY TRUE IF H[0] = I. C UPDATT TO INDICATE WHAT TYPE OF QN UPDATES ARE BEING STORED, C I.E. SUM FORM (BBLNIR) OR PRODUCT FORM (NOCEDAL) C OR FACTORED FORM (POWELL). C QNPART A FLAG WHICH IS TRUE WHEN WE ARE IN THE QUASI-NEWTON C PART OF THE CODE. C C ON EXIT FROM BBUPDT, THE MATRIX H MUST HAVE BEEN UPDATED. C C IN THE QUASI-NEWTON CASE, THAT UPDATE WILL HAVE BEEN DONE IN C PLACE, I.E. THE NEW MATRIX H WILL JUST HAVE OVERWRITTEN THE OLD. C C IN THE CONJUGATE GRADIENT CASE (I.E. WHEN CG IS TRUE), ANOTHER C TERM WILL HAVE BEEN ADDED TO THE SUM FORM OF H (UNLESS ALL C THE SPACE FOR UPDATES HAS BEEN USED), OR ELSE, IN THE EVENT C OF A RESTART, H WILL HAVE REDEFINED BY A SINGLE UPDATE TERM. C THUS, THE FOLLOWING VALUES MUST BE SET BEFORE RETURNING: C C CNTRST MUST HAVE BEEN INCREMENTED BY 1 IF A RESTART WAS DONE. C IDENTY WILL BE SET TO TRUE WHENEVER H0 IS THE IDENTITY, EVEN C IF SCDIAG IS TRUE. C NUPS MUST HAVE BEEN REVISED TO THE NUMBER OF SUM TERMS C DEFINED BY THE NEW H, WHETHER 1 OR AN INCREMENT OF THE C PREVIOUS VALUE. C CT MUST BE RESET IF THE UPDATE WAS A RESTART. THIS IS THE C ACTUAL ITERATION COUNTER, WHICH STARTS FROM 1 AT A C RESTART POINT AND IS INCREMENTED FOR EACH NEW POINT. C LASTPT MUST BE SET, IF A RESTART, TO INDICATE THE NEXT POINT C AT WHICH A RESTART MUST BE FORCED, REGARDLESS OF THE C TESTING MECHANISM. C XX, STG, UTG, NU C C IN THE CASE THAT PRODUCT FORM UPDATES ARE BEING STORED, THESE C VALUES MUST ALSO BE UPDATED, BUT THERE ARE SOME NOTABLE DIFF- C ERENCES. THERE ARE NO RESTARTS, AND WHEN THE MEMORY LIMIT IS C REACHED, EARLIER UPDATE TERMS ARE SIMPLY OVERWRITTEN IN A CIRCU- C LAR FASHION. C C THE TRACE VARIABLES TR7, TR8 AND TRV ARE EXPLAINED WITHIN THE C DESCRIPTION OF BBLNIR. C C## E N T R Y P O I N T S: BBUPDT THE NATURAL ENTRY POINT. C BBSUPD INITIALIZE FIXED ARGUMENTS. C## S U B R O U T I N E S: BBMULT TO MULTIPLY BY A SUM FORM H. C MOD, SQRT INTRINSICS. C INNER AN EXTERNAL ARGUMENT. C## P A R A M E T E R S: INTEGER SUMFRM, PRDFRM, MJDFRM PARAMETER ( SUMFRM = 1, PRDFRM = 2, MJDFRM = 3 ) REAL ZERO, ONE, TWO, THREE C!!!! DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) REAL FOUR, FIVE, SIX, SEVEN C!!!! DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) REAL EIGHT, NINE, TEN C!!!! DOUBLE PRECISION EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 9D0, TEN = 10D0 ) LOGICAL DONORM, NONORM PARAMETER ( DONORM = .TRUE., NONORM = .FALSE. ) LOGICAL T, F PARAMETER ( T = .TRUE., F = .FALSE. ) CHARACTER*(*) TRUE, QT, FALSE, QF PARAMETER ( TRUE = 'TRUE', QT = 'T', FALSE = 'FALSE', QF = 'F' ) INTEGER ITRUE, IFALSE PARAMETER ( ITRUE = 1, IFALSE = 0 ) REAL RTRUE, RFALSE C!!!! DOUBLE PRECISION RTRUE, RFALSE PARAMETER ( RTRUE = 1.D0, RFALSE = 0.D0 ) INTEGER GAMOFF, GAMONE, GAMALL PARAMETER ( GAMOFF = 0, GAMONE = 1, GAMALL = 2 ) C## L O C A L D E C L: C-----CONTROL PARAMETERS FOR ENTRY BBSUPD. INTEGER M, BASE, INCR, SCGAMM, TRU INTEGER SM, SBASE, SINCR, SSGAMM, STRU LOGICAL CG, SCDIAG, USESHN, FROMRS, TR7, TR10, TRV LOGICAL SCG, SDIAG, SUSEHN, SFRMRS, STR7, STR10, STRV C-----GENERAL DECLARATIONS. INTEGER IETA, INU, IS, IU, J, K, KJ, IY, ID, IG REAL TP1, TP2, R C!!!! DOUBLE PRECISION TP1, TP2, R C## S A V E: SAVE M, BASE, INCR, INU, SCGAMM, TRU, CG, - SCDIAG, USESHN, FROMRS, TR7, TR10, TRV C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NO DATA VALUES SET. C## E X E C U T I O N C## E X E C U T I O N C C IN THIS DESCRIPTION, "H" WILL DENOTE THE UPDATE MATRIX DEFINED C WHEN THE CURRENT POINT IS REACHED; "H^" WILL DENOTE THE UPDATE C MATRIX TO BE COMPUTED AND USED IN FORMING THE NEXT SEARCH C DIRECTION. IF ( TR7 ) WRITE(TRU,*) ' ***[ENTERING UPDT]***' IF ( CG ) THEN IF ( RSTEP ) THEN C P H A S E X - A : R E S T A R T.<<<<<<<<<<<<<<<<<<< IF (TR7 .OR. TR10) WRITE(TRU,*) ' [UPDT] RESTART! NUPS->1' C COUNT NUMBER OF RESTARTS CNTRST = CNTRST + 1 C SET POINT TO FORCE THE NEXT RESTART. IF ( FROMRS .AND. .NOT. USESHN ) THEN LASTPT = 1 + N ELSE LASTPT = M + 1 + N ENDIF C AFTER A RESTART, THE DIAGONAL SCALING MATRIX IS ALWAYS JUST I. IDENTY = T C IF M = 0, WE CAN NOT SAVE UPDATES SO REVERT TO A STEEPEST DESCENT C RESTART. IF ( M .EQ. 0 ) THEN CT = 0 NUPS = 0 ELSE CT = 1 NUPS = 1 QNPART = T ENDIF C SINCE A RESTART IS INDICATED, SAVE THE CURRENT S AND U = H*Y C = I*Y = Y (THE BEALE RESTART VECTORS) AND SAVE NU = Y'*H*Y C = Y'Y AND ETA = S'Y IN H(INU) AND H(IETA), I.E. DEFINE H[1]. IF ( M .NE. 0 ) THEN INU = BASE + 1 IETA = INU + 1 IU = IETA IS = IU + N CALL ZZCOPY ( N, Y, 1, H(IU+1), 1 ) CALL ZZCOPY ( N, S, 1, H(IS+1), 1 ) H(INU) = INNER ( N, H(IU+1), H(IU+1), NONORM,IW,RW,DW) H(IETA) = ETA IF(TR7) - WRITE(TRU,*) ' [UPDT] SAVED NU, ETA->',H(INU),H(IETA) ENDIF ELSE IF ( CG .AND. UPDATT .EQ. SUMFRM ) THEN C P H A S E X - B: CG, SUM FORM UPDATE. <<<<<<<<< C COMPUTE U = H*Y (INTO XX). C ALSO COMPUTE S'G (IN STG) AND U'G (IN UTG), AS WELL C AS ACCUMULATING NU = Y'*H*Y AND ETA = S'Y. NOTE THAT THE C COMPUTATION IS THE SAME FOR THE CG OR QN PARTS. IF ( TR7 ) WRITE(TRU,*) ' ***DOING SUM FORM UPDATE' CALL BBMULT ( H, Y, XX, N, NUPS, T, IDENTY, INNER,IW,RW,DW) NU = INNER( N, Y, XX, NONORM, IW, RW, DW ) STG = INNER( N, S, G, NONORM, IW, RW, DW ) UTG = INNER( N, XX, G, NONORM, IW, RW, DW ) IF ( QNPART ) THEN C SAVE UPDATE TERMS: PUT NU,ETA,U AND S IN THE ARRAY H. NUPS = NUPS + 1 INU = INU + INCR IETA = INU + 1 IU = IETA IS = IU + N CALL ZZCOPY ( N, XX, 1, H(IU+1), 1 ) CALL ZZCOPY ( N, S, 1, H(IS+1), 1 ) H(INU) = NU H(IETA) = ETA IF ( TR7 .OR. TR10 ) WRITE(TRU,*) ' [UPDT] NO RESTART;' - //' NUPS->',NUPS IF ( TR7 ) WRITE(TRU,*) ' [UPDT] SAVED NU, ETA->',NU,ETA ELSE IF ( TR7 .OR. TR10 ) WRITE(TRU,*) ' [UPDT] NO RESTART;' - //' NUPS->',NUPS+1,'(NOT STORED)' ENDIF C ...FOR THE "IF QNPART SO SAVE...". ELSE IF ( CG .AND. UPDATT .EQ. PRDFRM ) THEN C P H A S E X - C: CG, PRODUCT FORM UPDATE. <<<<<<<<< IF ( TR7 ) WRITE(TRU,*) ' ***DOING PRODUCT FORM UPDATE' NUPS = MOD(NUPS,M) IETA = BASE + NUPS*INCR + 1 IS = IETA IY = IS + N NUPS = NUPS + 1 CALL ZZCOPY ( N, S, 1, H(IS+1), 1 ) CALL ZZCOPY ( N, Y, 1, H(IY+1), 1 ) H(IETA) = ETA IF ( TR7 .OR. TR10 ) WRITE(TRU,*) ' [UPDT] SAVED NOCEDAL' - //' UPDATE TERM.' ELSEIF ( CG .AND. UPDATT .EQ. MJDFRM ) THEN C P H A S E X - D: CG, FACTORED FORM UPDATE. <<<<<<<< IF ( TR7 ) WRITE(TRU,*) ' ***DOING FACTORED FORM UPDATE' IY = BASE + NUPS*N NUPS = NUPS + 1 ID = IY + N*M IG = ID + N*M R = SQRT ( ETA ) CALL ZZSCAL ( N, -ALPHA, H(IY+1), 1 ) CALL ZZCOPY ( N, S, 1, H(ID+1), 1 ) CALL ZZSCAL ( N, (ONE/R), H(ID+1), 1 ) CALL ZZCOPY ( N, Y, 1, H(IG+1), 1 ) CALL ZZSCAL ( N, (ONE/R), H(IG+1), 1 ) IF ( TR7 .OR. TR10 ) WRITE(TRU,*) ' [UPDT] SAVED POWELL' - //' UPDATE TERM.' ENDIF ELSE C P H A S E X - E: Q N C A S E.<<<<<<<<<<<<<<<<<< C A VARIABLE METRIC ALGORITHM IS BEING USED. CALCULATE GRADIENT C DIFFERENCE Y AND ETA = S'Y. S IS THE STEP . C IF STEEPD IS .TRUE., SET UP THE INITIAL SCALED APPROXIMATE C HESSIAN. THIS IS THE INITIAL STEP. IF ( STEEPD ) THEN C CALCULATE NU = Y'*H*Y, WHICH HERE IS NU = Y'*Y. NU = INNER ( N, Y, Y, NONORM, IW, RW, DW ) C STORE THE INITIAL HESSIAN, WHICH IS H = (S'Y/Y'Y)*I = C (ETA/NU)*I. THEN WE NEED TO RECALCULATE THE INITIAL NU = C Y'*H*Y = (ETA/NU)*(NU ABOVE) = ETA, AND TO FIND XX = H*Y. KJ = 1 TP1 = ETA/NU DO 6000 K=1,N C NOTE: INNER LOOP IS FROM K TO N SO ONLY HALF OF H. H(KJ) = TP1 KJ = KJ + 1 DO 5900 J = K+1,N H(KJ) = ZERO KJ = KJ + 1 5900 CONTINUE XX(K) = TP1*Y(K) 6000 CONTINUE NU = ETA ELSE C CALCULATE XX = H*Y AND NU = Y'*H*Y. REMEMBER THAT ONLY C THE SYMMETRIC UPPER HALF OF H IS STORED (IN ROW ORDER). NU = ZERO DO 6500 K = 1,N TP1 = ZERO KJ = K DO 6200 J=1,K-1 TP1 = TP1 + H(KJ)*Y(J) KJ = KJ + (N-J) 6200 CONTINUE DO 6400 J=K,N TP1 = TP1 + H(KJ)*Y(J) KJ = KJ+1 6400 CONTINUE NU = NU + TP1*Y(K) XX(K) = TP1 6500 CONTINUE ENDIF C ...FOR " IF STEEPD". C NOW CALCULATE THE UPDATED APPROXIMATE HESSIAN H^. C USE THE BFGS UPDATE. NU, ETA AND H*Y (IN XX) ARE KNOWN. TP1 = ONE + NU/ETA CALL ZZCOPY ( N, XX, 1, Y, 1 ) CALL ZZSCAL ( N, -ONE, Y, 1 ) CALL ZZAXPY ( N, TP1, S, 1, Y, 1 ) KJ = 1 DO 7400 K=1,N TP2 = S(K)/ETA TP1 = XX(K)/ETA DO 7200 J=K,N H(KJ) = H(KJ) + TP2*Y(J) - TP1*S(J) KJ = KJ+1 7200 CONTINUE 7400 CONTINUE E N D I F C ...FOR THE UPDATE CHOICES. GOTO 90000 C## E N T R Y BBSUPD: ENTRY BBSUPD ( SM, SBASE, SINCR, SSGAMM, - SCG, SDIAG, SUSEHN, SFRMRS, STR7, STR10, STRV, STRU ) M = SM BASE = SBASE INCR = SINCR SCGAMM = SSGAMM CG = SCG SCDIAG = SDIAG USESHN = SUSEHN FROMRS = SFRMRS TR7 = STR7 TR10 = STR10 TRV = STRV TRU = STRU RETURN C## E X I T 90000 IF ( TR7 ) WRITE(TRU,*) ' ===[LEAVING UPDT].' RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF BBUPDT. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> valssg.f SUBROUTINE BBVALS ( INTS, LOGS, REALS ) C## A R G U M E N T S: INTEGER INTS(*) LOGICAL LOGS(*) REAL REALS(*) C!!!! DOUBLE PRECISION REALS(*) C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: VALS.F,V 1.12 91/12/31 14:53:10 BUCKLEY EXP $ C>RCS $LOG: VALS.F,V $ C>RCS REVISION 1.12 91/12/31 14:53:10 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.11 91/11/19 15:29:16 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.10 90/07/31 10:50:20 BUCKLEY C>RCS ADDED REVISED BLAS. C>RCS C>RCS REVISION 1.9 89/06/30 13:12:53 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3 89/05/18 12:39:28 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:55:41 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:54:31 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE CONTAINS THE DEFAULT VALUES FOR INITIALIZING C THE ROUTINES ZZPRNT, ZZEVAL, ZZTERM AND BBLNIR. IT RETURNS C THESE VALUES IN THE THREE ARRAYS IN THE CALLING SEQUENCE WHEN C CALLED. THE SPECIFIC ENTRIES ASSIGNED MAY BE SEEN BY LOOKING C AT THE TABLE BELOW. C C REFERENCES ARE TO THE PUBLISHED ALGORITHM TOMS ALGORITHM 630, C OR, IF INDICATED BY (REM), TO THE LATER PUBLISHED REMARK ON C ALGORITHM 630. C C------------ C ARRAY INTS| C------------ C INDEX INDEX NAME DEFAULT USE C CODE C ------ --- ---- --- --- C XDRVMD 1 DERVMD CANAL CONTROL OF DERIVATIVE MODE; SEE SECTION 3.13 C XNORM 2 NORM NL2 CONTROL OF NORM; SEE SECTION 3.14 (REM) C XSCALE 3 SCALE 0 SCALING TO APPLY TO F; SEE SECTION 3.13 (REM) C XLTRCU 4 LTRACU 6 UNIT FOR BBLNIR TRACE OUTPUT; SEE LOGS(1-15) C XETRCU 5 TRACEU 6 UNIT FOR OUTPUT OF F AND G; SEE LOGS(11,12) C XPTRCU 6 UNIT 6 UNIT FOR ZZPRNT OUTPUT ; SEE SECTION 3.12 (REM) C XTTRCU 7 TTRACU 6 UNIT FOR OUTPUT OF ZZTERM TRACE; SEE LOGS(27) C XMETH 8 METH 0 SEE BBLSET IN LISTING OF BBLNIR C XQUADN 9 QUADIN 2 NOW 4. SEE BBLSET IN LISTING OF BBLNIR C XALPS1 10 ALPIS1 1 NOW 4. SEE BBLSET IN LISTING OF BBLNIR C XSCGMM 11 SCGAMM GAMONE SEE BBLSET IN LISTING OF BBLNIR C XHTEST 12 HTEST 1 SEE BBLSET IN LISTING OF BBLNIR C XUPDTT 13 UPDATT SUMFRM NOCEDAL UPDATES FLAG; SEE SECTION 2.7 (REM) C XSTSTP 14 STSTEP 2 SEE BBLSET IN LISTING OF BBLNIR C C------------ C ARRAY LOGS| C------------ C INDEX INDEX NAME DEFAULT USE C CODE C ------ --- ---- --- --- C XTRACE 1--15 TRACES F THE 15 TRACE FLAGS; SEE LISTING OF BBLSET C XTRF 16 TRF F TRACE THE EVALUATION OF F IN ZZEVAL C XTRG 17 TRG F TRACE THE EVALUATION OF G IN ZZEVAL C XTTRCE 18 TTRACE F TRACE THE TERMINATION TESTS; SECTION 3.13 (REM) C XTRTST 19 TRTEST F TRACE DERIVATIVE TESTS; SEE SECTION 3.13 (REM) C XGRAD 20 GRAD T INCLUDE THE GRADIENT IN OUTPUT FROM ZZPRNT C XPOINT 21 POINT T INCLUDE THE POINT X IN OUTPUT FROM ZZPRNT C XTGRAD 22 TGRAD F INCLUDE THE GRADIENT TEST FOR TERMINATION C XTSTEP 23 TSTEP T INCLUDE THE STEP TEST FOR TERMINATION C XTSHXG 24 TSHXG T INCLUDE SHANNO'S TEST FOR TERMINATION C XTFUNC 25 TFUNC F INCLUDE THE FUNCTION TEST FOR TERMINATION C XRELF 26 RELF T MAKE FUNCTION TESTS RELATIVE TO F(X(0)) C XRELG 27 RELG T MAKE GRADIENT TESTS RELATIVE TO G(X(0)) C XFQUAD 28 FQUAD F SEE BBLSET IN LISTING OF BBLNIR C XDIAGL 29 DIAGNL F SEE BBLSET IN LISTING OF BBLNIR C XSHNNO 30 SHANNO F SEE BBLSET IN LISTING OF BBLNIR C XFRMRS 31 FROMRS F SEE BBLSET IN LISTING OF BBLNIR C XFRCEF 32 FORCEF T SEE BBLSET IN LISTING OF BBLNIR C C------------- C ARRAY REALS| C------------- C INDEX INDEX NAME DEFAULT USE C CODE C ------ --- ---- --- --- C XRO 1 RO 0.2 SEE BBLSET IN LISTING OF BBLNIR C XBETA 2 BETA 1.0 SEE BBLSET IN LISTING OF BBLNIR C C## E N T R Y P O I N T S: BBVALS NATURAL ENTRY POINT. C BBDVAL SET ANALYTIC DERIVATIVE CODE. C BBRVAL RESET BY READING NEW DATA IN. C BBSVAL RESET THE VALUES. C C## S U B R O U T I N E S: NONE ARE CALLED. C## P A R A M E T E R S: CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) CHARACTER*(*) PERIOD, COMMA, SEMICN PARAMETER ( PERIOD = '.', COMMA = ',', SEMICN = ';' ) CHARACTER*(*) COLON, DASH, EQUALS PARAMETER ( COLON = ':', DASH = '-', EQUALS = '=' ) CHARACTER*(*) OBRACE, CBRACE, UNDERS PARAMETER ( OBRACE = '{', CBRACE = '}', UNDERS = '_' ) CHARACTER*(*) PLUS, MINUS, EXCLAM PARAMETER ( PLUS = '+', MINUS = '-', EXCLAM = '!' ) CHARACTER*(*) GTHAN, LTHAN, QUESMK PARAMETER ( GTHAN = '>', LTHAN = '<', QUESMK = '?' ) CHARACTER*(*) SLASH, BSLASH, PERCNT PARAMETER ( SLASH = '/', BSLASH = '\\',PERCNT = '%' ) CHARACTER*(*) CARAT, ATSIGN, TILDE PARAMETER ( CARAT = '^', ATSIGN = '@', TILDE = '~' ) INTEGER NINTS, NLOGS, NREALS, NTRACF PARAMETER ( NINTS = 14, NLOGS = 32, NREALS = 2, NTRACF = 15 ) INTEGER XDRVMD, XNORM, XSCALE, XLTRCU PARAMETER ( XDRVMD = 1, XNORM = 2, XSCALE = 3, XLTRCU = 4 ) INTEGER XETRCU, XPTRCU, XTTRCU PARAMETER ( XETRCU = 5, XPTRCU = 6, XTTRCU = 7 ) INTEGER XMETH, XQUADN, XALPS1, XSCGMM PARAMETER ( XMETH = 8, XQUADN = 9, XALPS1 = 10, XSCGMM = 11 ) INTEGER XHTEST, XUPDTT, XSTSTP PARAMETER ( XHTEST = 12,XUPDTT = 13, XSTSTP = 14 ) INTEGER XTRACE PARAMETER ( XTRACE = 1 ) INTEGER XTRF, XTRG, XTTRCE, XTRTST PARAMETER ( XTRF = 16, XTRG = 17, XTTRCE = 18, XTRTST = 19 ) INTEGER XGRAD, XPOINT, XTGRAD PARAMETER ( XGRAD = 20, XPOINT = 21, XTGRAD = 22 ) INTEGER XTSTEP, XTSHXG, XTFUNC, XRELF PARAMETER ( XTSTEP = 23,XTSHXG = 24, XTFUNC = 25, XRELF = 26 ) INTEGER XRELG, XFQUAD, XDIAGL PARAMETER ( XRELG = 27, XFQUAD = 28, XDIAGL = 29 ) INTEGER XSHNNO, XFRMRS, XFRCEF PARAMETER ( XSHNNO = 30,XFRMRS = 31, XFRCEF = 32 ) INTEGER XRO, XBETA PARAMETER ( XRO = 1, XBETA = 2 ) LOGICAL T, F PARAMETER ( T = .TRUE., F = .FALSE. ) CHARACTER*(*) TRUE, QT, FALSE, QF PARAMETER ( TRUE = 'TRUE', QT = 'T', FALSE = 'FALSE', QF = 'F' ) INTEGER ITRUE, IFALSE PARAMETER ( ITRUE = 1, IFALSE = 0 ) REAL RTRUE, RFALSE C!!!! DOUBLE PRECISION RTRUE, RFALSE PARAMETER ( RTRUE = 1.D0, RFALSE = 0.D0 ) INTEGER CTOUPP, CTOLOW, CTOCAP PARAMETER ( CTOUPP = 1, CTOLOW = 2, CTOCAP = 3 ) INTEGER CANAL, CDIFF, CTEST, CFIRST PARAMETER ( CANAL = 1, CDIFF = 2, CTEST = 3, CFIRST = 4 ) INTEGER SUMFRM, PRDFRM, MJDFRM PARAMETER ( SUMFRM = 1, PRDFRM = 2, MJDFRM = 3 ) INTEGER NL1, NL2, NLINF PARAMETER ( NL1 = 1, NL2 = 2, NLINF = 3 ) INTEGER NQUITS PARAMETER ( NQUITS = 4 ) INTEGER PGRAD, PSTEP, PSHXG, PFUNC PARAMETER ( PGRAD = 1, PSTEP = 2, PSHXG = 3, PFUNC = 4 ) INTEGER GAMOFF, GAMONE, GAMALL PARAMETER ( GAMOFF = 0, GAMONE = 1, GAMALL = 2 ) C--ZZEVAL. LOGICAL TRF, TRG, TRTEST PARAMETER ( TRF = F, TRG = F, TRTEST = F ) INTEGER ETRACU, SCALE, DERVMD PARAMETER ( ETRACU = 6, SCALE = 0, DERVMD = CANAL ) C--ZZPRNT. INTEGER PTRACU LOGICAL GRAD, POINT PARAMETER ( GRAD = T, POINT = T, PTRACU = 6 ) C--ZZTERM. INTEGER NORM, TTRACU PARAMETER ( NORM = NL2, TTRACU = 6 ) LOGICAL TGRAD, TSTEP, TSHXG, TFUNC PARAMETER ( TGRAD = F, TSTEP= T, TSHXG = T, TFUNC = F ) LOGICAL RELF, RELG, TTRACE PARAMETER ( RELF = T, RELG = T, TTRACE = F ) C--BBLNIR. INTEGER METH, QUADIN, ALPIS1, STSTEP C PARAMETER ( METH = 0, QUADIN = 2, ALPIS1 = 1, STSTEP = 2 ) PARAMETER ( METH = 0, QUADIN = 4, ALPIS1 = 4, STSTEP = 2 ) INTEGER SCGAMM, HTEST, UPDATT PARAMETER ( SCGAMM = GAMONE, HTEST = 1, UPDATT = SUMFRM ) REAL RO, BETA C!!!! DOUBLE PRECISION RO, BETA PARAMETER ( RO = 0.2D0, BETA = 1.0D0 ) LOGICAL FQUAD, DIAGNL, SHANNO PARAMETER ( FQUAD = F, DIAGNL = F, SHANNO = F ) LOGICAL FROMRS, FORCEF PARAMETER ( FROMRS = F, FORCEF = T ) INTEGER LTRACU LOGICAL TRACE PARAMETER ( LTRACU = 6, TRACE = F ) C## L O C A L D E C L: INTEGER KEEPI(NINTS), SINTS(NINTS), I, RUNIT, WUNIT, SANAL LOGICAL KEEPL(NLOGS), SLOGS(NLOGS), ON, OFF CHARACTER*(NLOGS) CHECK REAL KEEPR(NREALS), SREALS(NREALS) C!!!! DOUBLE PRECISION KEEPR(NREALS), SREALS(NREALS) C## S A V E: EVERYTHING SAVE C## C O M M O N: NONE IS DEFINED. C## D A T A: NO VALUES ARE SET. DATA KEEPI(XDRVMD) /DERVMD/, KEEPI(XNORM ) /NORM / DATA KEEPI(XSCALE) /SCALE /, KEEPI(XLTRCU) /LTRACU/ DATA KEEPI(XETRCU) /ETRACU/, KEEPI(XPTRCU) /PTRACU/ DATA KEEPI(XTTRCU) /TTRACU/, KEEPI(XMETH ) /METH / DATA KEEPI(XQUADN) /QUADIN/, KEEPI(XALPS1) /ALPIS1/ DATA KEEPI(XSCGMM) /SCGAMM/, KEEPI(XHTEST) /HTEST / DATA KEEPI(XUPDTT) /UPDATT/, KEEPI(XSTSTP) /STSTEP/ DATA KEEPL(XTRF ) /TRF /, KEEPL(XTRG ) /TRG / DATA KEEPL(XTTRCE) /TTRACE/, KEEPL(XTRTST) /TRTEST/ DATA KEEPL(XGRAD ) /GRAD /, KEEPL(XPOINT) /POINT / DATA KEEPL(XTGRAD) /TGRAD /, KEEPL(XTSTEP) /TSTEP / DATA KEEPL(XTSHXG) /TSHXG /, KEEPL(XTFUNC) /TFUNC / DATA KEEPL(XRELF ) /RELF /, KEEPL(XRELG ) /RELG / DATA KEEPL(XFQUAD) /FQUAD /, KEEPL(XDIAGL) /DIAGNL/ DATA KEEPL(XSHNNO) /SHANNO/, KEEPL(XFRMRS) /FROMRS/ DATA KEEPL(XFRCEF) /FORCEF/ DATA (KEEPL(I),I=XTRACE,XTRACE+NTRACF-1) /NTRACF*TRACE/ DATA KEEPR(XRO ) /RO/, KEEPR(XBETA ) /BETA / C## E X E C U T I O N C## E X E C U T I O N C---STATEMENT FUNCTION. ON(I) = CHECK(I:I) .EQ. 'Y' .OR. CHECK(I:I) .EQ. 'T' OFF(I) = CHECK(I:I) .EQ. 'N' .OR. CHECK(I:I) .EQ. 'F' C---- DO 100 I = 1, NINTS INTS(I) = KEEPI(I) 100 CONTINUE DO 200 I = 1,NLOGS LOGS(I) = KEEPL(I) 200 CONTINUE CALL ZZCOPY ( NREALS, KEEPR, 1, REALS, 1 ) GOTO 90000 C## E N T R Y BBRVAL: ENTRY BBRVAL (WUNIT, RUNIT) C THIS IS USED TO INTERACTIVELY READ IN REPLACEMENT VALUES FOR C CONTROL PARAMETERS. IF AN END-OF-FILE IS ENCOUNTERED, EXECUTION C OF THIS ROUTINE TERMINATES IMMEDIATELY AND NO FURTHER VALUES C ARE READ. CHECK = BLANK WRITE( WUNIT, '(A,I3,A)') - ' ENTER STRING OF T, F OR BLANK' - //' CHARACTERS TO DEFINE UP TO ',NLOGS,' LOGICAL VALUES:' READ ( RUNIT, '(A)' ,END = 399 ) CHECK CALL ZZCASE (CHECK,CTOUPP) DO 350 I=1,NLOGS IF ( ON(I) ) THEN KEEPL(I) = T ELSE IF ( OFF(I) ) THEN KEEPL(I) = F ENDIF 350 CONTINUE WRITE( WUNIT, '(A,I3,A)') - ' ENTER FREE FORMAT LIST OF UP TO ',NINTS, ' INTEGER VALUES:' READ ( RUNIT, *, END = 399 ) (KEEPI(I),I=1,NINTS ) WRITE( WUNIT, '(A,I3,A)') - ' ENTER FREE FORMAT LIST OF UP TO ', NREALS, ' REAL VALUES:' READ ( RUNIT, *, END = 399 ) (KEEPR(I),I=1,NREALS) 399 CONTINUE RETURN C## E N T R Y BBSVAL: ENTRY BBSVAL ( SINTS, SLOGS, SREALS ) DO 400 I = 1,NINTS KEEPI(I) = SINTS(I) 400 CONTINUE DO 500 I = 1,NLOGS KEEPL(I) = SLOGS(I) 500 CONTINUE CALL ZZCOPY ( NREALS, SREALS, 1, KEEPR, 1 ) RETURN C## E N T R Y BBDVAL: C REDEFINE ANALYTIC CODE FOR DERIVATIVE MODE. ENTRY BBDVAL ( SANAL ) KEEPI(XDRVMD) = SANAL RETURN C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF BBVALS. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> vscgsg.f SUBROUTINE BBVSCG( FUNCNM, N, X, F, G, ACCT, STATUS, ITERS, FNCCT, - WORK, LWORK ) C## A R G U M E N T S: EXTERNAL FUNCNM INTEGER N, STATUS, ITERS, FNCCT, LWORK REAL X(N),F,G(N),ACCT,WORK(LWORK+1), FUNCNM C!!!! DOUBLE PRECISION X(N),F,G(N),ACCT,WORK(LWORK+1), FUNCNM C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: VSCG.F,V 1.12 91/11/22 11:34:51 BUCKLEY EXP $ C>RCS $LOG: VSCG.F,V $ C>RCS REVISION 1.12 91/11/22 11:34:51 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.11 90/07/31 10:50:25 BUCKLEY C>RCS ADDED REVISED BLAS. C>RCS C>RCS REVISION 1.10 90/06/25 16:27:07 BUCKLEY C>RCS WORKING REVISION; CHECKING OUT TOMS VERSION FOR FIX C>RCS C>RCS REVISION 1.9 89/06/30 13:27:53 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.2 89/05/15 14:55:43 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:54:31 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE ACTS AS AN INTERMEDIARY BETWEEN THE CALLING ROUTINE C AND THE ACTUAL MINIMIZATION ROUTINE BBLNIR. IT JUST SERVES TO C SIMPLIFY THE CALLING SEQUENCE A LITTLE FOR THE USER, TO SIMPLIFY C THE ARRAY REFERENCING WITHIN THE ALGORITHM BBLNIR AND TO SET ALL C DEFAULTS AND DO INITIALIZATION FOR ROUTINES ZZEVAL, ZZPRNT AND C ZZTERM USED BY BBLNIR, AS WELL AS FOR BBLNIR ITSELF. C C THE PARAMETERS ARE EXPLAINED IN THE DESCRIPTION SECTION OF BBLNIR, C WITH THE EXCEPTION OF THE ARRAY WORK. IT IS A REAL (OR DOUBLE C PRECISION) ARRAY WHICH IS SPLIT UP INTO SUBARRAYS TO PASS TO C BBLNIR. C C NOTE THAT LWORK IS THE TOTAL AMOUNT OF STORAGE AVAILABLE AS C PASSED TO BBVSCG; HDIM IS PASSED TO BBLNIR AS THE WORKING STOR- C AGE AVAILABLE FOR THE ARRAY H. THUS LWORK MUST BE OF SIZE C HDIM + 3*N, WHERE HDIM IS THE AMOUNT REQUIRED FOR BBLNIR. C THE MINIMUM REQUIREMENT FOR LWORK IS 3N, BUT THAT LEAVES C NONE FOR HDIM. SEE "METH" IN BBLNIR FOR FURTHER INFORMATION C ABOUT THE DIMENSION OF WORK. WE RECOMMEND A MINIMUM OF 5N+2 C FOR LWORK. C N.B. C WORK MUST CONTAIN AT LEAST 1 ELEMENT MORE THAN THE VALUE C GIVEN BY LWORK. THIS IS BECAUSE THE BALANCE IS USED FOR C THE RW/DW ARRAY. SEE THE EXTERNAL DOCUMENTATION. C C## E N T R Y P O I N T S: BBVSCG THE NATURAL ENTRY POINT. C BBVIDF REDEFINE ENTRY STATUS CODES. C BBVSDF REDEFINE EXIT STATUS CODES. C C## S U B R O U T I N E S: C C BBLNIR ...THE MAIN MINIMIZATION ALGORITHM. C BBDFLT ...TO SET UP ZZPRNT, ZZEVAL, ZZTERM AND BBLNIR. C BBEGET ...TO GET DATA FROM ZZEVAL. C BBPGET ...TO GET DATA FROM ZZPRNT. C ZZINNR ...FOR COMPUTING EUCLIDEAN INNER PRODUCTS. C ZZSECS ...FOR TIME. C C## P A R A M E T E R S: C--ON ENTRY: INTEGER CNORML, CRCSTR, CRCRPT, CRCNFG PARAMETER ( CNORML = 0, CRCSTR = 1, CRCRPT = 2, CRCNFG = 3 ) INTEGER CNRMFG, CPSTHR PARAMETER ( CNRMFG = -1, CPSTHR = -2 ) C--ON EXIT: INTEGER CDONE, CRCF, CRCFG, CRCG PARAMETER ( CDONE = 0, CRCF = 1, CRCFG = 2, CRCG = 3 ) INTEGER CNSTOR, CIPMIN, CIPUNF, CBDMTH PARAMETER ( CNSTOR = -1, CIPMIN = -2, CIPUNF = -3, CBDMTH = -4 ) INTEGER CLSFAL, CNODSC, CXSFNC, CPSBCK PARAMETER ( CLSFAL = -5, CNODSC = -6, CXSFNC = -7, CPSBCK = -8 ) INTEGER CRABRT, CUSERV PARAMETER ( CRABRT = -9, CUSERV = -10 ) REAL ZERO, ONE, TWO, THREE C!!!! DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) REAL FOUR, FIVE, SIX, SEVEN C!!!! DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) REAL EIGHT, NINE, TEN C!!!! DOUBLE PRECISION EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 9D0, TEN = 10D0 ) C## L O C A L D E C L: INTEGER HDIM, ID, IX, IG, IH, IW(1), FNCT, GRCT, ITCT INTEGER SNRMFG, SNORML, SRCSTR, SRCRPT, SRCNFG, SPSTHR INTEGER NORMFG, NORMAL, RCSTRT, RCRPT, RCNOFG, PSTHRU INTEGER SDONE, SRCF, SRCFG, SRCG, SNSTOR, SIPMIN, SPSBCK INTEGER DONE, RCF, RCFG, RCG, NOSTOR, IPMIN, PSBACK INTEGER SIPUNF, SBDMTH, SLSFAL, SNODSC, SXSFNC, SRABRT, SUSERV INTEGER IPUNDF, BDMETH, LSFAIL, NODESC, XSFUNC, RABORT, USERV C *** NOTE THAT THESE DECLARATIONS ARE **DELIBERATELY** REVERSED FROM C *** THE NORMAL REAL/DOUBLE PRECISION PAIRS! DOUBLE PRECISION DW(1) C!!!! REAL RW(1) EXTERNAL ZZINNR DOUBLE PRECISION ZZINNR REAL DECRF, TT, TIME C!!!! DOUBLE PRECISION DECRF, TT, TIME C## S A V E: SAVE HDIM, ID, IX, IG, IH, DECRF, TT SAVE NORMFG, NORMAL, RCSTRT, RCRPT, RCNOFG, PSTHRU SAVE DONE, RCF, RCFG, RCG, NOSTOR, IPMIN, IPUNDF, BDMETH SAVE LSFAIL, NODESC, RABORT, XSFUNC, USERV, PSBACK C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA NORMFG/CNRMFG/, NORMAL/CNORML/, RCSTRT/CRCSTR/, - RCRPT /CRCRPT/, RCNOFG/CRCNFG/, PSTHRU/CPSTHR/ DATA DONE /CDONE/, RCF /CRCF/, RCFG /CRCFG/, RCG/CRCG/ - NOSTOR/CNSTOR/, IPMIN /CIPMIN/, IPUNDF/CIPUNF/, - BDMETH/CBDMTH/, LSFAIL/CLSFAL/, NODESC/CNODSC/, - RABORT/CRABRT/, XSFUNC/CXSFNC/, USERV /CUSERV/, - PSBACK/CPSBCK/ C## E X E C U T I O N C## E X E C U T I O N IF ( STATUS .EQ. NORMAL .OR. STATUS .EQ. NORMFG - .OR. STATUS .EQ. RCSTRT ) THEN C START TIMING. CALL ZZSECS (TT) C SET DEFAULTS. CALL BBDFLT ( ITERS, FNCCT ) C DEFINE POINTERS TO SUBDIVIDE WORK. ID = 1 IX = ID + N IG = IX + N IH = IG + N C DETERMINE REMAINING STORAGE AVAILABLE FOR H. HDIM = LWORK - 3*N C SET EXPECTED DECREASE IN F TO BE UNKNOWN. DECRF = -ONE ENDIF C-----CALL ROUTINE FOR ACTUAL MINIMIZATION. CALL BBLNIR( FUNCNM, N, X, F, DECRF, G, ACCT, STATUS, ZZINNR, - WORK(ID), WORK(IX), WORK(IG), WORK(IH),HDIM,IW,WORK(LWORK+1),DW) C!!!!- WORK(ID), WORK(IX), WORK(IG), WORK(IH),HDIM,IW,RW,WORK(LWORK+1)) C-----RESET TIME, ITERATION COUNT AND FUNCTION COUNT BEFORE RETURN. IF ( STATUS .NE. RCF .AND. STATUS .NE. RCFG - .AND. STATUS .NE. RCG .AND. STATUS .NE. PSBACK ) THEN IF ( STATUS .EQ. NOSTOR .OR. STATUS .EQ. IPMIN .OR. - STATUS .EQ. IPUNDF .OR. STATUS .EQ. BDMETH ) THEN FNCCT = 0 ITERS = 0 ELSE CALL ZZEGET( FNCT, GRCT, TIME ) CALL ZZPGET( TIME, ITCT ) FNCCT = FNCT ITERS = ITCT ENDIF CALL ZZSECS( TIME ) ACCT = TIME - TT ENDIF GOTO 90000 C## E N T R Y BBVIDF: SET VALUES FOR STATUS *PASSED INTO* BBLNIR. ENTRY BBVIDF ( SNRMFG, SNORML, SRCSTR, SRCRPT, - SRCNFG, SPSTHR ) NORMFG = SNRMFG NORMAL = SNORML RCSTRT = SRCSTR RCRPT = SRCRPT RCNOFG = SRCNFG PSTHRU = SPSTHR RETURN C## E N T R Y BBVSDF: C SET VALUES FOR STATUS *RETURNED BY* BBLNIR. ENTRY BBVSDF ( SDONE, SRCF, SRCFG, SRCG, SNSTOR, SIPMIN, - SIPUNF, SBDMTH, SLSFAL, SNODSC, SXSFNC, SRABRT, SUSERV, - SPSBCK ) DONE = SDONE RCF = SRCF RCFG = SRCFG RCG = SRCG NOSTOR = SNSTOR IPMIN = SIPMIN IPUNDF = SIPUNF BDMETH = SBDMTH LSFAIL = SLSFAL NODESC = SNODSC XSFUNC = SXSFNC RABORT = SRABRT USERV = SUSERV PSBACK = SPSBCK RETURN C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF BBVSCG. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> evalsg.f SUBROUTINE ZZEVAL ( ZZUFNC, N, X, F, G, INDIC, IW, RW, DW ) C## A R G U M E N T S: INTEGER INDIC, N, IW(*) EXTERNAL ZZUFNC REAL F, X(N), G(N) C!!!! DOUBLE PRECISION F, X(N), G(N) DOUBLE PRECISION DW(*) REAL RW(*) C## S T A T U S: C IGNORE LINES BEGINNING WITH "C!!!!" . C C SYSTEM DEPENDENCE: NONE. C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C>RCS $HEADER: EVAL.F,V 2.1 91/11/20 10:46:57 BUCKLEY EXP $ C>RCS $LOG: EVAL.F,V $ C>RCS REVISION 2.1 91/11/20 10:46:57 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 2.0 90/07/31 11:15:06 BUCKLEY C>RCS ADDED REVISED BLAS. C>RCS C>RCS REVISION 1.9 89/06/30 13:11:45 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3 89/05/18 12:47:25 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:53:33 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/07 14:35:47 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS SUBROUTINE EVALUATES A TEST FUNCTION AT THE GIVEN C POINT "X". IT RETURNS THE VALUE OF THE FUNCTION AND / OR C THE VALUE OF THE GRADIENT AT X. IT ALLOWS THE APPLICATION OF A C NONLINEAR SCALING TO THE FUNCTION IF DESIRED (SEE FSCALE BELOW). C IT ALSO ALLOWS THE USE OF FINITE DIFFERENCES (SEE SDRVMD BELOW). C IT CAN ALSO ACT AS A NOOP, I.E. AS A DO NOTHING ROUTINE; (SEE C INDIC BELOW). C C-----ON ENTRY: C C ZZUFNC THE NAME OF THE FUNCTION TO EVALUATE. THERE C MUST BE A SUBROUTINE PROVIDED OF THE FORM C C SUBROUTINE ZZUFNC(INDIC,N,X,F,G,IW,RW,DW) C C (WHERE N, X, F, G, INDIC, IW, RW AND DW HAVE THE C SAME MEANING AS IN THIS SUBROUTINE ZZEVAL.) C C N THE DIMENSION OF THE PROBLEM, I.E. THE C NUMBER OF VARIABLES IN THE FUNCTION ZZUFNC. C C X CONTAINS THE VALUE OF THE N-COORDINATES X[1],...,X[N] C AT WHICH TO EVALUATE THE FUNCTION. C C INDIC = DOF ONLY EVALUATE THE FUNCTION. C = DOFG EVALUATE BOTH. C = DOG ONLY EVALUATE THE GRADIENT. C = NONE ACTUALLY, IF INDIC HAS ANY VALUE OTHER THAN C ONE OF THE FIRST THREE, THEN JUST CALL ZZUFNC C WITH THIS SAME CODE FOR INDIC; I.E. ZZEVAL SHOULD DO C NOTHING. THIS IS INTENDED FOR THE CONVENIENCE OF THE C WRITER OF ZZUFNC. C C NOTE THAT THE VALUES OF THESE CODES CAN BE REDEFINED C THROUGH THE ENTRY POINT ZZFDEF BELOW. DEFAULT VALUES C ARE GIVEN IN THE PARAMETER SECTION BELOW. C C IW THESE ARE 3 WORK ARRAYS WHICH ARE NOT USED AT ALL BY C RW ZZEVAL, BUT WHICH ARE JUST PASSED TO THE USER'S C DW ROUTINE ZZUFNC TO BE USED AS DESIRED. WITH THESE ARRAYS C AVAILABLE, IT IS OFTEN NOT NECESSARY TO USE REVERSE C COMMUNICATION. NOTE THAT THERE IS ONE AVAILABLE OF C EACH BASIC NUMERIC TYPE. C C-----ON EXIT: C C F CONTAINS THE FUNCTION VALUE (WITH THE SCALING C APPLIED IF REQUIRED). C C G CONTAINS THE GRADIENT VALUE (WITH THE SCALING C APPLIED IF REQUIRED). C C NEITHER F NOR G IS REFERENCED UNLESS ITS VALUE IS REQUESTED. C C INDIC = OK THE REQUEST MADE ON THE CALL WAS COMPLETED SATIS- C FACTORILY. F AND/OR G ARE AVAILABLE AS REQUESTED. C ABORT THE MINIMIZATION ROUTINE WHICH CALLED ZZEVAL IS C HEREBY REQUESTED TO EXIT IMMEDIATELY TO THE ROUTINE C WHICH CALLED IT. THIS CAN BE USED BY THE ROUTINE C ZZUFNC TO TRIGGER PREMATURE TERMINATION DUE TO C CIRCUMSTANCES OF WHICH THE MINIMIZATION ROUTINE MAY C NOT BE AWARE. C LIMIT TERMINATE THE MINIMIZATION; THE PRESET LIMIT ON THE C NUMBER OF FUNCTION EVALUATIONS ALLOWED HAS BEEN C EXCEEDED. SEE MAXFN BELOW. C NOF THE FUNCTION VALUE COULD NOT BE DETERMINED. C NOG THE GRADIENT VALUE COULD NOT BE DETERMINED. C NOFG NEITHER F NOR G COULD BE EVALUATED. C C THESE CODES CAN BE REDEFINED THROUGH AN ENTRY POINT BELOW, C AND HAVE DEFAULT VALUES SPECIFIED IN THE PARAMETER SECTION. C C-----SET THROUGH ENTRY POINT CALLS. C C ZZESRT ( FSCALE, SDRVMD, MAXFN ) M A N D A T O R Y C C THIS IS CALLED BEFORE MINIMIZING EACH FUNCTION. THIS CALL C IS M A N D A T O R Y. C C FSCALE CONTROLS THE NONLINEAR SCALING OF ZZUFNC. C C = 0 NO EFFECT. C C = K>0 THIS ROUTINE COMPUTES AND RETURNS FF( ZZUFNC(X) ), C WHERE FF IS THE K-TH OF THE NONLINEAR FUNCTIONS C OF ONE VARIABLE DEFINED IN THE ROUTINE ZZFSCL. C C NOTE THAT FOR CERTAIN SCALINGS, IF YOU CALL ZZEVAL C JUST FOR A GRADIENT VALUE, IT MAY BE NECESSARY TO C REQUEST A FUNCTION VALUE AS WELL IN ORDER TO DO THE C SCALING. THAT FUNCTION VALUE WILL NOT BE PASSED BACK. C THOSE WHICH DO NOT REQUIRE F FOR THE SCALING ARE THOSE C WITH K = 1,2,..,REQF - 1. FOR K = REQF,..., THE VALUE C OF F IS NECESSARY. C C SDRVMD THIS SPECIFIES THE METHOD BY WHICH DERIVATIVES ARE C TO BE COMPUTED, WHEN REQUESTED. THE CHOICE IS BETWEEN C C CANAL USE ANALYTIC FORMULAE WHICH MUST BE CODED AND C AVAILABLE IN THE USER ROUTINE ZZUFNC. C C CDIFF USE FINITE DIFFERENCE APPROXIMATIONS. IN THIS CASE, C THE USER ROUTINE MAY IGNORE CALLS WITH INDIC <> JUSTF, C AND NEED ONLY BE ABLE TO COMPUTE FUNCTION VALUES. C FURTHER COMMENTS APPEAR IN THE DISCUSSION OF FINITE C DIFFERENCE COMPUTATIONS (BELOW). C C CTEST IN THIS CASE BOTH ANALYTIC AND FINITE DIFFERENCES C ARE COMPUTED. THEY ARE THEN COMPARED AND A RECORD C IS KEPT TO SEE TO WHAT EXTENT THEY DISAGREE. A C RECORD OF THE LEVEL OF AGREEMENT IS AVAILABLE C THROUGH THE ENTRY POINT ZZECHK GIVEN BELOW. A MORE C COMPLETE DESCRIPTION IS ALSO GIVEN WHERE ZZECHK IS C DISCUSSED BELOW. C C CFIRST THIS CASE IS PRECISELY THE SAME AS FOR CTEST, WITH C THE SOLE EXCEPTION THAT THE TESTING ONLY TAKES PLACE C ON THE FIRST CALL TO ZZEVAL. C C THE INTEGER VALUES OF THE CODES FOR CANAL, ETC ARE C SET IN THE PARAMETER SECTION BELOW. THEY MAY BE C RESET VIA THE ENTRY POINT ZZEDEF DESCRIBED BELOW. C C MAXFN THE MAXIMUM VALUE ALLOWED FOR THE COUNT IFNCT. C C <= 0 ON ENTRY SPECIFIES NO MAXIMUM, I.E. MAXFN IS C IGNORED. C C = K>0 SPECIFIES THE MAXIMUM NUMBER OF TIMES THAT ZZUFNC C MAY BE CALLED. IF THE FUNCTION EVALUATION COUNT C IN IFNCT IS GREATER THAN OR EQUAL TO MAXFN ON C ENTRY TO ZZEVAL, THEN THE FUNCTION IS NOT C EVALUATED AND THE RETURN CODE INDIC IS SET AS C ABOVE. NOTE THAT THE COUNT IN IFNCT DOES N O T C INCLUDE FUNCTION EVALUATIONS USED FOR COMPUTING C FINITE DIFFERENCE GRADIENTS. C C C THE NEXT FOUR PARAMETERS ARE NOT IN THE CALLING SEQUENCE OF C ZZESRT, BUT THEY ARE INITIALIZED WHEN ZZESRT IS CALLED. C C IFNCT COUNTS THE NUMBER OF TIMES THE ROUTINE IS CALLED C TO EVALUATE THE FUNCTION. IT IS INITIALIZED TO 0 C DURING THE CALL TO ZZESRT. C C IGRCT COUNTS THE NUMBER OF TIMES THE ROUTINE IS CALLED C TO EVALUATE THE GRADIENT. IT IS INITIALIZED TO 0 C DURING THE CALL TO ZZESRT. C C FTIME RECORDS THE TIME ACCUMULATED IN EVALUATING THE C FUNCTION AND/OR THE GRADIENT. IT IS PRESET TO ZERO C WHEN ZZESRT IS CALLED. THE TIME USED IN THE FINAL C SCALING IS INCLUDED IN THE TIMING WHEN THE VALUE OF C FSCALE IS NON-ZERO. TIMING COMMENCES ON ENTRY TO C ZZEVAL, AND ENDS JUST BEFORE RETURN FROM ZZEVAL. C C ERR THE ESTIMATE OF THE ERROR BETWEEN THE ANALYTIC C AND DIFFERENCE VALUES FOR THE GRADIENT IS RECORDED C IN A SET OF VARIABLES ERR, SERR, DCNT, INDEX AND C GCNT, SO THESE ARE INITIALIZED TO 0. C C ZZESET ( TRF, TRG, TRTEST, ITRUN ) C C THIS IS CALLED BEFORE USING ZZEVAL (THESE VALUES ALSO HAVE C INTERNALLY SET DEFAULT VALUES GIVEN IN [..], SO THE CALL TO C ZZESET IS NOT MANDATORY.) C C TRF = TRUE IF THE FUNCTION VALUE IS TO BE PRINTED [FALSE] C TRG = TRUE IF THE GRADIENT VALUE IS TO BE PRINTED [FALSE] C TRTEST = TRUE IF THE FUNCTION VALUES ARE TO BE PRINTED C DURING TESTING MODE [FALSE] C C ITRUN THE UNIT NUMBER FOR OUTPUT OF COMPUTED VALUES [6] C C NOTE THAT AN ERROR MESSAGE IS PRINTED WHEN THE MAXIMUM NUMBER C OF FUNCTION EVALUATIONS IS EXCEEDED, PROVIDED EITHER TRF OR C TRG IS TRUE. C C ZZEDDF ( SANAL, SDIFF, STEST, SFIRST ) C C THIS MAY BE CALLED BEFORE USING ZZEVAL, AS FOR ZZESET. THIS C ALLOWS THE CODES FOR ANAL, ETC., TO BE REDEFINED. ALL HAVE C DEFAULTS, SO THIS CALL IS NOT MANDATORY. C C SANAL THE INTEGER VALUE FOR THE CODE FOR USING ANALYTIC C DERIVATIVES [CANAL]. C SDIFF THE INTEGER VALUE FOR THE CODE FOR USING FINITE C DIFFERENCES TO APPROXIMATE DERIVATIVES [CDIFF]. C STEST THE INTEGER VALUE FOR THE CODE FOR USING BOTH CANAL C AND CDIFF AND DOING A TEST FOR AGREEMENT [CTEST]. C SFIRST THE INTEGER VALUE FOR THE CODE FOR USING BOTH CANAL C AND CDIFF ON THE FIRST ITERATION ONLY. C C ZZEFDF ( SDOF, SDOG, SDOFG, SNONE ) C C THIS MAY BE CALLED BEFORE USING ZZEVAL, JUST AS FOR ZZEDEF. C C DOF THE CODE INDICATING THAT JUST THE FUNCTION VALUE IS C DESIRED. [JUSTF] C DOG THE CODE INDICATING THAT JUST THE GRADIENT VALUE IS C DESIRED. [JUSTG] C DOFG THE CODE INDICATING THAT BOTH THE FUNCTION AND GRADIENT C VALUES ARE DESIRED. [BOTH] C SNONE THE CODE INDICATING THAT NO ACTION IS TO BE TAKEN AND C THAT ZZUFNC SHOULD BE CALLED WITH NO OTHER PROCESSING. C C ZZERDF ( OK, LIMIT, ABORT, NOF, NOG, NOFG ) C C THIS MAY BE CALLED BEFORE USING ZZEVAL, JUST AS FOR ZZEDEF. C C OK THIS CODE INDICATES THAT THE REQUEST WAS SUCCESSFULLY DONE. C ABORT THIS MEANS THAT THE CALLING ROUTINE SHOULD IMMEDIATELY C TERMINATE THE MINIMIZATION AND RETURN TO THE ROUTINE WHICH C CALLED IT. C LIMIT THIS MEANS THAT THE ALLOWED NUMBER OF FUNCTION EVALUATIONS C HAS BEEN EXCEEDED. C NOF THIS MEANS THAT ZZEVAL WAS UNABLE TO SUCCESSFULLY EVALUATE C THE FUNCTION. C NOG THIS MEANS THAT ZZEVAL WAS UNABLE TO SUCCESSFULLY EVALUATE C THE GRADIENT. C NOFG THIS MEANS THAT ZZEVAL WAS UNABLE TO OBTAIN EITHER A C FUNCTION OR GRADIENT VALUE. C C-----AVAILABLE THROUGH ENTRY POINT CALLS AFTER A FUNCTION HAS BEEN C MINIMIZED: C C ZZEGET ( FNCT, GRCT, TIME ) C C THIS MAY BE CALLED AFTER MINIMIZING A FUNCTION TO OBTAIN SOME C SIMPLE STATISTICS WHICH HAVE BEEN ACCUMULATED SINCE THE LAST C CALL TO ZZESRT. THESE ARE C C FNCT THE NUMBER OF CALLS TO EVALUATE THE FUNCTION, I.E. C CALLS WITH INDIC = JUSTF OR BOTH. C C GRCT THE NUMBER OF CALLS TO EVALUATE THE GRADIENT, I.E. C CALLS WITH INDIC = JUSTG OR BOTH. C C TIME THE AMOUNT OF CPU TIME SPENT IN ZZEVAL. C C ZZECHK ( ERR, AVERR, INDX, ITERAT ) C C C THIS MAY ALSO BE CALLED AFTER A SEQUENCE OF CALLS TO ZZEVAL. C IT GIVES AN ESTIMATE OF THE AGREEMENT BETWEEN ANALYTIC AND C FINITE DIFFERENCE DERIVATIVES. OF COURSE THESE VALUES ARE ONLY C DEFINED IF SDRVMD = CTEST. C C ERR WILL BE RETURNED AS AN ESTIMATE OF THE LARGEST ERROR C WHICH OCCURRED AND AVERR IS AN ESTIMATE OF THE AVERAGE NUMBER OF C DECIMAL DIGITS OF AGREEMENT BETWEEN THE COMPONENTS OF THE ANALYTIC C AND DIFFERENCE DERIVATIVES. C C TO BE SPECIFIC, WHEN IN TEST MODE, EACH COMPONENT OF THE C ANALYTIC DERIVATIVE IS COMPUTED, AND THAT IS RETURNED IN G AS THE C GRADIENT. AS WELL, FOR EACH COMPONENT, A FINITE DIFFERENCE C APPROXIMATION IS COMPUTED (AS DESCRIBED BELOW) AND THE RELATIVE C DIFFERENCE BETWEEN THAT AND THE ANALYTIC COMPONENT IS DETERMINED. C THIS QUANTITY IS MONITORED, AND THE LARGEST SUCH VALUE IS C RECORDED. IN ADDITION, INDX INDICATES IN WHICH COMPONENT OF THAT C GRADIENT THE ERROR OCCURRED AND ITERAT TELLS WHICH GRADIENT C EVALUATION WAS IN PROGRESS WHEN THE ERROR OCCURRED; I.E. ITERAT C JUST RECORDS THE CURRENT VALUE OF IGRCT. NOTE THAT INDX C AND ITERAT ONLY REFER TO THE POINT AT WHICH THE LARGEST C ERROR OCCURRED. C C IF THE FUNCTION AND GRADIENT EVALUATIONS ARE CORRECT, ONE C WOULD NORMALLY EXPECT THE RELATIVE ERROR TO BE OF THE ORDER OF C 10**-(T/2), WHERE T IS THE NUMBER OF FIGURES OF RELATIVE C ACCURACY OF THE MACHINE IN USE. HOWEVER, AS THE MINIMUM IS C APPROACHED AND THE GRADIENT COMPONENTS GENERALLY BECOME VERY C SMALL, THIS RELATIVE ACCURACY MAY BE MUCH WORSE THAN EXPECTED. C THEREFORE WE ALSO MAINTAIN AN ESTIMATE OF THE AVERAGE AGREEMENT. C HERE, FOR EACH COMPONENT OF EACH GRADIENT COMPUTATION, WE COMPUTE C THE BASE 10 LOG OF THE RELATIVE ACCURACY; THIS IS ROUGHLY THE C NUMBER OF SIGNIFICANT FIGURES OF AGREEMENT BETWEEN THE TWO VALUES. C THIS QUANTITY IS MONITORED AND AVERR IS RETURNED AS THE AVERAGE C VALUE OF THE NUMBER OF SIGNIFICANT FIGURES OF AGREEMENT. C C WHEN FUNCTION AND GRADIENT COMPUTATIONS ARE CORRECT, ERR WILL C GENERALLY BE AT LEAST AS SMALL AS 10**(-T/2), ALTHOUGH IT CAN BE C MORE LIKE 10**(-T/4). GROSS BLUNDERS WILL USUALLY GIVE ERR A C VALUE VERY NEAR TO 1, BUT NOT ALWAYS. IF ALL IS WELL, AVERR WILL C USUALLY BE ABOUT T/2; BLUNDERS WILL OFTEN RESULT IN AVERR BEING C NEAR 0 OR 1. C C-----FINITE DIFFERENCE COMPUTATIONS C C FOR FIRST DERIVATIVES, SIMPLE FORWARD DIFFERENCES ARE USED. C TO ESTIMATE THE I-TH COMPONENT OF THE GRADIENT OF F, WE COMPUTE C C ( F(X + H*E[I]) - F(X) ) / H, C C WHERE H = EPS * ABS(X[I]). WHEN X[I] = 0, WE JUST CHOOSE H = EPS. C HERE EPS IS THE ROOT OF ETA, WHERE ETA DEFINES THE RELATIVE C MACHINE ACCURACY. THIS IS USED WHEN SDRVMD = CDIFF OR CTEST. C C WHEN SDRVMD = CTEST, MORE INFORMATION IS REQUIRED; THUS WE C ALSO COMPUTE F(X + SQRT(H)*E[I]). THIS MEANS THAT WHEN IN TEST C MODE, TWICE AS MANY FUNCTION EVALUATIONS ARE NEEDED. THIS IS C REQUIRED TO ELIMINATE SCALING EFFECTS IN THE ESTIMATE OF FIGURES C OF AGREEMENT. C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZEVAL. C C ZZESRT TO INITIALIZE FOR TESTING EACH FUNCTION. C ZZESET TO INITIALIZE CONTROL PARAMETERS. C ZZEDDF TO REDEFINE CODES FOR DERIVATIVE CALCULATIONS. C ZZEFDF TO REDEFINE CODES FOR FUNCTION EVALUATIONS. C ZZERDF TO REDEFINE CODES FOR RETURN CODES. C C ZZEGET TO RETURN FUNCTION/GRADIENT COUNTS AND TIME. C ZZECHK RETURNS THE ERROR VALUE IF IN TESTMODE. C C## S U B R O U T I N E S: C ZZSECS ...FOR FUNCTION TIMING. C ZZMPAR ...FOR MACHINE PARAMETERS. C ZZUFNC ...THE USER ROUTINE. C ZZFSCL ...PERFORMS SCALING. C C SQRT, MAX, ABS ...INTRINSIC FUNCTIONS. C LOG10, MIN, SIGN ...INTRINSIC FUNCTIONS. C C## P A R A M E T E R S: REAL ZERO, ONE, TWO, THREE C!!!! DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) REAL FOUR, FIVE, SIX, SEVEN C!!!! DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) REAL EIGHT, NINE, TEN C!!!! DOUBLE PRECISION EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 9D0, TEN = 10D0 ) REAL R11, R12, R13, R14 C!!!! DOUBLE PRECISION R11, R12, R13, R14 PARAMETER ( R11 = 11D0, R12 = 12D0, R13 = 13D0,R14 = 14D0) REAL R15, R16, R17, R18 C!!!! DOUBLE PRECISION R15, R16, R17, R18 PARAMETER ( R15 = 15D0, R16 = 16D0, R17 = 17D0,R18 = 18D0) REAL R19, R20, R25, R29 C!!!! DOUBLE PRECISION R19, R20, R25, R29 PARAMETER ( R19 = 19D0, R20 = 20D0, R25 = 25D0,R29 = 29D0) REAL R32, R36, R40, R42 C!!!! DOUBLE PRECISION R32, R36, R40, R42 PARAMETER ( R32 = 32D0, R36 = 36D0, R40 = 40D0,R42 = 42D0) REAL R45, R49 C!!!! DOUBLE PRECISION R45, R49 PARAMETER ( R45 = 45D0, R49 = 49D0 ) REAL R50, R56, R84, R90 C!!!! DOUBLE PRECISION R50, R56, R84, R90 PARAMETER ( R50 = 50D0, R56 = 56D0, R84 = 84D0,R90 = 90D0) REAL R100, R180, R200 C!!!! DOUBLE PRECISION R100, R180, R200 PARAMETER ( R100 = 100D0, R180 = 180D0, R200 = 200D0 ) REAL R256, R360, R400 C!!!! DOUBLE PRECISION R256, R360, R400 PARAMETER ( R256 = 256D0, R360 = 360D0, R400 = 400D0 ) REAL R600, R681, R991 C!!!! DOUBLE PRECISION R600, R681, R991 PARAMETER ( R600 = 600D0, R681 = 681D0, R991 = 991D0 ) REAL R1162, R2324 C!!!! DOUBLE PRECISION R1162, R2324 PARAMETER ( R1162 = 1162D0, R2324 = 2324D0 ) REAL R10000, R40000 C!!!! DOUBLE PRECISION R10000, R40000 PARAMETER ( R10000 = 10000D0, R40000 = 40000D0 ) INTEGER XEPS, XSMALL, XBIG PARAMETER ( XEPS = 1, XSMALL = 2, XBIG = 3 ) INTEGER REQF PARAMETER ( REQF = 2 ) C DEFINE THE DERIVATIVE CODES INTEGER CANAL, CDIFF, CTEST, CFIRST PARAMETER ( CANAL = 1, CDIFF = 2, CTEST = 3, CFIRST = 4 ) C DEFINE THE FUNCTION CODES INTEGER JUSTF, BOTH, JUSTG, NOOP PARAMETER ( JUSTF = 1, BOTH = 0, JUSTG = -1, NOOP = 2 ) C DEFINE THE RETURN CODES C THE RETURN CODES TO BE USED BY THE FUNCTION EVALUATION ROUTINE C TO INDICATE TO THE MINIMIZATION ROUTINE WHETHER OR NOT THE CALL C WAS SUCCESSFUL. INTEGER COK, CABORT, CLIMIT PARAMETER ( COK = 0, CABORT = -1, CLIMIT = -2 ) INTEGER CNOF, CNOG, CNOFG PARAMETER ( CNOF = -3, CNOG = -4, CNOFG = -5 ) C## L O C A L D E C L: LOGICAL TRF, TRG, FIRST, FONLY, GONLY, VALID, BAD, TRTEST, FCALL INTEGER IFNCT, FSCALE, IGRCT, SDRVMD, REMBAD INTEGER ITRUN, MAXFN, DERVMD, EXPENS, KK INTEGER CASE, CALLS, COUNT, INDEX, GCNT, DCNT INTEGER ZDCNT, ZINDEX, ZGCNT REAL FT, FV, FTIME, TT, SCALE, SERR, RH,ZERR,ZSERR C!!!! DOUBLE PRECISION FT, FV, FTIME, TT, SCALE, SERR, RH,ZERR,ZSERR REAL FVAL, FVAL2, ERR, ETA, EPS, H, ZZMPAR, TERR C!!!! DOUBLE PRECISION FVAL, FVAL2, ERR, ETA, EPS, H, ZZMPAR, TERR C-----DECLARATIONS FOR ENTRY POINT DUMMY ARGUMENTS. INTEGER DITRUN, FSCAL, MAXM, FNCT, GRCT, SEXPEN INTEGER DDERV, INDX, ITERAT INTEGER ANAL, DIFF, TEST, DOF, DOG, DOFG, NONE, TFIRST INTEGER SANAL, SDIFF, STEST, SDOF, SDOG, SDOFG, SNONE, SFIRST INTEGER OK, ABORT, LIMIT, NOF, NOG, NOFG INTEGER SOK, SABORT, SLIMIT, SNOF, SNOG, SNOFG LOGICAL DTRF, DTRG, DTRTST REAL TIME, ERROR, AVERR C!!!! DOUBLE PRECISION TIME, ERROR, AVERR C## S A V E: SAVE ITRUN, FSCALE, IFNCT, IGRCT, SERR, DCNT, EXPENS SAVE TRF, TRG, FTIME, SDRVMD, MAXFN, TRTEST SAVE FIRST, ERR, INDEX, GCNT, EPS, ETA, FCALL SAVE ANAL, DIFF, TEST, TFIRST, DOF, DOG, DOFG, NONE SAVE OK, ABORT, LIMIT, NOF, NOG, NOFG C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA FIRST /.TRUE./, FCALL/.TRUE./ DATA TRF, TRG, TRTEST / 3 * .FALSE. /, ITRUN / 6 / DATA SDRVMD/CANAL/, FSCALE/0/, MAXFN/0/ DATA ANAL/CANAL/, DIFF/ CDIFF/, TEST/ CTEST/, TFIRST/CFIRST/ DATA DOF/JUSTF/, DOG/ JUSTG/, DOFG/ BOTH/, NONE/ NOOP/ DATA OK/ COK/, ABORT/CABORT/, LIMIT/CLIMIT/ DATA NOF/ CNOF/, NOG/ CNOG/, NOFG/ CNOFG/ C## E X E C U T I O N C## E X E C U T I O N C-----STATEMENT FUNCTION. BAD() = CASE .EQ. ABORT .OR. CASE .EQ. LIMIT .OR. CASE .EQ. NOF - .OR. CASE .EQ. NOG .OR. CASE .EQ. NOFG C-----FIRST TEST FOR NOOP CALL. IF ( TRF .OR. TRG ) WRITE ( ITRUN,99992 )INDIC,DOF,DOG,DOFG VALID = INDIC .EQ. DOF .OR. INDIC .EQ. DOG .OR. INDIC .EQ. DOFG IF ( .NOT. VALID ) THEN CALL ZZUFNC ( INDIC, N, X, F, G, IW, RW, DW ) GOTO 90500 ENDIF IF ( MAXFN .GT. 0 .AND. IFNCT .GE. MAXFN ) THEN GOTO 91000 ENDIF DERVMD = SDRVMD IF ( FIRST ) THEN FIRST = .FALSE. ETA = ZZMPAR(XEPS) EPS = SQRT (ETA) ENDIF IF ( FCALL ) THEN IF ( DERVMD .EQ. TFIRST ) DERVMD = TEST FCALL = .FALSE. ELSE IF ( DERVMD .EQ. TFIRST ) DERVMD = ANAL ENDIF FONLY = INDIC .EQ. DOF GONLY = INDIC .EQ. DOG CALL ZZSECS (TT) FTIME = FTIME - TT IF ( .NOT. GONLY ) IFNCT = IFNCT + 1 IF ( .NOT. FONLY ) IGRCT = IGRCT + 1 C-----FIRST COMPUTE REQUIRED FUNCTION AND/OR GRADIENT VALUES. C REPEAT IF REQUIRED TO SIMULATE EXPENSIVE CALL. ZERR = ERR ZSERR = SERR ZDCNT = DCNT ZINDEX = INDEX ZGCNT = GCNT REMBAD = OK DO 9900 KK = 1, EXPENS CASE = INDIC C NO OF EXTRA CALLS TO USER ROUTINE WHICH WILL BE NEEDED. IF ( DERVMD .EQ. ANAL .OR. FONLY ) THEN CALLS = 0 ELSE CALLS = N ENDIF C FORCE FUNCTION EVALUATION IF REQUIRED FOR SCALING. IF ( FSCALE .GE. REQF .AND. GONLY ) THEN CASE = DOFG ENDIF C FIRST COMPUTE F(X) --- AND G(X) IF NEEDED. CALL ZZUFNC ( CASE, N, X, FVAL, G, IW, RW, DW ) IF ( BAD() ) THEN REMBAD = CASE GOTO 9900 ENDIF IF ( INDIC .NE. DOG ) THEN FT = FVAL ENDIF C -----DO EXTRA CALLS, IF REQUIRED. C AFTER FIRST CALL, FUNCTION VALUES ONLY. DO 1500 COUNT = 1, CALLS TT = X(COUNT) IF ( TT .EQ. ZERO ) THEN H = EPS ELSE H = EPS * ABS( TT ) ENDIF X(COUNT) = TT + H C COMPUTE F( X + H * E[COUNT] ) CASE = DOF CALL ZZUFNC ( CASE, N, X, FVAL, G, IW, RW, DW ) IF ( BAD() ) THEN REMBAD = CASE GOTO 9900 ENDIF X(COUNT) = TT IF ( DERVMD .EQ. TEST ) THEN C ---IF TRACE REQUESTED, PRINT ESTIMATED AND ANALYTIC VALUES. IF ( TRTEST ) WRITE(ITRUN,99995) - G(COUNT),COUNT,(FVAL-FT)/H C ---ESTIMATE ERROR, AND LEAVE COMPUTED C ANALYTIC GRADIENTS IN G. USE F AT C X + A * E[COUNT], FOR A = H AND SQRT(H). RH = SQRT(H) X(COUNT) = TT + RH CASE = DOF CALL ZZUFNC ( CASE, N, X, FVAL2, G, IW, RW, DW ) IF ( BAD() ) THEN REMBAD = CASE GOTO 9900 ENDIF X(COUNT) = TT IF ( ABS(FVAL2-FT) .GT. R100*ETA*ABS(FT) ) THEN TERR = (FVAL-FT - H*G(COUNT))/ - (FVAL2-FT - RH*G(COUNT)) IF (TT .GT. ONE) TERR = TERR / TT C TRUNCATE TO INTERVAL [ETA,1]. TERR = MAX( MIN(ONE,ABS(TERR)), ETA ) C ESTIMATE NUMBER OF FIGURES OF AGREEMENT. ZSERR = ZSERR - LOG10 (TERR) ZDCNT = ZDCNT + 1 IF (TRTEST) WRITE(ITRUN,99994) TERR,-LOG10(TERR) IF ( TERR .GT. ABS(ZERR) ) THEN ZINDEX = COUNT ZGCNT = IGRCT ZERR = SIGN (TERR, ZERR) ENDIF ELSE C FLAG CASE WHERE THERE IS EXCESSIVE CANCELLATION. ZERR = - ABS(ZERR) IF (TRTEST) WRITE(ITRUN,99993) ENDIF ELSE C ---ESTIMATE GRADIENTS USING FORWARD FINITE DIFFERENCE C FORMULAE AND STORE IN G. G(COUNT) = ( FVAL - FT ) / H ENDIF 1500 CONTINUE C -----DO SCALING: DEFINE FV AND SCALE. NOTE THAT IN SOME C INSTANCES THIS MAY REQUIRE AN EXTRA CALL TO GET THE C FUNCTION VALUE WHEN INDIC = DOG; THIS WAS DONE IN C THE CALLS ABOVE. IF ( FSCALE .NE. 0 ) THEN CALL ZZFSCL( FT, FV, SCALE, FSCALE, FONLY, GONLY ) ELSE FV = FT SCALE = ONE ENDIF C -----NOW REVISE THE FUNCTION AND GRADIENT AS NECESSARY. IF ( .NOT. GONLY ) THEN F = FV ENDIF IF ( .NOT. FONLY .AND. SCALE .NE. ONE ) THEN CALL ZZSCAL ( N, SCALE, G, 1 ) ENDIF 9900 CONTINUE ERR = ZERR INDEX = ZINDEX GCNT = ZGCNT DCNT = ZDCNT SERR = ZSERR INDIC = REMBAD GOTO 90000 C## E N T R Y ZZESRT: ENTRY ZZESRT ( FSCAL, DDERV, MAXM, SEXPEN ) FCALL = .TRUE. FSCALE = FSCAL SDRVMD = DDERV MAXFN = MAXM EXPENS = SEXPEN IFNCT = 0 IGRCT = 0 FTIME = ZERO IF ( SDRVMD .EQ. TEST .OR. SDRVMD .EQ. TFIRST ) THEN ERR = ZERO SERR = ZERO DCNT = 0 INDEX = 0 GCNT = 0 ENDIF RETURN C## E N T R Y ZZESET: ENTRY ZZESET ( DTRF, DTRG, DTRTST, DITRUN ) TRF = DTRF TRG = DTRG TRTEST = DTRTST ITRUN = DITRUN RETURN C## E N T R Y ZZEDDF: ENTRY ZZEDDF ( SANAL, SDIFF, STEST, SFIRST ) ANAL = SANAL DIFF = SDIFF TEST = STEST TFIRST = SFIRST RETURN C## E N T R Y ZZEFDF: ENTRY ZZEFDF ( SDOF, SDOG, SDOFG, SNONE ) DOF = SDOF DOG = SDOG DOFG = SDOFG NONE = SNONE RETURN C## E N T R Y ZZERDF: ENTRY ZZERDF(SOK,SABORT,SLIMIT,SNOF,SNOG,SNOFG) OK = SOK ABORT = SABORT LIMIT = SLIMIT NOF = SNOF NOG = SNOG NOFG = SNOFG RETURN C## E N T R Y ZZEGET: ENTRY ZZEGET ( FNCT, GRCT, TIME ) FNCT = IFNCT GRCT = IGRCT TIME = FTIME RETURN C## E N T R Y ZZECHK: ENTRY ZZECHK ( ERROR, AVERR, INDX, ITERAT ) ERROR = ERR INDX = INDEX ITERAT = GCNT AVERR = SERR / DCNT RETURN C## E X I T 90000 CALL ZZSECS (TT) FTIME = FTIME + TT IF ( TRF .AND. .NOT. BAD() ) WRITE (ITRUN,99998) F IF ( TRG .AND. .NOT. BAD() ) THEN WRITE (ITRUN,99997) WRITE (ITRUN,99996) G ENDIF 90500 RETURN C ALTERNATE RETURN IF MAXIMUM NUMBER OF FUNCTION EVALUATIONS C EXCEEDED. 91000 IF ( TRF .OR. TRG ) WRITE ( ITRUN,99999 ) INDIC = LIMIT RETURN C## F O R M A T S: 99992 FORMAT( ' [EVAL] INDIC (F,G,FG)=',4I3) 99993 FORMAT( ' EXCESSIVE ERROR IN GRADIENT ESTIMATION.') 99994 FORMAT( ' ERROR ESTIMATE IN GRADIENT ESTIMATION: ', G15.7/ - ' ESTIMATED FIGURES OF AGREEMENT: ', G9.2 ) 99995 FORMAT( ' ANALYTIC GRADIENT ', G22.15, ' (COMPONENT ',I3,')'/ - ' ESTIMATED DERIVATIVE', G22.15 ) 99996 FORMAT( ' ', 5 G15.8 ) 99997 FORMAT( ' (ZZEVAL) GRADIENT = ' ) 99998 FORMAT( ' (ZZEVAL) FUNCTION = ', G26.16 ) 99999 FORMAT(/' THE NUMBER OF FUNCTION EVALUATIONS ALLOWED HAS ', - 'BEEN EXCEEDED.') C## E N D OF ZZEVAL. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> innrsg.f DOUBLE PRECISION FUNCTION ZZINNR ( N, U, V, NRMFLG, IW, RW, DW ) C## A R G U M E N T S: INTEGER N, IW(*) LOGICAL NRMFLG REAL U(N), V(N) C!!!! DOUBLE PRECISION U(N), V(N) DOUBLE PRECISION DW(*) REAL RW(*) C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: INNR.F,V 2.1 91/11/20 10:46:59 BUCKLEY EXP $ C>RCS $LOG: INNR.F,V $ C>RCS REVISION 2.1 91/11/20 10:46:59 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 2.0 90/07/31 11:12:32 BUCKLEY C>RCS ADDED REVISED BLAS. . C>RCS C>RCS REVISION 1.9 89/06/30 13:11:47 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3 89/05/18 12:40:14 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:49:22 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM.. C>RCS C>RCS REVISION 1.1 89/01/07 14:35:52 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE COMPUTES THE NORMAL EUCLIDEAN INNER PRODUCT C OF THE VECTORS U AND V. C C *** NOTE THAT THE RESULT PASSED BACK IS C C *ALWAYS* DOUBLE PRECISION. C C IF NRMFLG IS SET ON ENTRY, THEN THE 2-NORM OF U IS COMPUTED C BY CALLING ZZNRM2 TO DO THE COMPUTATION WITHOUT OVERFLOW. IN C THIS CASE, V IS IGNORED AND THE NORM IS COMPUTED IN SINGLE OR C DOUBLE PRECISION AS APPROPRIATE. C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZINNR C## S U B R O U T I N E S: ZZNRM2 FOR NO OVERFLOW 2-NORMS C DBLE ...INTRINSIC C C## P A R A M E T E R S: REAL ZERO, ONE, TWO, THREE C!!!! DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) REAL FOUR, FIVE, SIX, SEVEN C!!!! DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) REAL EIGHT, NINE, TEN C!!!! DOUBLE PRECISION EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 9D0, TEN = 10D0 ) C## L O C A L D E C L: INTEGER I REAL ZZNRM2 C!!!! DOUBLE PRECISION ZZNRM2 C## S A V E: NONE SELECTED. C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NONE ARE SET. C## E X E C U T I O N C## E X E C U T I O N IF ( NRMFLG ) THEN ZZINNR = DBLE( ZZNRM2( N, U ) ) ELSE ZZINNR = ZERO DO 500 I = 1,N ZZINNR = ZZINNR + DBLE(U(I)) * DBLE(V(I)) 500 CONTINUE ENDIF C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZINNR. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> nrm2sg.f REAL FUNCTION ZZNRM2 ( N, V ) C!!!! DOUBLE PRECISION FUNCTION ZZNRM2 ( N, V ) C## A R G U M E N T S: INTEGER N REAL V(N) C!!!! DOUBLE PRECISION V(N) C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NOT REQUIRED. C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C SYSTEM DEPENDENCE: SYSTEM ROUTINE FOR ####. C C SYSTEM DEPENDENCE: NONE C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: REQUIRED (SEE CONVRT) C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C>RCS $HEADER: NRM2.F,V 2.1 91/11/20 10:47:00 BUCKLEY EXP $ C>RCS $LOG: NRM2.F,V $ C>RCS REVISION 2.1 91/11/20 10:47:00 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 2.0 90/07/31 11:16:18 BUCKLEY C>RCS ADDED REVISED BLAS. C>RCS C>RCS REVISION 1.9.1.1 89/06/30 15:28:16 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.9 89/06/30 13:11:48 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3 89/05/18 12:40:14 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:49:25 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM.. C>RCS C>RCS REVISION 1.1 89/01/07 14:35:57 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS COMPUTES THE 2-NORM (I.E. THE EUCLIDEAN NORM) OF THE C VECTOR V OF LENGTH N, WITH DUE REGARD TO AVOIDING OVERFLOW C AND UNDERFLOW. C C THE ROUTINE IS BASED ON SNRM2 FROM THE BLAS (IN LINPACK), C BUT THIS VERSION IS FOR CONSECUTIVELY STORED VECTORS ONLY, C AND IT USES MACHINE DEPENDENT CONSTANTS TAKEN FROM ZZMPAR. C THEREFORE IT MAKES NONE OF THE ASSUMPTIONS USED IN SNRM2, AND C IS IN FACT LESS MACHINE DEPENDENT. C C SNRM2 WAS WRITTEN IN FORTRAN 66, WHEREAS THIS VERSION IS WRITTEN C IN FORTRAN 77. THE USE OF BLOCK IF STATEMENTS MAKES THIS VERSION C MUCH MORE READABLE THAN SNRM2. C C THE MACHINE CONSTANTS MIN (THE SMALLEST MAGNITUDE), MAX (THE C LARGEST MAGNITUDE), AND PREC (THE PRECISION) ARE USED TO C CALCULATE THE CONSTANTS CUTLO AND CUTHI. THREE DIFFERENT CASES C MUST BE CONSIDERED WHEN CALCULATING THE NORM: C C (1) ALL COMPONENTS OF V ARE BELOW CUTLO. C C TO AVOID UNDERFLOW, EACH COMPONENT IS DIVIDED BY C SQRT(MIN)/N AND THEN THE REGULAR EUCLIDEAN NORM C OF THIS MODIFIED VECTOR IS CALCULATED. THIS RESULT C IS THEN MULTIPLIED BY SQRT(MIN)/N IN ORDER C TO GET THE CORRECT VALUE FOR THE NORM. C C (2) ONE OR MORE COMPONENTS ARE GREATER THAN CUTHI. C C TO AVOID OVERFLOW, THE SAME METHOD AS IN CASE (1) C IS USED WITH A SCALING FACTOR OF SQRT(MAX)*N . C C (3) ALL COMPONENTS ARE LESS THAN CUTHI, WITH AT LEAST C ONE COMPONENT GREATER THAN CUTLO. C C THE REGULAR FORMULA FOR THE EUCLIDEAN NORM IS C USED. C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZZZZZ. C C ONLY THE NATURAL ENTRY POINT ZZNRM2 C C## S U B R O U T I N E S: NONE ARE CALLED. C C ZZMPAR TO OBTAIN MACHINE DEPENDENT CONSTANTS. C C SQRT, ABS, REAL(DBLE) ... INTRINSIC C C## P A R A M E T E R S: NONE ARE DEFINED. INTEGER NULL, SMALL, NORMAL, LARGE PARAMETER ( NULL = 0, SMALL = 1, NORMAL = 2, LARGE = 2 ) REAL ZERO, ONE, TWO, THREE C!!!! DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) REAL FOUR, FIVE, SIX, SEVEN C!!!! DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) REAL EIGHT, NINE, TEN C!!!! DOUBLE PRECISION EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 9D0, TEN = 10D0 ) INTEGER XEPS, XSMALL, XBIG PARAMETER ( XEPS = 1, XSMALL = 2, XBIG = 3 ) C## L O C A L D E C L: NONE ARE DEFINED. INTEGER I, CASE LOGICAL FIRST REAL CUTLO, CUTHI, MAX, SUM, ZZMPAR, RD, XMAX C!!!! DOUBLE PRECISION CUTLO, CUTHI, MAX, SUM, ZZMPAR, RD, XMAX C## S A V E: NONE SELECTED. SAVE FIRST, MAX C## E Q U I V A L E N C E S: NONE ARE DEFINED. C C THERE ARE NO EQUIVALENCES. C C## C O M M O N: NONE IS DEFINED. C C THERE ARE NO COMMON BLOCKS. C C## D A T A: NONE ARE SET. DATA FIRST / .TRUE. / C## E X E C U T I O N C## E X E C U T I O N C----DEFINE A STATEMENT FUNCTION. RD(I) = REAL (I) C!!!! RD(I) = DBLE (I) C-----GET MACHINE LIMITS. IF ( FIRST ) THEN CUTLO = SQRT ( ZZMPAR(XSMALL) / ZZMPAR(XEPS) ) MAX = ZZMPAR(XBIG) FIRST = .FALSE. ENDIF C-----DO NORM. IF ( N .LE. 0 ) THEN ZZNRM2 = ZERO GOTO 90000 ENDIF CUTHI = SQRT(MAX) / RD(N) SUM = ZERO CASE = NULL C---- EVALUATE THE NORM BY ACCUMULATING A SCALED SUM OF SQUARES C AND ADJUSTING THE SCALING AS NUMBERS OF INCREASING LARGE C MAGNITUDE ARE FOUND. DO 100 I=1,N IF ( CASE .EQ. NORMAL ) THEN IF ( ABS(V(I)) .LT. CUTHI ) THEN SUM = SUM + V(I)**2 ELSE CASE = LARGE XMAX = ABS(V(I)) SUM = ONE + (SUM/V(I))/V(I) ENDIF ELSE IF ( CASE .EQ. SMALL ) THEN IF ( ABS(V(I)) .LE. CUTLO ) THEN IF ( ABS(V(I)) .LE. XMAX ) THEN SUM = SUM + (V(I)/XMAX) **2 ELSE SUM = ONE + (XMAX/V(I)) **2 XMAX = ABS(V(I)) ENDIF ELSE IF ( ABS(V(I)) .GE. CUTHI ) THEN CASE = LARGE XMAX = ABS(V(I)) SUM = ONE + (SUM/V(I))/V(I) ELSE CASE = NORMAL SUM = (SUM*XMAX)*XMAX + V(I)**2 ENDIF ELSE IF ( CASE .EQ. LARGE ) THEN IF ( ABS(V(I)) .LE. XMAX ) THEN SUM = SUM + (V(I)/XMAX)**2 ELSE SUM = ONE + SUM * (XMAX/V(I))**2 XMAX = ABS(V(I)) ENDIF ELSE IF ( CASE .EQ. NULL ) THEN IF ( ABS(V(I)) .EQ. ZERO ) THEN C JUST FALL THROUGH... ELSE IF ( ABS(V(I)) .LE. CUTLO ) THEN CASE = SMALL XMAX = ABS (V(I)) SUM = ONE ELSE IF ( ABS(V(I)) .GE. CUTHI ) THEN CASE = LARGE XMAX = ABS (V(I)) SUM = ONE ELSE CASE = NORMAL SUM = V(I)**2 ENDIF ENDIF 100 CONTINUE IF ( CASE .EQ. NORMAL .OR. CASE .EQ. NULL ) THEN ZZNRM2 = SQRT(SUM) ELSE ZZNRM2 = XMAX * SQRT(SUM) ENDIF C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C C THERE ARE NO FORMATS USED. C C## E N D OF ZZNRM2. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> prntsg.f SUBROUTINE ZZPRNT ( N, X, F, G, NRMG, INCR ) C## A R G U M E N T S: INTEGER N, INCR REAL F, X(N), G(N), NRMG C!!!! DOUBLE PRECISION F, X(N), G(N), NRMG C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: PRNT.F,V 2.2 91/12/16 12:12:48 BUCKLEY EXP $ C>RCS $LOG: PRNT.F,V $ C>RCS REVISION 2.2 91/12/16 12:12:48 BUCKLEY C>RCS MINOR FIX FOR TOMS. C>RCS C>RCS REVISION 2.1 91/11/20 10:47:02 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 2.0 90/07/31 11:12:40 BUCKLEY C>RCS ADDED REVISED BLAS. C>RCS C>RCS REVISION 1.9 89/06/30 13:11:49 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.4 89/05/21 12:44:25 BUCKLEY C>RCS REVISED FOR COPY C>RCS C>RCS REVISION 1.3 89/05/18 12:40:15 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:49:27 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM.. C>RCS C>RCS REVISION 1.1 89/01/07 14:36:05 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE PRINTS (OPTIONALLY) A POINT X , THE VALUE F OF C SOME FUNCTION AT THE POINT X, ALONG WITH THE NORM OF THE GRADIENT C AT THAT POINT, AND (OPTIONALLY) THE VALUE OF THE GRADIENT C G AT THE POINT X. C C TWO OUTPUT UNITS MAY BE SIMULTANEOUSLY DEFINED; EITHER OR BOTH C MAY BE USED. THE PRINT INTERVAL MAY BE DEFINED INDEPENDENTLY FOR C EACH. IF FORCE IS SET, IT APPLIES TO BOTH, IF BOTH ARE DEFINED. C THE DESCRIPTION BELOW ONLY APPLIES TO ONE UNIT. IDENTICAL COMMENTS C APPLY TO THE OTHER. OUTPUT TO A UNIT MAY BE TURNED OFF BY SETTING C THE LEVEL TO 0, OR THE UNIT NUMBER TO 0. ONLY ONE CALL IS NEEDED C AT EACH ITERATE; PRINTING WILL BE DONE ON EITHER OR BOTH UNITS, C AS NEEDED. C C SOME OF THE CONTROL OF PRINT IS THROUGH VARIABLES WHICH ARE C SET THROUGH AN ENTRY POINT CALL TO ZZPSET. THESE ARE DECLARED C AS SAVE VARIABLES. ZZPSET SHOULD BE CALLED TO INITIALIZE ZZPRNT C EACH TIME A FUNCTION IS TO BE MINIMIZED. THE DESCRIPTION OF THE C CONTROL FOLLOWS. C C---DESCRIPTION OF PARAMETERS. C C N THE DIMENSION OF THE PROBLEM. C X THE CURRENT POINT. C F THE FUNCTION VALUE AT X. C G THE GRADIENT VALUE AT X, IF NEEDED. C NRMG THE NORM OF THE GRADIENT. C INCR SEE (5) BELOW. C C---NOTE: 1. CONTROL IS UNDER PLEV1. (PLEV MEANS PRINT LEVEL) C SEE ENTRY POINT ZZP1ST BELOW. C C LET IP = ABS(PLEV1). THEN IF C C PLEV1 = 0 THERE IS NO OUTPUT. C C PLEV1 < 0 PRINT EVERY IP-TH ITERATION: C C THE ITERATION NUMBER IN ITCT, C THE FUNCTION VALUE IN F, C THE NO. OF FUNC EVALUATIONS IN IFNCT. C THE NO. OF GRAD EVALUATIONS IN IGRCT. C C THESE COUNTS ARE OBTAINED THROUGH A CALL C TO THE ENTRY POINT ZZEGET IN ZZEVAL. C C PLEV1 > 0 PRINT EVERY IP-TH ITERATION, AS FOR C PLEV1 < 0, BUT ALSO PRINT: C C THE POINT X, AND C THE GRADIENT G (SEE POINT 2 BELOW). C C 2. SETTING GRAD1 = FALSE WILL ENSURE THAT THE GRADIENTS ARE C NEVER PRINTED, REGARDLESS OF THE VALUE OF PLEV1. THIS C WOULD BE APPROPRIATE WHEN GRADIENTS ARE NOT AVAILABLE OR C TO PRINT X WITHOUT PRINTING G WHEN PLEV1 > 0. THE C SAME COMMENTS APPLY TO SUPPRESSING X WITH POINT1=FALSE. C C 3. PRPT1 RECORDS THE NUMBER OF THE NEXT ITERATION AT WHICH C TO PRINT. WHEN ZZP1ST IS CALLED, THE ITERATION COUNT C ITCT IS INITIALIZED (TO -1) AND PRPT1 IS SET TO 0; THIS C IS WHY ZZP1ST MUST BE CALLED BEFORE EACH FUNCTION IS C MINIMIZED. ON ENTRY TO ZZPRNT, ITCT IS FIRST INCREMENTED C BY 1. THEN, IF ITCT IS LESS THAN PRPT1, NO ACTION TAKES C PLACE AT ALL. IF ON THE OTHER HAND, ITCT = PRPT1, THEN C PRINTING OF THE APPROPRIATE INFORMATION IS DONE, AND C THEN PRPT1 IS ADVANCED BY ABS(PLEV1) TO MARK THE POINT C AT WHICH NEXT TO PRINT. IF ON ENTRY THE VALUE OF ITCT C IS BEYOND THAT OF PRPT1, PRPT1 IS REPEATEDLY INCREMENTED BY C ABS(PLEV1) UNTIL ONE OF THE FIRST TWO CASES OCCURS. OF C COURSE THIS IS NOT SUPPOSED TO HAPPEN IF ZZP1ST WAS C CALLED TO INITIALIZE ZZPRNT. C C 4. ITCT IS INCREMENTED INTERNALLY, BUT THE COUNTING OF C IFNCT AND IGRCT WILL BE DONE BY ZZEVAL; THE VALUES ARE C OBTAINED BY A CALL TO THE ENTRY POINT ZZEGET. C C 5. SETTING INCR CAN BE USED TO FORCE PRINTING, REGARDLESS C OF THE VALUES OF PRPT1 AND ITCT. THIS IS USEFUL FOR C FORCING PRINTING OF THE FINAL POINT REACHED. IN FACT, C INCR DEFINES THE AMOUNT BY WHICH TO INCREMENT THE INTERNAL C ITERATION COUNTER OF ZZPRNT. THUS, NORMALLY ZZPRNT WILL C BE CALLED WITH INCR = 1. TO FORCE PRINTING, ZZPRNT MAY BE C CALLED WITH INCR = 0; THE POINT IS PRINTED BUT THE ITERA- C TION COUNTER IS NOT ADVANCED. FINALLY, IF ONE WISHES TO C INSIST THAT THE ITERATION COUNTER BE UPDATED CORRECTLY AND C THAT THE POINT BE PRINTED REGARDLESS OF THE VALUE OF PRPT1, C ONE MAY CALL ZZPRNT WITH INCR = -1; BECAUSE INCR <=0, THE C PRINT OF THE POINT WILL BE FORCED, AND IT IS IN FACT C ABS(INCR) THAT IS USED TO UPDATE THE ITERATION COUNT. THIS C PARTICULAR CASE IS USEFUL AT THE FINAL POINT. C C NOTE THAT PRPT1 IS STILL ADVANCED, BUT ONLY IF APPROPRIATE, C I.E. IF PRINTING WOULD HAVE BEEN DONE ANYWAY, AS EXPLAINED C IN 2. C C ALSO, WHEN FORCING IS DONE, THE ROUTINE IS CAREFUL NOT C TO REPEAT A PRINTING REQUEST. IF THE OUTPUT UNIT OR C THE STATUS OF GRAD1 OR THE ITERATION COUNT ITCT IS C DIFFERENT, THEN THE PRINTING IS DONE; OTHERWISE IT C IS CONSIDERED A REPEAT OF A PREVIOUS REQUEST AND IT C IS IGNORED. C C 6. PRTIME IS USED FOR ACCUMULATING THE TIME SPENT IN THE C PRINT ROUTINE. IT IS INITIALIZED TO ZERO AT THE CALL C TO ZZP1ST, AND EACH CALL TO ZZPRNT INCREMENTS PRTIME BY C THE AMOUNT OF TIME SPENT IN THE ROUTINE. C C---ALSO AVAILABLE THROUGH ZZPGET (TIME, ITER). C C THE USER MAY CALL ZZPGET AT ANY TIME TO GET THE AMOUNT OF TIME C SPENT IN THE PRINT ROUTINE AND THE CURRENT ITERATION COUNT. C THESE ARE, RESP., THE ARGUMENTS ITER AND TIME. C C## E N T R Y P O I N T S: C C ZZPRNT ...THE NATURAL ENTRY. C ZZP1ST ...TO INITIALIZE CONTROL VARIABLES FOR FIRST UNIT. C ZZP2ST ...TO INITIALIZE CONTROL VARIABLES FOR SECOND UNIT. C ZZPGET ...TO RETURN ITERATION COUNT AND TIME. C C## S U B R O U T I N E S: C C ABS ...INTRINSIC FUNCTION. C ZZSECS ...FOR PRINT TIMING. C ZZEGET ...ENTRY TO ZZEVAL FOR FUNCTION/GRADIENT COUNTS. C C## P A R A M E T E R S: REAL ZERO, ONE, TWO, THREE C!!!! DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) REAL FOUR, FIVE, SIX, SEVEN C!!!! DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) REAL EIGHT, NINE, TEN C!!!! DOUBLE PRECISION EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 9D0, TEN = 10D0 ) C## L O C A L D E C L: INTEGER IFNCT, IGRCT, ITCT, COPYUN INTEGER PRPT1, PLEV1, UNIT1, LSTIT1, LSTUN1 INTEGER PRPT2, PLEV2, UNIT2, LSTIT2, LSTUN2 LOGICAL GRAD1, LSTGR1, POINT1, LSTPT1, COPY LOGICAL GRAD2, LSTGR2, POINT2, LSTPT2, FORCE, GOT REAL SECS, PRTIME, DTIME C!!!! DOUBLE PRECISION SECS, PRTIME, DTIME C-----DECLARATIONS FOR ENTRY POINT DUMMY ARGUMENTS. LOGICAL DGRAD1, DPINT1, DGRAD2, DPINT2, CP INTEGER DPRUN1, DPRNT1, DPRUN2, DPRNT2, ITER, CU REAL TIME C!!!! DOUBLE PRECISION TIME C## S A V E: SAVE PRTIME, ITCT, COPY, COPYUN SAVE PRPT1, GRAD1, PLEV1, UNIT1, POINT1 SAVE PRPT2, GRAD2, PLEV2, UNIT2, POINT2 SAVE LSTIT1, LSTUN1, LSTGR1, LSTPT1 SAVE LSTIT2, LSTUN2, LSTGR2, LSTPT2 C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA PLEV1/0/, PLEV2/0/, UNIT1/6/, UNIT2/0/ DATA COPY/.FALSE./, COPYUN/6/ C## E X E C U T I O N C## E X E C U T I O N FORCE = INCR .LE. 0 ITCT = ITCT + ABS(INCR) CALL ZZSECS (SECS) PRTIME = PRTIME - SECS GOT = .FALSE. IF ( FORCE .AND. ( ITCT .EQ. LSTIT1 ) - .AND. ( UNIT1 .EQ. LSTUN1 ) - .AND. ( POINT1 .EQV. LSTPT1 ) - .AND. ( GRAD1 .EQV. LSTGR1 ) ) THEN C DON'T REPEAT AN EARLIER REQUEST. GOTO 2000 ENDIF 100 IF ( PLEV1 .NE. 0 .AND. ITCT .GT. PRPT1 ) THEN PRPT1 = PRPT1 + ABS(PLEV1) GOTO 100 ENDIF IF ( (UNIT1 .NE. 0 ) .AND. - (PLEV1 .NE. 0 ) .AND. - (FORCE .OR. (ITCT .EQ. PRPT1)) ) THEN C -----SAVE INFORMATION DEFINING THIS PRINT REQUEST. LSTIT1 = ITCT LSTUN1 = UNIT1 LSTGR1 = GRAD1 LSTPT1 = POINT1 C ------PRINT ITERATION NUMBER, FUNCTION VALUE, NORM OF G, AND C NUMBER OF FUNCTION/GRADIENT EVALUATIONS. CALL ZZEGET ( IFNCT, IGRCT, DTIME ) GOT = .TRUE. WRITE ( UNIT1, 99999 ) ITCT,F,IFNCT,NRMG,IGRCT,DTIME C ------IF PLEV1 > 0 , ALSO PRINT X AND G. IF ( PLEV1 .GT. 0 ) THEN IF ( POINT1) THEN WRITE (UNIT1,99998) X ENDIF IF ( GRAD1 ) THEN WRITE (UNIT1,99997) G ENDIF ENDIF C ------UPDATE COUNTER. IF (ITCT .EQ. PRPT1) PRPT1 = PRPT1 + ABS(PLEV1) ENDIF 2000 IF ( FORCE .AND. ( ITCT .EQ. LSTIT2 ) - .AND. ( UNIT2 .EQ. LSTUN2 ) - .AND. ( POINT2 .EQV. LSTPT2 ) - .AND. ( GRAD2 .EQV. LSTGR2 ) ) THEN C DON'T REPEAT AN EARLIER REQUEST. GOTO 4000 ENDIF 2200 IF ( PLEV2 .NE. 0 .AND. ITCT .GT. PRPT2 ) THEN PRPT2 = PRPT2 + ABS(PLEV2) GOTO 2200 ENDIF IF ( (UNIT2 .NE. 0 ) .AND. - (PLEV2 .NE. 0 ) .AND. - (FORCE .OR. (ITCT .EQ. PRPT2)) ) THEN C -----SAVE INFORMATION DEFINING THIS PRINT REQUEST. LSTIT2 = ITCT LSTUN2 = UNIT2 LSTGR2 = GRAD2 LSTPT2 = POINT2 C ------PRINT ITERATION NUMBER, FUNCTION VALUE, NORM OF G, AND C NUMBER OF FUNCTION/GRADIENT EVALUATIONS. IF ( .NOT. GOT ) CALL ZZEGET ( IFNCT, IGRCT, DTIME ) WRITE ( UNIT2, 99989 ) ITCT,F,IFNCT,NRMG IF ( COPY ) WRITE ( COPYUN, 99989 ) ITCT,F,IFNCT,NRMG C ------IF PLEV2 > 0 , ALSO PRINT X AND G. IF ( PLEV2 .GT. 0 ) THEN IF ( POINT2) THEN WRITE (UNIT2,99988) X IF (COPY) WRITE (COPYUN,99988) X ENDIF IF ( GRAD2 ) THEN WRITE (UNIT2,99987) G IF (COPY) WRITE (COPYUN,99987) G ENDIF ENDIF C ------UPDATE COUNTER. IF (ITCT .EQ. PRPT2) PRPT2 = PRPT2 + ABS(PLEV2) ENDIF 4000 GOTO 90000 C## E N T R Y ZZP1ST: ENTRY ZZP1ST ( DPRUN1, DGRAD1, DPINT1, DPRNT1 ) UNIT1 = DPRUN1 GRAD1 = DGRAD1 POINT1 = DPINT1 PLEV1 = DPRNT1 PRPT1 = 0 ITCT = -1 LSTIT1 = -2 LSTUN1 = 0 LSTPT1 = -1 LSTGR1 = -1 PRTIME = ZERO RETURN C## E N T R Y ZZP2ST: ENTRY ZZP2ST (DPRUN2,DGRAD2,DPINT2,DPRNT2,CP,CU ) UNIT2 = DPRUN2 GRAD2 = DGRAD2 POINT2 = DPINT2 PLEV2 = DPRNT2 COPY = CP COPYUN = CU PRPT2 = 0 ITCT = -1 PRTIME = ZERO RETURN C## E N T R Y ZZPGET: ENTRY ZZPGET ( TIME, ITER ) TIME = PRTIME ITER = ITCT RETURN C## E X I T 90000 CALL ZZSECS (SECS) PRTIME = PRTIME + SECS 91000 RETURN C## F O R M A T S: 99987 FORMAT(' GRAD: ', 7G9.2 / (1X,8G9.2) ) 99988 FORMAT(' POINT X:', 7G9.2 / (1X,8G9.2) ) 99989 FORMAT(' PT #',I3,'; F=',G15.8,'(#',I3,') !!G!!=',E7.2) 99997 FORMAT(' THE GRADIENT AT THIS POINT IS ', 3G15.8 / (1X,5G15.8) ) 99998 FORMAT(' THE VARIABLES HAVE THE CURRENT VALUES GIVEN BY ',4X, - G26.16 / (2X,3G26.16) ) 99999 FORMAT(' ',' ...PT ',I3,'; F=',G23.16,'(#',I3,') !!G!!=', - E7.2, '(#',I3,'); ',F8.3,' SECS' ) C## E N D OF ZZPRNT. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> fsclsg.f SUBROUTINE ZZFSCL ( FT, FV, SCALE, FSCALE, FONLY, GONLY ) C## A R G U M E N T S: INTEGER FSCALE LOGICAL FONLY, GONLY REAL FT, FV, SCALE C!!!! DOUBLE PRECISION FT, FV, SCALE C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: FSCL.F,V 2.1 91/11/20 10:46:58 BUCKLEY EXP $ C>RCS $LOG: FSCL.F,V $ C>RCS REVISION 2.1 91/11/20 10:46:58 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 2.0 90/07/31 11:12:20 BUCKLEY C>RCS ADDED REVISED BLAS. C>RCS C>RCS REVISION 1.9 89/06/30 13:11:50 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3 89/05/18 12:40:17 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:49:30 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM.. C>RCS C>RCS REVISION 1.1 89/01/07 14:36:08 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS SUBROUTINE APPLIES ONE OF SEVERAL SCALINGS (LINEAR OR C NONLINEAR) TO A FUNCTION VALUE. C C-----ON ENTRY: C C FT - THE PRESENT FUNCTION VALUE C C FSCALE - THE CODE FOR THE TYPE OF SCALE DESIRED. WHERE C THE SCALE FUNCTION IS ONE OF THE FOLLOWING: C C 1: F(Z) = 1 + Z C 2: F(Z) = Z*Z C 3: F(Z) = -1 / (1 + Z*Z) C 4: F(Z) = SQRT(1 + Z*Z) C 5: F(Z) = Z*Z*Z C C FONLY - IF TRUE ONLY THE FUNCTION IS EVALUATED. C GONLY - IF TRUE ONLY THE GRADIENT IS EVALUATED. C C-----ON EXIT: C FV - THE SCALED FUNCTION VALUE. C SCALE - GRADIENT SCALING FACTOR. C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZFSCL. C## S U B R O U T I N E S: SQRT... INTRINSIC C## P A R A M E T E R S: REAL ZERO, ONE, TWO, THREE C!!!! DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) REAL FOUR, FIVE, SIX, SEVEN C!!!! DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) REAL EIGHT, NINE, TEN C!!!! DOUBLE PRECISION EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 9D0, TEN = 10D0 ) C## L O C A L D E C L: NONE ARE DEFINED. C## S A V E: NONE SELECTED. C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NONE ARE SET. C## E X E C U T I O N C## E X E C U T I O N GOTO (2100,2200,2300,2400,2500), FSCALE C -----FF(Z) = 1 + F(Z) -------FSCALE = 1. 2100 IF ( .NOT. GONLY ) FV = FT + ONE IF ( .NOT. FONLY ) SCALE = ONE GOTO 90000 C -----FF(Z) = Z*Z ------------FSCALE = 2. 2200 IF ( .NOT. GONLY ) FV = FT * FT IF ( .NOT. FONLY ) SCALE = TWO * FT GOTO 90000 C -----FF(Z) = -1/(1+Z**2) --- FSCALE = 3. 2300 FV = -ONE / ( ONE + FT**2 ) IF ( .NOT. FONLY ) SCALE = TWO * FT * FV**2 GOTO 90000 C -----FF(Z) = SQRT(1+Z**2) -- FSCALE = 4. 2400 FV = SQRT(ONE + FT**2) IF ( .NOT. FONLY ) SCALE = FT/FV GOTO 90000 C -----FF(Z) = Z*Z*Z --------- FSCALE = 5. 2500 IF ( .NOT. GONLY ) FV = FT*FT*FT IF ( .NOT. FONLY ) SCALE = THREE*FT*FT GOTO 90000 C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZFSCL. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> termsg.f SUBROUTINE ZZTERM ( FIRST, N, FX, G, XI, XIM1, EPS, LESS ) C## A R G U M E N T S: INTEGER N LOGICAL LESS, FIRST REAL EPS, G(N), XI(N), XIM1(N), FX C!!!! DOUBLE PRECISION EPS, G(N), XI(N), XIM1(N), FX C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: TERM.F,V 2.1 91/11/20 10:47:03 BUCKLEY EXP $ C>RCS $LOG: TERM.F,V $ C>RCS REVISION 2.1 91/11/20 10:47:03 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 2.0 90/07/31 11:12:58 BUCKLEY C>RCS ADDED REVISED BLAS. C>RCS C>RCS REVISION 1.9 89/06/30 13:11:51 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3 89/05/18 12:40:18 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:49:32 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM.. C>RCS C>RCS REVISION 1.1 89/01/07 14:36:12 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE IS USED TO TEST WHETHER OR NOT TO TERMINATE A C MINIMIZATION ROUTINE. IT PROVIDES A MEANS OF USING UNIFORM C CRITERIA FOR DIFFERENT ROUTINES. A CHOICE OF CRITERIA IS C PROVIDED, ACCORDING TO VARIABLES WHICH ARE PASSED IN THE C ENTRY ZZTSET. C C NOTE THAT IN ONE CASE, THE TEST CANNOT BE APPLIED ON THE C FIRST POINT SINCE A PAIR OF SUCCESSIVE POINTS IS REQUIRED. C THUS A FLAG FIRST IS REQUIRED IN THE CALLING SEQUENCE. IF IT C IS TRUE, IT IS ASSUMED THAT THE ALGORITHM IS AT AN INITIAL C POINT AND LESS IS ALWAYS RETURNED AS FALSE IF ONE INCLUDES THE C TEST WHICH LOOKS AT MORE THAN ONE POINT. C C NOTE THAT IT WILL ALWAYS RETURN A TRUE VALUE IF THE NORM C OF THE GRADIENT COMPUTES TO 0, SINCE IN THIS CASE, NO FURTHER C STEPS CAN BE TAKEN ANYWAY. C C HERE !! V !! DENOTES THE APPROPRIATE NORM OF THE VECTOR V. C C N IS THE LENGTH OF THE VECTORS. C C-----ENTRY ZZTSET ( NORM, TESTS, TRACE, TRACUN ) C C THE CRITERIA ARE DETERMINED AS FOLLOWS: C C NORM = NL1 [1] USE THE NL1 (ABSSUM) NORM OF VECTORS. C = NL2 [2] USE THE NL2 (EUCLIDEAN) NORM OF VECTORS. C = NLINF[3] USE THE MAXIMUM (INFINITY) NORM OF VECTORS. C C TESTS THIS IS A CHARACTER STRING OF LENGTH 4. EACH CHARACTER C CAN BE 'T' TO INDICATE THAT THE CORRESPONDING TEST C IS TO BE APPLIED, OR ANYTHING ELSE TO INDICATE NOT. C THE DIGIT IN [.] BELOW INDICATES WHICH CHARACTER C IN THE STRING CONTROLS EACH TEST. C C IF THE TRACE ARGUMENT IS SET TO TRUE, THEN THE RESULT OF C EACH TEST WILL BE PRINTED ON UNIT TRACUN. NOTE THAT WHEN C SEVERAL TESTS ARE BEING APPLIED, THE TRACE WILL SHOW EACH C SEPARATELY. C C THE TESTS MAY BE SCALED RELATIVE TO CERTAIN VALUES, C NORMALLY THE VALUE OF THE FUNCTION AND GRADIENT AT THE C INITIAL POINT. THIS IS DESCRIBED FURTHER IN THE DESCRIPTION C OF THE ENTRY POINT ZZTINT BELOW. C C TYPE = GRAD[1] TEST IF THE APPROPRIATE NORM OF G IS < OR = EPS. C THIS FIRST TYPE OF TEST IS MOST COMMONLY USED TO C SEE IF THE GRADIENT IS SUFFICIENTLY SMALL. THUS C THE TEST APPLIED IS C C !!G!! <= EPS * NG0 C C = STEP[2] TEST IF THE APPROPRIATE NORM OF THE DIFFERENCE C BETWEEN XI AND XIM1 IS <= EPS. THE TEST IS C ABSOLUTE IF THE NORM OF XI IS LESS THAN ONE, AND C RELATIVE OTHERWISE. THIS TYPE OF TEST IS NORMALLY C USED TO TEST THE DISTANCE BETWEEN SUCCESSIVE C POINTS. THUS THE TEST IS C C !! XI-XIM1 !! <= EPS * MAX(1,!!XI!!) C C = SHXG[3] USE A TEST APPEARING IN SHANNO'S CONMIN USING X C AND G. TERMINATION IS INDICATED WHEN C C !!G!! C ------------ <= EPS * NG0 C MAX(1,!!X!!) C C = FUNC[4] TERMINATE IF THE FUNCTION VALUE IS SUFFICIENTLY C SMALL. THIS TEST WOULD NORMALLY ONLY BE USED IN C A RELATIVE MANNER. THUS THE TEST IS C C !FX! <= EPS * !FX0! C C NOTE THAT SEVERAL OF THESE TESTS MAY BE APPLIED. THIS IS C DETERMINED BY THE NUMBER OF CHARACTERS IN THE STRING TESTS C WHICH ARE SET TO 'T'. C C OTHER POINTS TO NOTE ARE: C C SOME TESTS ARE ACTUALLY DONE BY COMPARING THE SQUARES OF THE C NORMS AGAINST EPS**2. THUS IT IS POSSIBLE THAT THIS VERSION C OF THIS ROUTINE MIGHT GENERATE AN UNWANTED OVERFLOW OR C UNDERFLOW. C C NOTE: NEITHER G NOR XI NOR XIM1 IS ALTERED BY THIS ROUTINE. C ONLY THOSE VECTORS USED IN THE TEST ARE ACTUALLY C REFERENCED. FOR EXAMPLE, IF TYPE=GRAD (ONLY), XIM1 IS NOT C REFERENCED. C C ON RETURN: IF THE DESIRED TESTS ARE *ALL* PASSED, THEN LESS C IS SET TO .TRUE.; OTHERWISE IT IS SET TO .FALSE.. C C-----ENTRY TGET ( GSQ, XSG, DIFFSQ ) C C GSQ, XSQ - THE VECTOR NORMS COMPUTED DURING APPLICATION OF THE C DIFFSQ TESTS ARE DECLARED AS SAVE VARIABLES SO THAT THE C VALUES CAN BE ACCESSED IF DESIRED BY CALLING THE C ENTRY POINT ZZTGET. OF COURSE, ONLY THOSE WHICH C WERE ACTUALLY COMPUTED IN APPLYING THE DESIRED TESTS C WILL BE DEFINED. C C WE HAVE SPECIFICALLY: C C GSQ NORM SQUARED OF G, GSQ = !!G!!**2 C C XSQ NORM SQUARED OF XI, XSQ = !!XI!!**2 C C DIFFSQ NORM SQUARED OF XI-XIM1, DIFFSQ = !!XI-XIM1!!**2 C C-----ENTRY POINT ZZTINT (FX0, NG0) C C IT IS OFTEN DESIRED TO MAKE TERMINATION TESTS RELATIVE TO THE C FUNCTION AND/OR GRADIENT VALUES AT THE INITIAL POINT. IN THE C TESTS ABOVE, THE VALUES FX0 AND NG0 ARE USED; THESE MAY BE C THOUGHT OF AS THE FUNCTION VALUE AT X0, ALONG WITH THE NORM OF C THE GRADIENT AT THAT POINT. THE VALUES FOR FX0 AND NG0 ARE SET C BY CALLING THIS ENTRY POINT JUST AFTER THE FIRST FUNCTION AND C GRADIENT HAVE BEEN EVALUATED. IF RELATIVE TESTS ARE NOT DESIRED, C THESE VALUES SHOULD BE SET TO 1. IF THE ENTRY POINT IS NOT CALLED, C THE DEFAULT VALUE FOR THESE IS IN FACT 1. C C## E N T R Y P O I N T S: ZZTERM ...THE NATURAL ENTRY. C ZZTGET ...RETURN NORMS. C ZZTSET ...SET THE CONTROL VALUES. C ZZTINT ...SET INITIAL SCALING VALUES. C## S U B R O U T I N E S: ABS AND MAX ...INTRINSIC C## P A R A M E T E R S: REAL ZERO, ONE, TWO, THREE C!!!! DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) REAL FOUR, FIVE, SIX, SEVEN C!!!! DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) REAL EIGHT, NINE, TEN C!!!! DOUBLE PRECISION EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 9D0, TEN = 10D0 ) LOGICAL T, F PARAMETER ( T = .TRUE., F = .FALSE. ) CHARACTER*(*) TRUE, QT, FALSE, QF PARAMETER ( TRUE = 'TRUE', QT = 'T', FALSE = 'FALSE', QF = 'F' ) INTEGER ITRUE, IFALSE PARAMETER ( ITRUE = 1, IFALSE = 0 ) REAL RTRUE, RFALSE C!!!! DOUBLE PRECISION RTRUE, RFALSE PARAMETER ( RTRUE = 1.D0, RFALSE = 0.D0 ) C---- NORM AND TEST TYPES INTEGER NL1, NL2, NLINF PARAMETER ( NL1 = 1, NL2 = 2, NLINF = 3 ) INTEGER NQUITS PARAMETER ( NQUITS = 4 ) INTEGER PGRAD, PSTEP, PSHXG, PFUNC PARAMETER ( PGRAD = 1, PSTEP = 2, PSHXG = 3, PFUNC = 4 ) C## L O C A L D E C L: INTEGER I REAL GSQ, XSQ, DIFFSQ C!!!! DOUBLE PRECISION GSQ, XSQ, DIFFSQ LOGICAL LIST C-----DECLARATIONS FOR ENTRY POINT DUMMY ARGUMENTS. CHARACTER*(4) TESTS LOGICAL GRAD, STEP, SHXG, FUNC, TRACE, STRACE INTEGER NORM, SNORM, TRACUN, STRCUN REAL VGSQ, VXSQ, VDIFSQ, FX0, SF0, NG0, SNG0 C!!!! DOUBLE PRECISION VGSQ, VXSQ, VDIFSQ, FX0, SF0, NG0, SNG0 C## S A V E: SAVE GSQ, XSQ, DIFFSQ, FX0, NG0, GRAD, STEP SAVE TRACE, TRACUN, SHXG, FUNC, NORM C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA FX0/ONE/, NG0/ONE/ DATA NORM/2/, TRACE/.FALSE./, TRACUN/6/ DATA GRAD/.FALSE./, STEP/.TRUE./, SHXG/.TRUE./, FUNC/.FALSE./ C## E X E C U T I O N C## E X E C U T I O N IF ( .NOT. FIRST .OR. GRAD .OR. SHXG ) THEN IF ( GRAD .OR. SHXG ) THEN GSQ = ZERO DO 500 I=1,N IF ( NORM .EQ. NL1 ) THEN GSQ = GSQ + ABS(G(I)) ELSEIF ( NORM .EQ. NL2 ) THEN GSQ = GSQ + (G(I))**2 ELSEIF ( NORM .EQ. NLINF ) THEN GSQ = MAX( GSQ, ABS(G(I)) ) ENDIF 500 CONTINUE IF ( GSQ .EQ. ZERO ) THEN LESS = T GOTO 90000 ENDIF ENDIF IF ( STEP .OR. SHXG ) THEN XSQ = ZERO DO 700 I=1,N IF ( NORM .EQ. NL1 ) THEN XSQ = XSQ + ABS(XI(I)) ELSEIF ( NORM .EQ. NL2 ) THEN XSQ = XSQ + (XI(I))**2 ELSEIF ( NORM .EQ. NLINF ) THEN XSQ = MAX( XSQ, ABS(XI(I)) ) ENDIF 700 CONTINUE ENDIF IF ( STEP ) THEN DIFFSQ = ZERO DO 900 I=1,N IF ( NORM .EQ. NL1 ) THEN DIFFSQ = DIFFSQ + ABS(XI(I) - XIM1(I)) ELSEIF ( NORM .EQ. NL2 ) THEN DIFFSQ = DIFFSQ + ( XI(I)-XIM1(I) )**2 ELSEIF ( NORM .EQ. NLINF ) THEN DIFFSQ = MAX( DIFFSQ, ABS(XI(I) - XIM1(I)) ) ENDIF 900 CONTINUE ENDIF ENDIF IF ( FIRST .AND. STEP ) THEN LESS = .FALSE. IF ( TRACE ) WRITE(TRACUN,99999) ' [TERM] FIRST POINT;' - //' NO STEPSIZE; NO TEST DONE.' ELSE LESS = .TRUE. IF ( GRAD ) THEN LIST = GSQ .LE. (EPS*NG0)**2 LESS = LESS .AND. LIST IF (TRACE) WRITE(TRACUN,99998) - LIST,'(GRAD) GSQ,EPS,NG0=',GSQ,EPS,NG0 ENDIF IF ( STEP .AND. (LESS .OR. TRACE) ) THEN LIST = DIFFSQ .LE. EPS**2 * MAX(ONE,XSQ) LESS = LESS .AND. LIST IF (TRACE) WRITE(TRACUN,99998) - LIST, '(STEP) DIFFSQ,XSQ,EPS=', DIFFSQ,XSQ,EPS ENDIF IF ( SHXG .AND. (LESS .OR. TRACE) ) THEN LIST = GSQ .LE. (EPS*NG0)**2 * MAX(ONE,XSQ) LESS = LESS .AND. LIST IF (TRACE) WRITE(TRACUN,99997) LIST, - ' (SHXG) G,XSQ;EPS,NG0=',GSQ,XSQ,EPS,NG0 ENDIF IF ( FUNC .AND. (LESS .OR. TRACE) ) THEN LIST = ABS(FX) .LE. EPS * ABS(FX0) LESS = LESS .AND. LIST IF (TRACE) WRITE(TRACUN,99998) - LIST, '(FUNC) FX, FX0, EPS=',FX, FX0, EPS ENDIF ENDIF GOTO 90000 C## E N T R Y ZZTSET: ENTRY ZZTSET ( SNORM, TESTS, STRACE, STRCUN ) NORM = SNORM GRAD = TESTS(PGRAD:PGRAD) .EQ. 'T' STEP = TESTS(PSTEP:PSTEP) .EQ. 'T' SHXG = TESTS(PSHXG:PSHXG) .EQ. 'T' FUNC = TESTS(PFUNC:PFUNC) .EQ. 'T' TRACE = STRACE TRACUN = STRCUN RETURN C## E N T R Y ZZTINT: ENTRY ZZTINT ( SF0, SNG0 ) FX0 = SF0 NG0 = SNG0 RETURN C## E N T R Y ZZTGET: ENTRY ZZTGET ( VGSQ, VXSQ, VDIFSQ ) VGSQ = GSQ VXSQ = XSQ VDIFSQ = DIFFSQ RETURN C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. 99999 FORMAT ( A ) 99998 FORMAT ( ' [TERM] LESS=',L1,'; ',A,3G14.3 ) 99997 FORMAT ( ' [TERM] LESS=',L1,'; ',A,4G11.3 ) C## E N D OF ZZTERM. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> dttmsg.f SUBROUTINE ZZDTTM ( CHDATE ) C## A R G U M E N T S: CHARACTER *(*) CHDATE C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NOT REQUIRED. C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: DTTM.F,V 1.10 91/11/19 16:15:05 BUCKLEY EXP $ C>RCS $LOG: DTTM.F,V $ C>RCS REVISION 1.10 91/11/19 16:15:05 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.9 89/06/30 13:28:53 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 13:39:29 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 14:26:41 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:44:17 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:30:07 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE RETURNS IN CHDATE A 41-CHARACTER DATE OF THE FORM C GIVEN IN MODEL(BELOW). IT USES THE TIME AND DATE AS OBTAINED C FROM THE OPERATING SYSTEM (VIA THE ROUTINES ZZTIME AND ZZDATE) C AND CONVERTS THEM TO THE FORM OF THE MODEL GIVEN BELOW. C IT ASSUMES THAT THE ROUTINES ZZTIME AND ZZDATE RETURN 10 C CHARACTER STRINGS, RESPECTIVELY, OF THE FORM: C C TIME: (HH+MM+SS) C DATE: (YY+MM+DD) C C NOTE THAT EXCESS BLANKS IN THE DATE ARE ELIMINATED. C IF CHDATE IS MORE THAN 41 CHARACTERS IN LENGTH, ONLY THE C LEFTMOST 41 WILL BE ALTERED. IF IT IS LESS THAN 41 IN C LENGTH, ONLY THE LEFTMOST CHARACTERS OF THE DATE WILL BE C RETURNED. C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZDTTM C## S U B R O U T I N E S: C C ZZDATE USER ROUTINE TO GET A DATE. C ZZTIME USER ROUTINE TO GET THE TIME OF DAY. C ZZLENG USER ROUTINE TO GET STRING LENGTH. C ZZSHFT USER ROUTINE TO SHIFT A STRING. C MIN, INT, LEN, MOD, REAL ...INTRINSIC C C## P A R A M E T E R S: INTEGER PTHOUR, PTMIN, PTAMPM PARAMETER ( PTHOUR = 1, PTMIN = 4, PTAMPM = 7 ) INTEGER PTMON, PTDAY, PTYEAR, PTDAYN PARAMETER ( PTMON = 24, PTDAY = 34, PTYEAR = 40, PTDAYN = 13 ) CHARACTER*(*) MODEL PARAMETER ( MODEL ='00:00 A.M., WEDNESDAY, SEPTEMBER 00, 1999') C## L O C A L D E C L: INTEGER KMON, TO, K, DAYNO, MODLEN INTEGER ZZLENG CHARACTER *10 TEMP CHARACTER *41 TDATE CHARACTER * 9 MONTHS(12), DAYS(0:6) C## S A V E: SAVE MONTHS, DAYS C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NONE ARE SET. DATA MONTHS( 1), MONTHS( 2)/'JANUARY ','FEBRUARY '/ DATA MONTHS( 3), MONTHS( 4)/'MARCH ','APRIL '/ DATA MONTHS( 5), MONTHS( 6)/'MAY ','JUNE '/ DATA MONTHS( 7), MONTHS( 8)/'JULY ','AUGUST '/ DATA MONTHS( 9), MONTHS(10)/'SEPTEMBER','OCTOBER '/ DATA MONTHS(11), MONTHS(12)/'NOVEMBER ','DECEMBER '/ DATA DAYS(0) / 'SUNDAY ' / DATA DAYS(1) / 'MONDAY ' / DATA DAYS(2) / 'TUESDAY ' / DATA DAYS(3) / 'WEDNESDAY' / DATA DAYS(4) / 'THURSDAY ' / DATA DAYS(5) / 'FRIDAY ' / DATA DAYS(6) / 'SATURDAY ' / C## E X E C U T I O N C## E X E C U T I O N TDATE = MODEL MODLEN = LEN(TDATE) CALL ZZDATE(TEMP) IF ( TEMP(8:8) .EQ. '0' ) THEN TEMP(8:8) = ' ' ENDIF TDATE ( PTDAY : PTDAY+1 ) = TEMP(8:9) TDATE ( PTYEAR : PTYEAR+1 ) = TEMP(2:3) READ ( TEMP(8:9), '(I2)' ) DAYNO READ ( TEMP(2:3), '(I2)' ) K K = K + 1900 READ ( TEMP(5:6), '(I2)' ) KMON TDATE(PTMON:PTMON+8) = MONTHS(KMON) TO = ZZLENG ( MONTHS(KMON) ) IF ( TO .NE. 9 ) THEN CALL ZZSHFT ( TDATE, PTMON+9, PTMON+TO, MODLEN ) ENDIF IF ( KMON .EQ. 1 .OR. KMON .EQ. 2 ) THEN KMON = KMON + 13 K = K - 1 ELSE KMON = KMON + 1 ENDIF DAYNO = DAYNO + INT ( REAL(KMON) * 30.6001 ) DAYNO = DAYNO + INT ( REAL( K ) * 365.25 ) DAYNO = MOD ( DAYNO+5, 7 ) CALL ZZTIME(TEMP) TDATE(PTMIN:PTMIN+1) = TEMP(5:6) READ ( TEMP(2:3), '(I2)' ) K IF ( K .GE. 13 ) THEN K = K-12 TDATE(PTAMPM:PTAMPM) = 'P' ELSE IF ( K .EQ. 12 ) THEN TDATE(PTAMPM:PTAMPM) = 'P' ELSE IF ( K .EQ. 0 ) THEN K = K + 12 TDATE(PTAMPM:PTAMPM) = 'A' ELSE TDATE(PTAMPM:PTAMPM) = 'A' ENDIF WRITE ( TDATE(PTHOUR:PTHOUR+1), '(I2)' ) K TDATE(PTDAYN:PTDAYN+8) = DAYS(DAYNO) K = ZZLENG (DAYS(DAYNO)) IF ( K .NE. 9 ) THEN C ==> SHIFT OVER BLANKS. CALL ZZSHFT ( TDATE, PTDAYN+9, PTDAYN+K, MODLEN ) ENDIF GOTO 90000 C## E X I T 90000 MODLEN = MIN ( MODLEN, LEN(CHDATE) ) CHDATE(1:MODLEN) = TDATE RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZDTTM. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> shftsg.f SUBROUTINE ZZSHFT (STRING, FROM, TO, NUMBER ) C## A R G U M E N T S: INTEGER FROM, TO, NUMBER CHARACTER *(*) STRING C## S T A T U S: C SYSTEM DEPENDENCE: NONE. C SINGLE/DOUBLE CONVERSION: NOT REQUIRED. C C>RCS $HEADER: SHFT.F,V 1.10 91/11/19 16:18:04 BUCKLEY EXP $ C>RCS $LOG: SHFT.F,V $ C>RCS REVISION 1.10 91/11/19 16:18:04 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.9 89/06/30 13:29:07 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 13:39:42 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 14:26:57 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:44:49 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:30:10 BUCKLEY C>RCS INITIAL REVISION C>RCS C## D E S C R I P T I O N: C THIS ROUTINE PERFORMS A SHIFT OF CHARACTERS WITHIN STRING. THE C NUMBER OF CHARACTERS SHIFTED IS NUMBER AND THEY ARE SHIFTED SO C THAT THE CHARACTER IN POSITION FROM IS MOVED TO POSITION TO. C CHARACTERS IN THE TO POSITION ARE OVERWRITTEN. BLANKS REPLACE C CHARACTERS IN THE FROM POSITION. SHIFTING MAY BE LEFT OR RIGHT, C AND THE FROM AND TO POSITIONS MAY OVERLAP. CARE IS TAKEN NOT C TO ALTER OR USE ANY CHARACTERS BEYOND THE DEFINED LIMITS C OF THE STRING. C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZSHFT. C## S U B R O U T I N E S: LEN MIN MAX (INTRINSIC) C## P A R A M E T E R S: CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) CHARACTER*(*) PERIOD, COMMA, SEMICN PARAMETER ( PERIOD = '.', COMMA = ',', SEMICN = ';' ) CHARACTER*(*) COLON, DASH, EQUALS PARAMETER ( COLON = ':', DASH = '-', EQUALS = '=' ) CHARACTER*(*) OBRACE, CBRACE, UNDERS PARAMETER ( OBRACE = '{', CBRACE = '}', UNDERS = '_' ) CHARACTER*(*) PLUS, MINUS, EXCLAM PARAMETER ( PLUS = '+', MINUS = '-', EXCLAM = '!' ) CHARACTER*(*) GTHAN, LTHAN, QUESMK PARAMETER ( GTHAN = '>', LTHAN = '<', QUESMK = '?' ) CHARACTER*(*) SLASH, BSLASH, PERCNT PARAMETER ( SLASH = '/', BSLASH = '\\',PERCNT = '%' ) CHARACTER*(*) CARAT, ATSIGN, TILDE PARAMETER ( CARAT = '^', ATSIGN = '@', TILDE = '~' ) C## L O C A L D E C L: INTEGER N, SHIFT, INCR, I, IS, IE INTEGER IBS, ETO, EFROM, K, SLEN CHARACTER *1 CH C## S A V E: NONE SELECTED. C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NO DATA VALUES SET. C## E X E C U T I O N C## E X E C U T I O N SLEN = LEN (STRING) N = NUMBER - 1 SHIFT = FROM - TO IF ( FROM .NE. TO ) THEN IF ( TO .LE. FROM ) THEN INCR = 1 IS = MIN( FROM+MAX(0,1-TO), SLEN+1 ) IE = MIN( FROM+N, SLEN ) IBS = MAX( IE-SHIFT+1, MAX(FROM,0) ) ELSE INCR = -1 ETO = TO + N EFROM = FROM + N IS = MAX( EFROM - MAX(0,ETO-SLEN) , 0 ) IE = MAX(FROM , 0) IBS = MIN( TO-1 , MIN(EFROM,SLEN) ) ENDIF DO 1000 I=IS,IE,INCR K = I - SHIFT CH = STRING(I:I) STRING(K:K) = CH 1000 CONTINUE DO 2000 I=IBS,IE,INCR STRING(I:I) = BLANK 2000 CONTINUE ENDIF GOTO 90000 C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZSHFT. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> lengsg.f INTEGER FUNCTION ZZLENG (LINE) C## A R G U M E N T S: CHARACTER*(*) LINE C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NOT REQUIRED. C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: LENG.F,V 1.10 91/11/19 16:13:33 BUCKLEY EXP $ C>RCS $LOG: LENG.F,V $ C>RCS REVISION 1.10 91/11/19 16:13:33 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.9 89/06/30 13:28:59 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 13:39:34 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 14:26:46 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:44:31 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:30:09 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE DETERMINES THE POSITION OF THE LAST NONBLANK C CHARACTER IN THE STRING LINE. IF THE LINE IS ENTIRELY C BLANK, THEN ZZLENG IS SET TO 0. C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZLENG C## S U B R O U T I N E S: LEN ...INTRINSIC C## P A R A M E T E R S: CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) CHARACTER*(*) PERIOD, COMMA, SEMICN PARAMETER ( PERIOD = '.', COMMA = ',', SEMICN = ';' ) CHARACTER*(*) COLON, DASH, EQUALS PARAMETER ( COLON = ':', DASH = '-', EQUALS = '=' ) CHARACTER*(*) OBRACE, CBRACE, UNDERS PARAMETER ( OBRACE = '{', CBRACE = '}', UNDERS = '_' ) CHARACTER*(*) PLUS, MINUS, EXCLAM PARAMETER ( PLUS = '+', MINUS = '-', EXCLAM = '!' ) CHARACTER*(*) GTHAN, LTHAN, QUESMK PARAMETER ( GTHAN = '>', LTHAN = '<', QUESMK = '?' ) CHARACTER*(*) SLASH, BSLASH, PERCNT PARAMETER ( SLASH = '/', BSLASH = '\\',PERCNT = '%' ) CHARACTER*(*) CARAT, ATSIGN, TILDE PARAMETER ( CARAT = '^', ATSIGN = '@', TILDE = '~' ) C## L O C A L D E C L: INTEGER I C## S A V E: NONE SELECTED. C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NONE ARE SET. C## E X E C U T I O N C## E X E C U T I O N ZZLENG = 0 DO 1000 I = LEN(LINE), 1, -1 IF ( LINE(I:I) .NE. BLANK ) THEN ZZLENG = I GOTO 90000 ENDIF 1000 CONTINUE C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZLENG. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> basesg.f SUBROUTINE ZZBASE ( N, BASE, STRING, * ) C## A R G U M E N T S: CHARACTER *(*) STRING INTEGER N, BASE C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NOT REQUIRED. C C>RCS $HEADER: BASE.F,V 1.10 91/11/19 16:04:05 BUCKLEY EXP $ C>RCS $LOG: BASE.F,V $ C>RCS REVISION 1.10 91/11/19 16:04:05 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.9 89/06/30 13:28:51 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 13:39:27 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 14:26:38 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:44:03 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:30:07 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE TAKES THE STRING OF CHARACTERS IN STRING AND C CONVERTS THEM TO AN INTEGER VALUE IN N. THE NUMBERS ARE ASSUMED C TO BE IN BASE "BASE", WHERE 2 <= BASE <= 16. C C THE STRING IS PROCESSED LEFT TO RIGHT. BLANKS ARE IGNORED, C EVEN WITHIN THE NUMBER. A LEADING + OR - MAY BE GIVEN. ALL C OTHER CHARACTERS MUST BE BETWEEN 0 AND BASE-1. IF BASE > 10, C THEN THE ADDITIONAL DIGITS ALLOWED ARE AS MANY OF A,B,C,D,E,F C AS ARE NECESSARY. ONLY UPPERCASE LETTERS A TO Z ARE RECOGNIZED. C ANY ERROR CAUSES THE ALTERNATE EXIT TO BE TAKEN. C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZBASE C## S U B R O U T I N E S: INDEX, LEN ... INTRINSIC C## P A R A M E T E R S: CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) CHARACTER*(*) PERIOD, COMMA, SEMICN PARAMETER ( PERIOD = '.', COMMA = ',', SEMICN = ';' ) CHARACTER*(*) COLON, DASH, EQUALS PARAMETER ( COLON = ':', DASH = '-', EQUALS = '=' ) CHARACTER*(*) OBRACE, CBRACE, UNDERS PARAMETER ( OBRACE = '{', CBRACE = '}', UNDERS = '_' ) CHARACTER*(*) PLUS, MINUS, EXCLAM PARAMETER ( PLUS = '+', MINUS = '-', EXCLAM = '!' ) CHARACTER*(*) GTHAN, LTHAN, QUESMK PARAMETER ( GTHAN = '>', LTHAN = '<', QUESMK = '?' ) CHARACTER*(*) SLASH, BSLASH, PERCNT PARAMETER ( SLASH = '/', BSLASH = '\\',PERCNT = '%' ) CHARACTER*(*) CARAT, ATSIGN, TILDE PARAMETER ( CARAT = '^', ATSIGN = '@', TILDE = '~' ) C## L O C A L D E C L: CHARACTER * 1 CH CHARACTER *16 DIGITS INTEGER I, K, SIGN C## S A V E: SAVE DIGITS C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C# D A T A: DATA DIGITS / '0123456789ABCDEF' / C## E X E C U T I O N C## E X E C U T I O N N = 0 SIGN = 0 DO 1000 I = 1,LEN(STRING) CH = STRING(I:I) IF ( CH .NE. BLANK ) THEN IF ( CH .EQ. PLUS ) THEN IF ( SIGN .EQ. 0 ) THEN SIGN = 1 ELSE GOTO 91000 ENDIF ELSE IF ( CH .EQ. MINUS ) THEN IF ( SIGN .EQ. 0 ) THEN SIGN = -1 ELSE GOTO 91000 ENDIF ELSE K = INDEX ( DIGITS(1:BASE), CH ) IF ( K .EQ. 0 ) THEN GOTO 91000 ELSE N = N*BASE + K - 1 IF ( SIGN .EQ. 0 ) THEN SIGN = 1 ENDIF ENDIF ENDIF C FOR CASE-SOLUTION ENDIF C FOR NON-BLANK CHARACTER 1000 CONTINUE IF ( SIGN .EQ. 0 ) THEN SIGN = 1 ENDIF N = N * SIGN GOTO 90000 C## E X I T 90000 RETURN 91000 RETURN 1 C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZBASE. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> cntrsg.f SUBROUTINE ZZCNTR ( STRING ) C## A R G U M E N T S: CHARACTER *(*) STRING C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NOT REQUIRED. C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: CNTR.F,V 1.10 91/11/19 16:14:31 BUCKLEY EXP $ C>RCS $LOG: CNTR.F,V $ C>RCS REVISION 1.10 91/11/19 16:14:31 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.9 89/06/30 13:28:52 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 13:39:28 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 14:26:40 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:44:13 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:30:07 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE SHIFTS THE NONBLANK CHARACTERS OF STRING SO THAT C THERE IS A BALANCE OF BLANKS ON LEFT AND RIGHT. C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZCNTR C## S U B R O U T I N E S: LEN ...INTRINSIC C ZZSHFT ...TO SHIFT A STRING. C## P A R A M E T E R S: CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) CHARACTER*(*) PERIOD, COMMA, SEMICN PARAMETER ( PERIOD = '.', COMMA = ',', SEMICN = ';' ) CHARACTER*(*) COLON, DASH, EQUALS PARAMETER ( COLON = ':', DASH = '-', EQUALS = '=' ) CHARACTER*(*) OBRACE, CBRACE, UNDERS PARAMETER ( OBRACE = '{', CBRACE = '}', UNDERS = '_' ) CHARACTER*(*) PLUS, MINUS, EXCLAM PARAMETER ( PLUS = '+', MINUS = '-', EXCLAM = '!' ) CHARACTER*(*) GTHAN, LTHAN, QUESMK PARAMETER ( GTHAN = '>', LTHAN = '<', QUESMK = '?' ) CHARACTER*(*) SLASH, BSLASH, PERCNT PARAMETER ( SLASH = '/', BSLASH = '\\',PERCNT = '%' ) CHARACTER*(*) CARAT, ATSIGN, TILDE PARAMETER ( CARAT = '^', ATSIGN = '@', TILDE = '~' ) C## L O C A L D E C L: INTEGER START, ENDCH, SLEN, CLEN, LEFT, I C## S A V E: NONE SELECTED. C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NONE ARE SET. C## E X E C U T I O N C## E X E C U T I O N SLEN = LEN(STRING) C FIND FIRST NONBLANK CHARACTER. DO 1000 I=1,SLEN IF ( STRING(I:I) .NE. BLANK ) THEN START = I GOTO 2000 ENDIF 1000 CONTINUE C THE STRING IS ALL BLANK IF WE FALL THROUGH THE DO LOOP. GOTO 90000 C FIND LAST NON-BLANK CHARACTER. 2000 DO 3000 I=SLEN,1,-1 IF ( STRING(I:I) .NE. BLANK ) THEN ENDCH = I GOTO 4000 ENDIF 3000 CONTINUE C COMPUTE SHIFT AND DO IT. 4000 CLEN = ENDCH - START + 1 LEFT = 1 + (SLEN - CLEN) / 2 CALL ZZSHFT ( STRING, START, LEFT, CLEN ) GOTO 90000 C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZCNTR. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> errmsg.f SUBROUTINE ZZERRM ( VALUE, *, MESSAG ) C## A R G U M E N T S: CHARACTER *(*) MESSAG REAL VALUE C!!!! DOUBLE PRECISION VALUE C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: ERRM.F,V 1.10 91/11/19 16:15:44 BUCKLEY EXP $ C>RCS $LOG: ERRM.F,V $ C>RCS REVISION 1.10 91/11/19 16:15:44 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.9 89/06/30 13:28:55 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 13:39:31 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 14:26:43 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:44:23 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:30:08 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE PRINTS AN ERROR MESSAGE, AND THEN RETURNS. C C CODE IS MESSAGE ( 1:1 ) C LEVEL IS MESSAGE ( 2:2 ) C C IF CODE = NONE ('N') VALUE IS IGNORED. C = INTG ('I') THE INTEGER NINT(VALUE) IS PRINTED. C = REEL ('R') VALUE IS PRINTED. C C LEVEL GIVES THE SEVERITY CODE, AS FOLLOWS: C C TRIVAL ('T') NORMAL RETURN IN ANY CASE; A TRIVIAL ERROR. C SEVERE ('S') NORMAL RETURN IF INTACT IS TRUE; C ALTERNATE RETURN OTHERWISE. C THIS ALLOWS FOR AN ABORT IN BATCH MODE. C FATAL ('F') ALTERNATE RETURN IN ANY CASE. THIS FORCES AN C ABORT EVEN IN INTERACTIVE MODE. C C## E N T R Y P O I N T S: ZZERRM THE NATURAL ENTRY. C ZZETRM DEFINE UNIT. C C## S U B R O U T I N E S: NINT ...INTRINSIC C ZZLENG ...NON-BLANK LENGTH OF A STRING. C C## P A R A M E T E R S: NONE ARE DEFINED. CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) CHARACTER*(*) PERIOD, COMMA, SEMICN PARAMETER ( PERIOD = '.', COMMA = ',', SEMICN = ';' ) CHARACTER*(*) COLON, DASH, EQUALS PARAMETER ( COLON = ':', DASH = '-', EQUALS = '=' ) CHARACTER*(*) OBRACE, CBRACE, UNDERS PARAMETER ( OBRACE = '{', CBRACE = '}', UNDERS = '_' ) CHARACTER*(*) PLUS, MINUS, EXCLAM PARAMETER ( PLUS = '+', MINUS = '-', EXCLAM = '!' ) CHARACTER*(*) GTHAN, LTHAN, QUESMK PARAMETER ( GTHAN = '>', LTHAN = '<', QUESMK = '?' ) CHARACTER*(*) SLASH, BSLASH, PERCNT PARAMETER ( SLASH = '/', BSLASH = '\\',PERCNT = '%' ) CHARACTER*(*) CARAT, ATSIGN, TILDE PARAMETER ( CARAT = '^', ATSIGN = '@', TILDE = '~' ) INTEGER MESTRT PARAMETER ( MESTRT = 3 ) C## L O C A L D E C L: EXTERNAL ZZLENG INTEGER K, ZZLENG, OUT, DFUNIT LOGICAL MODE, INTACT CHARACTER * 1 TRIVAL, SEVERE, FATAL, CODE CHARACTER * 1 INTG, REEL, NONE, LEVEL C## S A V E: SAVE TRIVAL, SEVERE, FATAL, INTACT SAVE OUT, NONE, INTG, REEL C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA OUT /6/, INTACT /.FALSE./ DATA TRIVAL /'T'/, SEVERE /'S'/, FATAL /'F'/ DATA NONE /'N'/, INTG /'I'/, REEL /'R'/ C## E X E C U T I O N C## E X E C U T I O N C----- FIRST WRITE THE ERROR MESSAGE. K = ZZLENG ( MESSAG ) IF ( MESSAG(K:K) .EQ. PERIOD ) THEN K = K - 1 ENDIF CODE = MESSAG ( 1:1 ) LEVEL = MESSAG ( 2:2 ) IF ( CODE .EQ. NONE ) THEN WRITE ( OUT, 99999 ) BLANK, MESSAG(MESTRT:K), PERIOD ELSE IF ( CODE .EQ. INTG ) THEN WRITE ( OUT, 99998 ) BLANK, MESSAG(MESTRT:K), - BLANK, NINT(VALUE), PERIOD ELSE IF ( CODE .EQ. REEL ) THEN WRITE ( OUT, 99997 ) BLANK, MESSAG(MESTRT:K), - BLANK, VALUE, PERIOD ENDIF C-----THEN INDICATE WHETHER JOB CONTINUING OR ABORTING. IF ( INTACT ) THEN IF ( LEVEL .EQ. FATAL ) THEN WRITE ( OUT, 99999 ) ' JOB BEING ABORTED.' ENDIF ELSE IF ( LEVEL .EQ. TRIVAL ) THEN WRITE ( OUT, 99999 ) ' JOB WILL CONTINUE.' ELSE WRITE ( OUT, 99999 ) ' JOB BEING ABORTED.' ENDIF ENDIF GOTO 90000 C## E N T R Y ZZETRM: ENTRY ZZETRM ( MODE, DFUNIT ) OUT = DFUNIT INTACT = MODE RETURN C## E X I T C USE ALTERNATE RETURN IF ABORT REQUIRED. 90000 IF ( ( INTACT .AND. LEVEL .EQ. FATAL ) .OR. - .NOT. INTACT .AND. LEVEL .NE. TRIVAL ) THEN RETURN 1 ELSE RETURN ENDIF C## F O R M A T S: 99997 FORMAT ( A, A, A, G14.7, A ) 99998 FORMAT ( A, A, A, I8, A ) 99999 FORMAT ( A, A, A ) C## E N D OF ZZERRM. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> leftsg.f INTEGER FUNCTION ZZLEFT (LINE) C## A R G U M E N T S: CHARACTER*(*) LINE C## S T A T U S: C SYSTEM DEPENDENCE: NONE. C SINGLE/DOUBLE CONVERSION: NOT REQUIRED. C C>RCS $HEADER: LEFT.F,V 1.10 91/11/19 16:13:32 BUCKLEY EXP $ C>RCS $LOG: LEFT.F,V $ C>RCS REVISION 1.10 91/11/19 16:13:32 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.9 89/06/30 13:28:58 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 13:39:33 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 14:26:46 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:44:29 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:30:08 BUCKLEY C>RCS INITIAL REVISION C>RCS C## D E S C R I P T I O N: C C THIS ROUTINE DETERMINES THE POSITION OF THE LAST NONBLANK C CHARACTER IN THE STRING LINE. IF THE LINE IS ENTIRELY C BLANK, THEN ZZLEFT IS SET TO 0. NOTE THAT IT FIRST CLEARS C ANY LEADING BLANKS BY FIRST LEFT SHIFTING THE LINE IF NEEDED. C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZLEFT. C## S U B R O U T I N E S: LEN (INTRINSIC) C## P A R A M E T E R S: CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) CHARACTER*(*) PERIOD, COMMA, SEMICN PARAMETER ( PERIOD = '.', COMMA = ',', SEMICN = ';' ) CHARACTER*(*) COLON, DASH, EQUALS PARAMETER ( COLON = ':', DASH = '-', EQUALS = '=' ) CHARACTER*(*) OBRACE, CBRACE, UNDERS PARAMETER ( OBRACE = '{', CBRACE = '}', UNDERS = '_' ) CHARACTER*(*) PLUS, MINUS, EXCLAM PARAMETER ( PLUS = '+', MINUS = '-', EXCLAM = '!' ) CHARACTER*(*) GTHAN, LTHAN, QUESMK PARAMETER ( GTHAN = '>', LTHAN = '<', QUESMK = '?' ) CHARACTER*(*) SLASH, BSLASH, PERCNT PARAMETER ( SLASH = '/', BSLASH = '\\',PERCNT = '%' ) CHARACTER*(*) CARAT, ATSIGN, TILDE PARAMETER ( CARAT = '^', ATSIGN = '@', TILDE = '~' ) C## L O C A L D E C L: INTEGER I, START C## S A V E: NONE SELECTED. C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NO DATA VALUES SET. C## E X E C U T I O N C## E X E C U T I O N ZZLEFT = 0 DO 500 I = 1, LEN(LINE) IF ( LINE(I:I) .NE. BLANK ) THEN START = I GOTO 600 ENDIF 500 CONTINUE GOTO 90000 600 DO 700 I = LEN(LINE), 1, -1 IF ( LINE(I:I) .NE. BLANK ) THEN ZZLEFT = I GOTO 800 ENDIF 700 CONTINUE 800 IF ( START .NE. 1 ) THEN CALL ZZSHFT ( LINE, START, 1, ZZLEFT-START+1 ) ZZLEFT = ZZLEFT - START + 1 ENDIF 1000 CONTINUE C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZLEFT. END C C C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> lftisg.f INTEGER FUNCTION ZZLFTI (STRING, N ) C## A R G U M E N T S: INTEGER N CHARACTER *(*) STRING C## S T A T U S: C C SYSTEM DEPENDENCE: NONE. C SINGLE/DOUBLE CONVERSION: NOT REQUIRED. C C>RCS $HEADER: LFTI.F,V 1.10 91/11/19 16:13:35 BUCKLEY EXP $ C>RCS $LOG: LFTI.F,V $ C>RCS REVISION 1.10 91/11/19 16:13:35 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.9 89/06/30 13:28:59 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 13:39:35 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 14:26:47 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:44:35 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C## D E S C R I P T I O N: C THIS ROUTINE TAKES THE INTEGER N, CONVERTS IT TO A CHARACTER C REPRESENTATION, AND PUTS IT INTO STRING WITH NO LEADING C BLANKS. IT RETURNS THE LENGTH OF THE RESULTING STRING WITH C TRAILING BLANKS NOT INCLUDED. C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZLFTI. C## S U B R O U T I N E S: ZZLEFT. C## P A R A M E T E R S: NONE ARE DEFINED. C## L O C A L D E C L: INTEGER ZZLEFT C## S A V E: NONE SELECTED. C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NO DATA VALUES SET. C## E X E C U T I O N C## E X E C U T I O N WRITE ( STRING, '(I10)' ) N ZZLFTI = ZZLEFT(STRING) C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZLFTI. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> rdchsg.f SUBROUTINE ZZRDCH ( UNIT, LIST, NDATA, NPERLN, RECNO ) C## A R G U M E N T S: INTEGER UNIT, NDATA, NPERLN, RECNO CHARACTER *(*) LIST C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NOT REQUIRED. C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: RDCH.F,V 1.10 91/11/19 16:17:12 BUCKLEY EXP $ C>RCS $LOG: RDCH.F,V $ C>RCS REVISION 1.10 91/11/19 16:17:12 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.9 89/06/30 13:29:01 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 13:39:38 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 14:26:49 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:44:39 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:30:09 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE READS THE INFORMATION FROM THE 'UNIT' INTO THE C ARRAY LIST USING DIRECT ACCESS UNFORMATTED INPUT. AFTER C READING EACH LINE, I.E. EACH RECORD, RECNO IS INCREMENTED BY 1. C THUS, ON RETURN, RECNO IS ONE MORE THAN THE NUMBER OF THE LAST C RECORD READ. C C UNIT - THE UNIT ON WHICH THE INFORMATION RESIDES. C LIST - THE ARRAY INTO WHICH THE INFORMATION IS TO BE READ. C NDATA - THE NUMBER OF ELEMENTS TO BE READ FROM UNIT. C NPERLN - THE MAXIMUM NUMBER OF ELEMENTS IN EACH RECORD OF UNIT. C RECNO - THE FIRST RECORD NUMBER ON UNIT FROM WHICH THE C INFORMATION CAN BE READ. C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZRDCH. C## S U B R O U T I N E S: MOD ... INTRINSIC C## P A R A M E T E R S: NONE ARE DEFINED. C## L O C A L D E C L: INTEGER I, J C## S A V E: NONE SELECTED. C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NONE ARE SET. C## E X E C U T I O N C## E X E C U T I O N I = 1 DO 100 J = 1, NDATA/NPERLN READ ( UNIT, REC = RECNO ) LIST( I: J * NPERLN) RECNO = RECNO + 1 I = I + NPERLN 100 CONTINUE IF ( MOD(NDATA, NPERLN) .NE. 0) THEN READ ( UNIT, REC = RECNO ) LIST( I: NDATA) RECNO = RECNO + 1 ENDIF GOTO 90000 C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZRDCH. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> rdinsg.f SUBROUTINE ZZRDIN ( UNIT, LIST, NDATA, NPERLN, RECNO ) C## A R G U M E N T S: INTEGER UNIT, LIST(*), NDATA, NPERLN, RECNO C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NOT REQUIRED. C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: RDIN.F,V 1.10 91/11/19 16:17:13 BUCKLEY EXP $ C>RCS $LOG: RDIN.F,V $ C>RCS REVISION 1.10 91/11/19 16:17:13 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.9 89/06/30 13:29:03 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 13:39:38 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 14:26:50 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:44:42 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:30:09 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE READS THE INFORMATION FROM THE 'UNIT' INTO THE C ARRAY LIST USING DIRECT ACCESS UNFORMATTED INPUT. AFTER C READING EACH LINE, I.E. EACH RECORD, RECNO IS INCREMENTED BY 1. C THUS, ON RETURN, RECNO IS ONE MORE THAN THE NUMBER OF THE LAST C RECORD READ. C C UNIT - THE UNIT ON WHICH THE INFORMATION RESIDES. C LIST - THE ARRAY INTO WHICH THE INFORMATION IS TO BE READ. C NDATA - THE NUMBER OF ELEMENTS TO BE READ FROM UNIT. C NPERLN - THE MAXIMUM NUMBER OF ELEMENTS IN EACH RECORD OF UNIT. C RECNO - THE FIRST RECORD NUMBER ON UNIT FROM WHICH THE C INFORMATION CAN BE READ. C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZRDIN. C## S U B R O U T I N E S: MOD ... INTRINSIC C## P A R A M E T E R S: NONE ARE DEFINED. C## L O C A L D E C L: INTEGER I, J, L C## S A V E: NONE SELECTED. C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NONE ARE SET. C## E X E C U T I O N C## E X E C U T I O N I = 1 DO 100 J = 1, NDATA/NPERLN READ ( UNIT, REC = RECNO ) ( LIST(L), L = I, J * NPERLN ) RECNO = RECNO + 1 I = I + NPERLN 100 CONTINUE IF ( MOD(NDATA, NPERLN) .NE. 0) THEN READ ( UNIT, REC = RECNO ) ( LIST(L), L = I, NDATA ) RECNO = RECNO + 1 ENDIF GOTO 90000 C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZRDIN. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> rdlgsg.f SUBROUTINE ZZRDLG ( UNIT, LIST, NDATA, NPERLN, RECNO ) C## A R G U M E N T S: INTEGER UNIT, NDATA, NPERLN, RECNO LOGICAL LIST(*) C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NOT REQUIRED. C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: RDLG.F,V 1.10 91/11/19 16:17:14 BUCKLEY EXP $ C>RCS $LOG: RDLG.F,V $ C>RCS REVISION 1.10 91/11/19 16:17:14 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.9 89/06/30 13:29:03 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 13:39:39 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 14:26:54 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:44:44 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:30:10 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE READS THE INFORMATION FROM THE 'UNIT' INTO THE C ARRAY LIST USING DIRECT ACCESS UNFORMATTED INPUT. AFTER C READING EACH LINE, I.E EACH RECORD, RECNO IS INCREMENTED BY 1. C THUS, ON RETURN, RECNO IS ONE MORE THAN THE NUMBER OF THE LAST C RECORD READ. C C UNIT - THE UNIT ON WHICH THE INFORMATION RESIDES. C LIST - THE ARRAY INTO WHICH THE INFORMATION IS TO BE READ. C NDATA - THE NUMBER OF ELEMENTS TO BE READ FROM UNIT. C NPERLN - THE MAXIMUM NUMBER OF ELEMENTS IN EACH RECORD OF UNIT. C RECNO - THE FIRST RECORD NUMBER ON UNIT FROM WHICH THE C INFORMATION CAN BE READ. C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZRDLG. C## S U B R O U T I N E S: MOD ... INTRINSIC C## P A R A M E T E R S: NONE ARE DEFINED. C## L O C A L D E C L: INTEGER I, J, L C## S A V E: NONE SELECTED. C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NONE ARE SET. C## E X E C U T I O N C## E X E C U T I O N I = 1 DO 100 J = 1, NDATA/NPERLN READ ( UNIT, REC = RECNO ) ( LIST(L), L = I, J * NPERLN ) RECNO = RECNO + 1 I = I + NPERLN 100 CONTINUE IF ( MOD(NDATA, NPERLN) .NE. 0) THEN READ ( UNIT, REC = RECNO ) ( LIST(L), L = I, NDATA ) RECNO = RECNO + 1 ENDIF GOTO 90000 C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZRDLG. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> rdrlsg.f SUBROUTINE ZZRDRL ( UNIT, LIST, NDATA, NPERLN, RECNO ) C## A R G U M E N T S: INTEGER UNIT, NDATA, NPERLN, RECNO REAL LIST(*) C!!!! DOUBLE PRECISION LIST(*) C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: RDRL.F,V 1.10 91/11/19 16:17:15 BUCKLEY EXP $ C>RCS $LOG: RDRL.F,V $ C>RCS REVISION 1.10 91/11/19 16:17:15 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.9 89/06/30 13:29:05 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 13:39:40 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 14:26:55 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:44:46 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:30:10 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE READS THE INFORMATION FROM 'UNIT' INTO THE C ARRAY LIST USING DIRECT ACCESS UNFORMATTED INPUT. AFTER C READING EACH LINE, I.E. EACH RECORD, RECNO IS INCREMENTED BY 1. C THUS, ON RETURN, RECNO IS ONE MORE THAN THE NUMBER OF THE LAST C RECORD READ. C C UNIT - THE UNIT ON WHICH THE INFORMATION RESIDES. C LIST - THE ARRAY INTO WHICH THE INFORMATION IS TO BE READ. C NDATA - THE NUMBER OF ELEMENTS TO BE READ FROM UNIT. C NPERLN - THE MAXIMUM NUMBER OF ELEMENTS IN EACH RECORD OF UNIT. C RECNO - THE FIRST RECORD NUMBER ON UNIT FROM WHICH THE C INFORMATION CAN BE READ. C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZRDRL. C## S U B R O U T I N E S: MOD ... INTRINSIC C## P A R A M E T E R S: NONE ARE DEFINED. C## L O C A L D E C L: INTEGER I, J, L C## S A V E: NONE SELECTED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NONE ARE SET. C## E X E C U T I O N C## E X E C U T I O N I = 1 DO 100 J = 1, NDATA/NPERLN READ ( UNIT, REC = RECNO ) ( LIST(L), L = I, J * NPERLN ) RECNO = RECNO + 1 I = I + NPERLN 100 CONTINUE IF ( MOD(NDATA, NPERLN) .NE. 0) THEN READ ( UNIT, REC = RECNO ) ( LIST(L), L = I, NDATA ) RECNO = RECNO + 1 ENDIF GOTO 90000 C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZRDRL. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> wmatsg.f SUBROUTINE ZZWMAT (SPACE, NAME, A, X, B, Y, - NRX, R1, R2, C1, C2, - F, W, D, S, LINE, UNIT ) C## A R G U M E N T S: CHARACTER *(*) NAME CHARACTER *1 F INTEGER NRX, R1, R2, C1, C2 INTEGER W, D, UNIT, LINE, S, SPACE REAL X(NRX,*), Y(NRX,*), A, B C!!!! DOUBLE PRECISION X(NRX,*), Y(NRX,*), A, B C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C>RCS $HEADER: WMAT.F,V 1.3 91/12/16 11:57:27 BUCKLEY EXP $ C>RCS $LOG: WMAT.F,V $ C>RCSREVISION 1.3 91/12/16 11:57:27 BUCKLEY C>RCSFIX FOR TOMS; ADD SPACE. C>RCS C>RCSREVISION 1.1 90/07/31 12:57:12 BUCKLEY C>RCSINITIAL REVISION C>RCS C## D E S C R I P T I O N: C PRINT OUT A SUBMATRIX OF A MATRIX WITH GIVEN FORMAT. C PRINT A TITLE FOR THE MATRIX: NAME C EACH OUTPUT LINE IS PRECEDED BY SPACE BLANK CHARACTERS. C PRINT THE VALUES FROM THE MATRIX A*X + B*Y C A AND B ARE SCALARS; X AND Y ARE VECTORS OR MATRICES. C THERE ARE ASSUMED TO BE NRX ROWS IN EACH MATRIX. C (USE 1 TO PRINT COLUMN VECTORS.) C PRINT FROM ROW R1 TO ROW R2, INCLUSIVE. C PRINT FROM COLUMN C1 TO COLUMN C2, INCLUSIVE. C PRINT EACH ENTRY IN FORMAT FW.D C ..F IS A CHARACTER 'F', 'G', 'E' OR 'D' C ..W AND D ARE INTEGERS C ..S IS THE NUMBER OF SPACES BETWEEN EACH ENTRY. C ..LINE IS THE NUMBER OF CHARACTERS PER LINE. C (IF LINE=0, THEN LINE IS REPLACED WITH 80) C ALL OUTPUT IS ON THE GIVEN UNIT. C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZWMAT. C## S U B R O U T I N E S: NONE ARE CALLED. C## P A R A M E T E R S: NONE ARE DEFINED. C## L O C A L D E C L: INTEGER I, J CHARACTER *100 FORM C## S A V E: NONE SELECTED. C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA FORM / '(??X,??(? ??.??, ?? X), ? ??.??)' / C E.G. (02X,05(F 09.04, 03 X), F 09.04) C 123456789012345678901234567890 C 1 2 3 C## E X E C U T I O N C## E X E C U T I O N IF ( LINE .EQ. 0 ) THEN LINE = 80 ENDIF IF ( SPACE .EQ. 0 ) THEN WRITE ( FORM(02:05), 99998 ) ' ' ELSE WRITE ( FORM(02:03), 99999 ) SPACE ENDIF WRITE ( FORM(06:07), 99999 ) 1+(LINE-SPACE-W)/(W+S) WRITE ( FORM(09:09), 99997 ) F WRITE ( FORM(11:12), 99999 ) W WRITE ( FORM(14:15), 99999 ) D WRITE ( FORM(18:19), 99999 ) S WRITE ( FORM(25:25), 99997 ) F WRITE ( FORM(27:28), 99999 ) W WRITE ( FORM(30:31), 99999 ) D IF ( SPACE .NE. 0 ) THEN WRITE ( UNIT, 99998 ) (' ',I=1,SPACE),NAME ELSE WRITE ( UNIT, 99998 ) NAME ENDIF DO 1000 I = R1, R2 IF ( SPACE .NE. 0 ) THEN WRITE ( UNIT, FORM ) SPACE,(A*X(I,J)+B*Y(I,J),J=C1,C2) ELSE WRITE ( UNIT, FORM ) ( A*X(I,J)+B*Y(I,J), J=C1, C2) ENDIF 1000 CONTINUE C## E X I T 90000 RETURN C## F O R M A T S: SEE CHARACTER STRING FORM. 99997 FORMAT (A1) 99998 FORMAT (A) 99999 FORMAT (I2) C E N D OF WMAT. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> wrchsg.f SUBROUTINE ZZWRCH ( UNIT, LIST, NDATA, NPERLN, RECNO ) C## A R G U M E N T S: INTEGER UNIT, NDATA, NPERLN, RECNO CHARACTER *(*) LIST C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NOT REQUIRED. C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: WRCH.F,V 1.10 91/11/19 16:19:01 BUCKLEY EXP $ C>RCS $LOG: WRCH.F,V $ C>RCS REVISION 1.10 91/11/19 16:19:01 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.9 89/06/30 13:29:09 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 13:39:43 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 14:26:59 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:44:52 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:30:11 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE WRITES THE INFORMATION IN THE ARRAY LIST INTO THE C TEMPORARY 'UNIT' USING DIRECT ACCESS UNFORMATTED OUTPUT. AFTER C WRITING EACH LINE, I.E. RECORD, RECNO IS INCREMENTED BY 1. THUS, C ON RETURN, RECNO IS ONE MORE THAN THE NUMBER IF THE LAST RECORD C WRITTEN. C C UNIT - THE UNIT ON WHICH THE INFORMATION IS TO BE WRITTEN. C LIST - THE ARRAY WHICH CONTAINS THE INFORMATION. C NDATA - THE NUMBER OF ELEMENTS IN LIST. C NPERLN - THE MAXIMUM NUMBER OF ELEMENTS ALLOWED FOR EACH RECORD. C RECNO - THE FIRST RECORD NUMBER INTO WHICH THE DATA IS TO BE C WRITTEN. C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZWRCH. C## S U B R O U T I N E S: MOD ... INTRINSIC C## P A R A M E T E R S: NONE ARE DEFINED. C## L O C A L D E C L: INTEGER I, J C## S A V E: NONE SELECTED. C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NONE ARE SET. C## E X E C U T I O N C## E X E C U T I O N I = 1 DO 100 J = 1, NDATA/NPERLN WRITE ( UNIT, REC = RECNO ) LIST( I: J * NPERLN) RECNO = RECNO + 1 I = I + NPERLN 100 CONTINUE IF ( MOD(NDATA, NPERLN) .NE. 0) THEN WRITE ( UNIT, REC = RECNO ) LIST(I: NDATA) RECNO = RECNO + 1 ENDIF GOTO 90000 C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZWRCH. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> wrinsg.f SUBROUTINE ZZWRIN ( UNIT, LIST, NDATA, NPERLN, RECNO ) C## A R G U M E N T S: INTEGER UNIT, LIST(*), NDATA, NPERLN, RECNO C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NOT REQUIRED. C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: WRIN.F,V 1.10 91/11/19 16:19:02 BUCKLEY EXP $ C>RCS $LOG: WRIN.F,V $ C>RCS REVISION 1.10 91/11/19 16:19:02 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.9 89/06/30 13:29:10 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 13:39:44 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 14:27:00 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:44:54 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:30:11 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE WRITES THE INFORMATION IN THE ARRAY LIST INTO THE C TEMPORARY 'UNIT' USING DIRECT ACCESS UNFORMATTED OUTPUT. AFTER C WRITING EACH LINE, I.E. RECORD, RECNO IS INCREMENTED BY 1. THUS, C ON RETURN, RECNO IS ONE MORE THAN THE NUMBER IF THE LAST RECORD C WRITTEN. C C UNIT - THE UNIT ON WHICH THE INFORMATION IS TO BE WRITTEN. C LIST - THE ARRAY WHICH CONTAINS THE INFORMATION. C NDATA - THE NUMBER OF ELEMENTS IN LIST. C NPERLN - THE MAXIMUM NUMBER OF ELEMENTS ALLOWED FOR EACH RECORD. C RECNO - THE FIRST RECORD NUMBER INTO WHICH THE DATA IS TO BE C WRITTEN. C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZWRIN. C## S U B R O U T I N E S: MOD ... INTRINSIC C## P A R A M E T E R S: NONE ARE DEFINED. C## L O C A L D E C L: INTEGER I, J, L C## S A V E: NONE SELECTED. C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NONE ARE SET. C## E X E C U T I O N C## E X E C U T I O N I = 1 DO 100 J = 1, NDATA/NPERLN WRITE ( UNIT, REC = RECNO ) (LIST(L), L = I, J * NPERLN) RECNO = RECNO + 1 I = I + NPERLN 100 CONTINUE IF ( MOD(NDATA, NPERLN) .NE. 0) THEN WRITE ( UNIT, REC = RECNO ) (LIST(L), L = I, NDATA) RECNO = RECNO + 1 ENDIF GOTO 90000 C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZWRIN. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> wrlgsg.f SUBROUTINE ZZWRLG ( UNIT, LIST, NDATA, NPERLN, RECNO ) C## A R G U M E N T S: INTEGER UNIT, NDATA, NPERLN, RECNO LOGICAL LIST(*) C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NOT REQUIRED. C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: WRLG.F,V 1.10 91/11/19 16:19:03 BUCKLEY EXP $ C>RCS $LOG: WRLG.F,V $ C>RCS REVISION 1.10 91/11/19 16:19:03 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.9 89/06/30 13:29:11 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 13:39:45 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 14:27:01 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:45:04 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:30:11 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE WRITES THE INFORMATION IN THE ARRAY LIST INTO THE C TEMPORARY 'UNIT' USING DIRECT ACCESS UNFORMATTED OUTPUT. AFTER C WRITING EACH LINE, I.E. RECORD, RECNO IS INCREMENTED BY 1. THUS, C ON RETURN, RECNO IS ONE MORE THAN THE NUMBER IF THE LAST RECORD C WRITTEN. C C UNIT - THE UNIT ON WHICH THE INFORMATION IS TO BE WRITTEN. C LIST - THE ARRAY WHICH CONTAINS THE INFORMATION. C NDATA - THE NUMBER OF ELEMENTS IN LIST. C NPERLN - THE MAXIMUM NUMBER OF ELEMENTS ALLOWED FOR EACH RECORD. C RECNO - THE FIRST RECORD NUMBER INTO WHICH THE DATA IS TO BE C WRITTEN. C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZWRLG. C## S U B R O U T I N E S: MOD ... INTRINSIC C## P A R A M E T E R S: NONE ARE DEFINED. C## L O C A L D E C L: INTEGER I, J, L C## S A V E: NONE SELECTED. C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NONE ARE SET. C## E X E C U T I O N C## E X E C U T I O N I = 1 DO 100 J = 1, NDATA/NPERLN WRITE ( UNIT, REC = RECNO ) (LIST(L), L = I, J * NPERLN) RECNO = RECNO + 1 I = I + NPERLN 100 CONTINUE IF ( MOD(NDATA, NPERLN) .NE. 0) THEN WRITE ( UNIT, REC = RECNO ) (LIST(L), L = I, NDATA) RECNO = RECNO + 1 ENDIF GOTO 90000 C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZWRLG. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> wrrlsg.f SUBROUTINE ZZWRRL ( UNIT, LIST, NDATA, NPERLN, RECNO ) C## A R G U M E N T S: INTEGER UNIT, NDATA, NPERLN, RECNO REAL LIST(*) C!!!! DOUBLE PRECISION LIST(*) C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: WRRL.F,V 1.10 91/11/19 16:19:05 BUCKLEY EXP $ C>RCS $LOG: WRRL.F,V $ C>RCS REVISION 1.10 91/11/19 16:19:05 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.9 89/06/30 13:29:12 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 13:39:45 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 14:27:02 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:45:07 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:30:12 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE WRITES THE INFORMATION IN THE ARRAY LIST INTO THE C TEMPORARY 'UNIT' USING DIRECT ACCESS UNFORMATTED OUTPUT. AFTER C WRITING EACH LINE, I.E. RECORD, RECNO IS INCREMENTED BY 1. THUS, C ON RETURN, RECNO IS ONE MORE THAN THE NUMBER IF THE LAST RECORD C WRITTEN. C C UNIT - THE UNIT ON WHICH THE INFORMATION IS TO BE WRITTEN. C LIST - THE ARRAY WHICH CONTAINS THE INFORMATION. C NDATA - THE NUMBER OF ELEMENTS IN LIST. C NPERLN - THE MAXIMUM NUMBER OF ELEMENTS ALLOWED FOR EACH RECORD. C RECNO - THE FIRST RECORD NUMBER INTO WHICH THE DATA IS TO BE C WRITTEN. C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZWRRL. C## S U B R O U T I N E S: MOD ... INTRINSIC C## P A R A M E T E R S: NONE ARE DEFINED. C## L O C A L D E C L: INTEGER I, J, L C## S A V E: NONE SELECTED. C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NONE ARE SET. C## E X E C U T I O N C## E X E C U T I O N I = 1 DO 100 J = 1, NDATA/NPERLN WRITE ( UNIT, REC = RECNO ) (LIST(L), L = I, J * NPERLN) RECNO = RECNO + 1 I = I + NPERLN 100 CONTINUE IF ( MOD(NDATA, NPERLN) .NE. 0) THEN WRITE ( UNIT, REC = RECNO ) (LIST(L), L = I, NDATA) RECNO = RECNO + 1 ENDIF GOTO 90000 C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZWRRL. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> addpsg.f SUBROUTINE ZZADDP ( ADD, NAMES, NUMBRS, NUMBER, LIST, - LISTNO, LISTMX, PRECNO, PFNAMS, PROBNO, - GROUPS, GNAMES, NGRPS, MEMBS, * ) C## A R G U M E N T S: INTEGER NUMBER, LISTMX, LISTNO, PROBNO, NGRPS INTEGER LIST(*), PRECNO(3,PROBNO), GROUPS(*), MEMBS(*) LOGICAL ADD CHARACTER*(*) NAMES(*), PFNAMS, GNAMES REAL NUMBRS(*) C!!!! DOUBLE PRECISION NUMBRS(*) C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C C SYSTEM DEPENDENCE: NONE C C>RCS $HEADER: ADDP.F,V 1.10 91/11/20 10:52:35 BUCKLEY EXP $ C>RCS $LOG: ADDP.F,V $ C>RCS REVISION 1.10 91/11/20 10:52:35 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.9 89/06/30 13:38:10 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 16:42:28 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 12:20:12 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:46:53 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:50:05 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE IS RESPONSIBLE FOR ADDING A PROBLEM, OR A COLLECTION C OF PROBLEMS, TO THE CURRENT LIST OF PROBLEMS TO BE EXECUTED. THE C PROBLEMS MAY BE DROPPED FROM THE LIST AS WELL. IT IS POSSIBLE C TO SPECIFY A SINGLE PROBLEM, OR ALL PROBLEMS USING A PARTICULAR C FUNCTION, OR ALL PROBLEMS IN A PREDEFINED GROUP. THE ARGUMENTS C HAVE THE FOLLOWING MEANINGS. C C ADD A FLAG: IF TRUE ADD THE PROBLEMS; OTHERWISE DROP THEM. C C NAMES THE ARRAY OF NAMES TO ADD OR DROP. C NUMBRS THE ARRAY OF NUMBERS TO ADD OR DROP. C NUMBER THE NUMBER OF ENTRIES IN NAMES AND NUMBRS. C C THE FORMAT OF THESE TWO ARRAYS IS AS FOLLOWS : C C THE I-TH ENTRY OF NAMES CORRESPONDS TO THE I-TH ENTRY C OF NUMBRS. IF THE NAME IS BLANK, THEN IT IS ASSUMED C THAT NUMBR CONTAINS THE NUMBER OF A PROBLEM TO ADD OR C DROP. IF IT IS NONBLANK AND CONTAINS NO '/' (I.E. THE C 'RADIX' CHARACTER) IT IS ASSUMED THAT IT CONTAINS THE C NAME OF AN ENTITY TO ADD OR DROP. (THIS IS ALSO TRUE IF C THE '/' IS THE LAST NONBLANK CHARACTER.) IF IT CONTAINS C A '/' IN THE FIRST POSITION, THEN THE ARRAY NUMBR MUST C CONTAIN THE NUMBER OF THE ENTITY TO BE DROPPED OR C ADDED, AND THE CHARACTER FOLLOWING THE '/' INDICATES C THE TYPE OF THE ENTITY, I.E. 'P' FOR A PROBLEM, 'G' C FOR A GROUP, OR 'F' FOR A FUNCTION. IN THE REMAINING C CASE IT IS TAKEN THAT A NAME IS GIVEN FOR THE ENTITY C AND THAT THE ENTITY IDENTIFIER FOLLOWS THE SLASH. C C LIST THE CURRENT LIST OF PROBLEMS. C LISTNO THE NUMBER OF ENTRIES CURRENTLY IN LIST. C LISTMX THE NUMBER OF ELEMENTS ALLOWED IN LIST. C C PRECNO AN ARRAY CONTAINING INFOMATION ABOUT EACH PROBLEM IN C PROLOG. FOR EACH PROBLEM, THERE ARE 3 ENTRIES. THE C FIRST GIVES THE RECORD NUMBER IN DAUF WHERE THE PROBLEM C MAY BE FOUND. THE SECOND GIVES THE DIMENSION OF THE C PROBLEM AND THE THIRD GIVES THE NUMBER OF THE FUNCTION C USED BY THIS PROBLEM. C PFNAMS AN ARRAY GIVING THE NAME FOR EACH PROBLEM, AS WELL AS C THE NAME OF THE FUNCTION USED BY THE PROBLEM. C PROBNO THE TOTAL NUMBER OF PROBLEMS DEFINED. C C GROUPS AN ARRAY WHICH GIVES THE RECORD NUMBER IN DAUF WHERE C EACH GROUP MAY BE FOUND. C GNAMES A CHARACTER STRING GIVING THE NAME OF EACH GROUP. C NGRPS THE NUMBER OF GROUPS POSSIBLE. C MEMBS A DUMMY ARRAY WHOSE SIZE IS THE MAXIMUM NUMBER OF C PROBLEMS PER GROUP C C * AN ERROR RETURN. C C## E N T R Y P O I N T S: ZZADDP THE NATURAL ENTRY POINT. C ZZASET DEFINE SPECIAL RADIX CHARS. C C## S U B R O U T I N E S: C C INDEX, REAL(DBLE), NINT ...GENERIC C C ZZLENG NON-BLANK LENGTH OF A STRING C ZZERRM ERROR MESSAGES C ZZGETG GETS GROUP OF PROBLEMS FROM DAUF C ZZSRCH SEARCHES A DICTIONARY C C RD... STATEMENT FUNCTION C C## P A R A M E T E R S: LOGICAL T, F PARAMETER ( T = .TRUE., F = .FALSE. ) CHARACTER*(*) TRUE, QT, FALSE, QF PARAMETER ( TRUE = 'TRUE', QT = 'T', FALSE = 'FALSE', QF = 'F' ) INTEGER ITRUE, IFALSE PARAMETER ( ITRUE = 1, IFALSE = 0 ) REAL RTRUE, RFALSE C!!!! DOUBLE PRECISION RTRUE, RFALSE PARAMETER ( RTRUE = 1.D0, RFALSE = 0.D0 ) INTEGER CTOUPP, CTOLOW, CTOCAP PARAMETER ( CTOUPP = 1, CTOLOW = 2, CTOCAP = 3 ) CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) CHARACTER*(*) PERIOD, COMMA, SEMICN PARAMETER ( PERIOD = '.', COMMA = ',', SEMICN = ';' ) CHARACTER*(*) COLON, DASH, EQUALS PARAMETER ( COLON = ':', DASH = '-', EQUALS = '=' ) CHARACTER*(*) OBRACE, CBRACE, UNDERS PARAMETER ( OBRACE = '{', CBRACE = '}', UNDERS = '_' ) CHARACTER*(*) PLUS, MINUS, EXCLAM PARAMETER ( PLUS = '+', MINUS = '-', EXCLAM = '!' ) CHARACTER*(*) GTHAN, LTHAN, QUESMK PARAMETER ( GTHAN = '>', LTHAN = '<', QUESMK = '?' ) CHARACTER*(*) SLASH, BSLASH, PERCNT PARAMETER ( SLASH = '/', BSLASH = '\\',PERCNT = '%' ) CHARACTER*(*) CARAT, ATSIGN, TILDE PARAMETER ( CARAT = '^', ATSIGN = '@', TILDE = '~' ) C-----I/O UNIT NUMBERS INTEGER PREPRC, DAUF, INPTUN PARAMETER ( PREPRC = 1, DAUF = 2, INPTUN = 3 ) INTEGER TEMPUN, STDIN, TRMOUT PARAMETER ( TEMPUN = 4, STDIN = 5, TRMOUT = 6 ) INTEGER WRITUN, TRACUN, SUMMUN PARAMETER ( WRITUN = 7, TRACUN = 8, SUMMUN = 9 ) INTEGER COPYUN, TEXUN PARAMETER ( COPYUN =10, TEXUN =11 ) C-----STRING LENGTHS INTEGER PNAMLN, FNAMLN, GNAMLN PARAMETER ( PNAMLN = 8, FNAMLN = PNAMLN, GNAMLN = PNAMLN ) INTEGER TITLEN, PDESCL PARAMETER ( TITLEN = 72, PDESCL = 72 ) C-----CLASSES AND MODES OF PROBLEM REQUESTS. INTEGER PROBS, FUNCS, GRPS, ANY PARAMETER ( PROBS = 1, FUNCS = 2, GRPS = 3, ANY = 4 ) INTEGER BYNAME, BYNUMB PARAMETER ( BYNAME = 1, BYNUMB = 2 ) C-----ROW NUMBER FOR RECORD NUMBER, DIMENSION AND FUNCTION NUMBER. C DEFINITIONS OF THE ROWS IN THE ARRAY PRECNO. ( PRECNO HOLDS THE C RECORD NUMBER IN THE DAUF FILE, THE MINIMUM DIMENSION, AND THE C FUNCTION NUMBER OF EACH PROBLEM. ) INTEGER RECN, DIMN, FNO1 PARAMETER ( RECN = 1, DIMN = 2, FNO1 = 3 ) C-----DEFAULT VALUES FOR SPECIAL RADIX CHARACTERS. CHARACTER *(*) DRAD, DRADP, DRADF, DRADG PARAMETER ( DRAD= '/', DRADP= 'P', DRADF= 'F', DRADG= 'G' ) C-----ERROR MESSAGES. CHARACTER *(PNAMLN) NAME CHARACTER *(*) ERR1, ERR2, ERR3, ERR4, ERR5, ERR6 PARAMETER ( ERR1 = ' CAN''T FIND PROBLEM ' , - ERR2 = ' CAN''T FIND FUNCTION ' , - ERR3 = ' CAN''T FIND GROUP ' , - ERR4 = ' CAN''T FIND PROBLEM, FUNCTION OR GROUP ', - ERR5 = ' PROBLEM CAPACITY EXCEEDED', - ERR6 = ' LIST ALREADY CONTAINS PROBLEM') CHARACTER *(*) NMD, NUM PARAMETER ( NMD = ' NAMED ', NUM = ' #' ) C## L O C A L D E C L: C-----CHARACTERS WHICH SIGNIFY PROBLEMS AND GROUPS. CHARACTER*1 RADIX, RADPRB, RADFUN, RADGRP CHARACTER*1 SRADIX, SRADP, SRADF, SRADG C-----FUNCTION DECLARATION. INTEGER ZZLENG C-----LOCAL VARIABLES. INTEGER CLASS, MODE, PNUMB, IMARK INTEGER COUNT, LEFT, LOC, SIZE INTEGER I, J, K INTEGER ERRFLG LOGICAL DROP, FOUND, TRY CHARACTER * 1 CH REAL RD C!!!! DOUBLE PRECISION RD C## S A V E: SAVE RADIX, RADPRB, RADFUN, RADGRP C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA RADIX/DRAD/, RADPRB/DRADP/, RADGRP/DRADG/, RADFUN/DRADF/ C## E X E C U T I O N C## E X E C U T I O N C-----DEFINE FUNCTION STATEMENT. RD(I) = REAL(I) C!!!! RD(I) = DBLE(I) C-----NOW EXECUTE. DROP = .NOT. ADD LEFT = LISTNO COUNT = 0 C-----LOOP THOUGH EACH PROBLEM. 1000 FOUND = F IF ( COUNT .LT. NUMBER ) THEN C CONTINUE THE LOOP. COUNT = COUNT + 1 ELSE C 109 FINISHED, SO EXIT, BUT FIRST... IF ( DROP .AND. LEFT .NE. LISTNO ) THEN C COMPRESS OUT THE -1 ENTRIES. I = 0 J = 0 1100 J = J+1 IF ( J .LE. LISTNO ) THEN IF ( LIST(J) .EQ. -1 ) THEN GOTO 1100 ENDIF I = I + 1 LIST(I) = LIST(J) GOTO 1100 ENDIF LISTNO = LEFT ENDIF GOTO 90000 ENDIF C-----DETERMINE CLASS AND MODE OF PROBLEM STATEMENT. IF ( NAMES (COUNT) .EQ. BLANK ) THEN CLASS = PROBS MODE = BYNUMB PNUMB = NINT ( NUMBRS(COUNT) ) ELSE IMARK = INDEX ( NAMES(COUNT), RADIX ) IF ( IMARK .EQ. 0 .OR. IMARK .EQ. ZZLENG(NAMES(COUNT)) ) THEN CLASS = ANY MODE = BYNAME ELSE IF ( IMARK .EQ. 1 ) THEN MODE = BYNUMB ELSE MODE = BYNAME ENDIF CH = NAMES(COUNT) ( IMARK+1:IMARK+1 ) CALL ZZCASE( CH, CTOUPP ) IF ( CH .EQ. RADPRB ) THEN CLASS = PROBS ELSE IF ( CH .EQ. RADFUN ) THEN CLASS = FUNCS ELSE IF ( CH .EQ. RADGRP ) THEN CLASS = GRPS ELSE CLASS = ANY ENDIF ENDIF IF ( MODE .EQ. BYNAME ) THEN IF ( IMARK .EQ. 0 ) THEN NAME = NAMES(COUNT) ELSE NAME = NAMES(COUNT) (1:IMARK-1) ENDIF CALL ZZCASE(NAME,CTOUPP) PNUMB = 0 ELSE PNUMB = NINT( NUMBRS(COUNT) ) NAME = BLANK ENDIF ENDIF C-----FIRST TRY TO FIND THE NAME OR NUMBER GIVEN AS A PROBLEM. IF ( CLASS .EQ. PROBS .OR. CLASS .EQ. ANY ) THEN IF ( MODE .EQ. BYNUMB ) THEN IF ( PNUMB .GE. 1 .AND. PNUMB .LE. PROBNO ) THEN IF ( PRECNO(RECN,PNUMB) .NE. -1 ) THEN IF ( DROP ) THEN DO 1140 I = 1,LISTNO IF ( LIST(I) .EQ. PNUMB ) THEN FOUND = T LIST(I) = -1 LEFT = LEFT -1 GOTO 1145 ENDIF 1140 CONTINUE 1145 CONTINUE ELSEIF ( LISTNO .LT. LISTMX ) THEN FOUND = T DO 1147 K = 1, LISTNO IF ( PNUMB .EQ. LIST(K) ) THEN CALL ZZERRM( RD(PNUMB), *91000, - 'IT'//ERR6//NUM ) GOTO 1148 ENDIF 1147 CONTINUE LISTNO = LISTNO + 1 LIST( LISTNO ) = PNUMB 1148 CONTINUE ELSE GOTO 80000 ENDIF ENDIF ENDIF ELSE C ---NAMED PROBLEM... DO 1160 PNUMB = 1, PROBNO IF ( PRECNO(RECN,PNUMB) .GT. 0 ) THEN LOC = PNUMB * PNAMLN * 2 - PNAMLN IF ( PFNAMS(LOC-PNAMLN+1:LOC) .EQ. NAME ) THEN IF ( DROP ) THEN DO 1150 I = 1,LISTNO IF ( LIST(I) .EQ. PNUMB ) THEN LIST(I) = -1 FOUND = T LEFT = LEFT -1 GOTO 1180 ENDIF 1150 CONTINUE C ...NOT DROP SO ADD... ELSEIF ( LISTNO .LT. LISTMX ) THEN FOUND = T DO 1155 K = 1, LISTNO IF ( PNUMB .EQ. LIST(K) ) THEN CALL ZZERRM ( RD(I), *91000, - 'NT'//ERR6//NMD//NAME ) GOTO 1156 ENDIF 1155 CONTINUE LISTNO = LISTNO + 1 LIST( LISTNO ) = PNUMB 1156 CONTINUE ELSE GOTO 80000 ENDIF ENDIF ENDIF 1160 CONTINUE 1180 CONTINUE ENDIF C ...FOR NAME OR NUMBER. ENDIF C ...FOR CLASS = PROBS. IF ( .NOT. FOUND .AND. CLASS .EQ. PROBS ) THEN IF ( MODE .EQ. BYNUMB ) THEN CALL ZZERRM (RD(PNUMB),*91000,'IT'//ERR1//NUM) ELSE CALL ZZERRM ( RD(I), *91000,'NT'//ERR1//NMD//NAME) ENDIF ENDIF C-----TRY TO FIND THE NAME OR NUMBER SPECIFIED AS A FUNCTION. IF ( CLASS .EQ. FUNCS .OR. ( CLASS .EQ. ANY - .AND. .NOT. FOUND ) ) THEN C CHECK EACH PROBLEM. DO 1210 I = 1, PROBNO IF ( PRECNO(RECN,I) .NE. -1 ) THEN IF ( MODE .EQ. BYNAME ) THEN LOC = I * PNAMLN * 2 TRY = PFNAMS(LOC-PNAMLN+1:LOC) .EQ. NAME ELSE TRY = PRECNO(FNO1,I) .EQ. PNUMB ENDIF IF ( TRY ) THEN IF ( DROP ) THEN DO 1200 J = 1,LISTNO IF ( LIST(J) .EQ. I ) THEN FOUND = T LIST(J) = -1 LEFT = LEFT - 1 GOTO 1210 ENDIF 1200 CONTINUE ELSEIF ( LISTNO .GE. LISTMX ) THEN GOTO 80000 ELSE FOUND = T DO 1205 K = 1, LISTNO IF ( I .EQ. LIST(K) ) THEN CALL ZZERRM( RD(I), *91000, 'IT'//ERR6//NUM ) GOTO 1206 ENDIF 1205 CONTINUE LISTNO = LISTNO + 1 LIST( LISTNO ) = I 1206 CONTINUE ENDIF C FOR THE "IF ADD OR DROP..." ENDIF C FOR THE "IF TRY..." ENDIF 1210 CONTINUE IF ( .NOT. FOUND .AND. CLASS .EQ. FUNCS ) THEN IF ( MODE .EQ. BYNAME ) THEN CALL ZZERRM ( RD(I), *91000,'NT'//ERR2//NMD//NAME) ELSE CALL ZZERRM ( RD(PNUMB), * 91000, 'IT'// ERR2 // NUM ) ENDIF ENDIF ENDIF C-----TRY TO FIND THE NAME SPECIFIED AS A GROUP. IF ( CLASS .EQ. GRPS .OR. - ( CLASS .EQ. ANY .AND. .NOT. FOUND ) ) THEN IF ( MODE .EQ. BYNUMB ) THEN IF ( PNUMB .GT. 0 .AND. PNUMB .LE. NGRPS ) THEN IF ( GROUPS(PNUMB) .NE. -1 ) THEN FOUND = T LOC = GNAMLN * PNUMB NAME = GNAMES(LOC-GNAMLN+1:LOC) ENDIF ENDIF ELSE C NAMED GROUP SO SEARCH FOR IT PNUMB = 1 CALL ZZSRCH(NAME,GNAMLN,GNAMES,NGRPS,GNAMLN,PNUMB, F, T) FOUND = PNUMB .NE. 0 ENDIF IF ( .NOT. FOUND .AND. CLASS .EQ. GRPS ) THEN IF ( MODE .EQ. BYNUMB ) THEN CALL ZZERRM ( RD(PNUMB), * 91000, 'IT'// ERR3 // NUM ) ELSE CALL ZZERRM ( RD(PNUMB), * 91000, 'NT'//ERR3//NMD//NAME ) ENDIF ENDIF 2100 IF ( FOUND ) THEN C ADD A GROUP OF PROBLEMS. CALL ZZGETG ( DAUF, PNUMB, NAME, SIZE, MEMBS, GNAMES, - GROUPS, ERRFLG, *91000 ) IF ( ERRFLG .EQ. 0 ) THEN IF ( ADD ) THEN DO 2200 I = 1, SIZE DO 2150 K = 1, LISTNO IF ( MEMBS(I) .EQ. LIST(K) ) THEN CALL ZZERRM ( RD(MEMBS(I)), *91000, - 'IT'//ERR6//NUM ) GOTO 2160 ENDIF 2150 CONTINUE IF ( LISTNO .GE. LISTMX ) THEN GOTO 80000 ELSE LISTNO = LISTNO + 1 LIST( LISTNO ) = MEMBS(I) ENDIF 2160 CONTINUE 2200 CONTINUE ELSE DO 4000 I = 1, SIZE DO 3500 J = 1, LISTNO IF ( LIST(J) .EQ. MEMBS(I) ) THEN LIST(J) = -1 LEFT = LEFT -1 GOTO 3600 ENDIF 3500 CONTINUE 3600 CONTINUE 4000 CONTINUE ENDIF ENDIF ENDIF ENDIF C-----FLAG ERROR IF NOT FOUND SOMEWHERE. IF ( .NOT. FOUND .AND. CLASS .EQ. ANY ) THEN IF ( MODE .EQ. BYNUMB ) THEN CALL ZZERRM ( RD(PNUMB), * 91000, 'IT'// ERR4 // NUM ) ELSE CALL ZZERRM ( RD(PNUMB), * 91000, 'NT'//ERR4//NMD//NAME) ENDIF ENDIF GOTO 1000 C## E N T R Y ZZASET: ENTRY ZZASET ( SRADIX, SRADP, SRADF, SRADG ) RADIX = SRADIX RADPRB = SRADP RADFUN = SRADF RADGRP = SRADG RETURN C## E R R O R S: 80000 IF ( MODE .EQ. BYNUMB ) THEN CALL ZZERRM ( RD(PNUMB), *91000, 'IT'// ERR5//NUM ) ELSE CALL ZZERRM ( RD(PNUMB), * 91000, 'NT'//ERR5//NMD//NAME) ENDIF GOTO 90000 C## E X I T 90000 RETURN C----- ERROR RETURN. 91000 RETURN 1 C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZADDP. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> aftrsg.f SUBROUTINE ZZAFTR ( TESTCH, STATUS, SUBR, WRTSUM, SEELVL, WRITFL, - IW, RW, DW ) C## A R G U M E N T S: LOGICAL WRTSUM, WRITFL INTEGER SUBR, SEELVL, STATUS, IW(*) CHARACTER * 1 TESTCH REAL RW(*) DOUBLE PRECISION DW(*) C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NOT REQUIRED. C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: AFTR.F,V 1.10 91/11/20 10:52:36 BUCKLEY EXP $ C>RCS $LOG: AFTR.F,V $ C>RCS REVISION 1.10 91/11/20 10:52:36 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.9 89/06/30 13:38:12 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 16:42:29 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 12:20:15 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:46:59 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:50:06 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C JUST LIKE ZZBFOR IS CALLED JUST BEFORE FINDING THE MINIMUM OF C ONE OF THE GIVEN PROBLEMS, THIS IS CALLED JUST AFTER THE MINIMUM C HAS BEEN FOUND. C C PARAMETER DESCRIPTION: C C TESTCH - USED IN THE TEMPUN FILE TO FLAG DATA TO BE PROCESSED C IN ZZSMRY. C STATUS - SAME AS IN ZZLINK, SEE THAT SUBROUTINE FOR C DESCRIPTION. C SUBR - THE NUMBER OF THE SUBROUTINE BEING USED. C WRTSUM - COPY SUMMARY TO WRITE UNIT IF TRUE. C SEELEV - CONTROLS THE AMOUNT OF SUMMARY DATA SHOWN ON THE C SCREEN (IT TAKES ON AN INTEGER VALUE FROM 1 TO 4). C WRITFL - COPY OUTPUT OF THE TEST TO THE WRITE UNIT IF TRUE. C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZAFTR. C## S U B R O U T I N E S: BBVGET GET SPECIAL COUNTS FROM BBLNIR. C C## P A R A M E T E R S: C----- DEFINITION OF THE I/O UNITS. INTEGER PREPRC, DAUF, INPTUN PARAMETER ( PREPRC = 1, DAUF = 2, INPTUN = 3 ) INTEGER TEMPUN, STDIN, TRMOUT PARAMETER ( TEMPUN = 4, STDIN = 5, TRMOUT = 6 ) INTEGER WRITUN, TRACUN, SUMMUN PARAMETER ( WRITUN = 7, TRACUN = 8, SUMMUN = 9 ) INTEGER COPYUN, TEXUN PARAMETER ( COPYUN =10, TEXUN =11 ) C----- DEFINITION OF SEELEV VALUES INTEGER CNONE, CMIN, CMED, CFULL PARAMETER ( CNONE = 1, CMIN = 2, CMED = 3, CFULL = 4 ) C----- DEFINITION OF STATUS CODES. C--ON ENTRY: INTEGER CNORML, CRCSTR, CRCRPT, CRCNFG PARAMETER ( CNORML = 0, CRCSTR = 1, CRCRPT = 2, CRCNFG = 3 ) INTEGER CNRMFG, CPSTHR PARAMETER ( CNRMFG = -1, CPSTHR = -2 ) C--ON EXIT: INTEGER CDONE, CRCF, CRCFG, CRCG PARAMETER ( CDONE = 0, CRCF = 1, CRCFG = 2, CRCG = 3 ) INTEGER CNSTOR, CIPMIN, CIPUNF, CBDMTH PARAMETER ( CNSTOR = -1, CIPMIN = -2, CIPUNF = -3, CBDMTH = -4 ) INTEGER CLSFAL, CNODSC, CXSFNC, CPSBCK PARAMETER ( CLSFAL = -5, CNODSC = -6, CXSFNC = -7, CPSBCK = -8 ) INTEGER CRABRT, CUSERV PARAMETER ( CRABRT = -9, CUSERV = -10 ) C## L O C A L D E C L: C----- DECLARATIONS FOR BBLNIR. INTEGER RSTART, UPDATE, FORCE C## S A V E: NONE SELECTED. C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NONE ARE SET. C## E X E C U T I O N C## E X E C U T I O N GOTO ( 1000, 2000 ) SUBR C-----FOR BBLNIR. 1000 CALL BBVGET ( RSTART, UPDATE, FORCE ) WRITE ( TEMPUN, * ) RSTART, UPDATE, FORCE GOTO 90000 C-----NOTHING TO DO FOR SHANNO'S ROUTINE CONMIN. 2000 GOTO 90000 C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZAFTR. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> bforsg.f SUBROUTINE ZZBFOR ( TESTCH, STATUS, SUBR, WRTSUM, SEELVL, WRITFL, - IW, RW, DW ) C## A R G U M E N T S: LOGICAL WRTSUM, WRITFL INTEGER SUBR, SEELVL, STATUS, IW(*) CHARACTER * 1 TESTCH REAL RW(*) DOUBLE PRECISION DW(*) C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NOT REQUIRED. C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: BFOR.F,V 1.10 91/11/20 10:52:37 BUCKLEY EXP $ C>RCS $LOG: BFOR.F,V $ C>RCS REVISION 1.10 91/11/20 10:52:37 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.9 89/06/30 13:38:12 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 16:42:30 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 12:20:16 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:47:03 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:50:06 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE IS CALLED JUST BEFORE RUNNING EACH TEST PROBLEM. C THIS ALLOWS FOR OUTPUT OF ANY SPECIAL USER INFORMATION. C C PARAMETER DESCRIPTION: C C TESTCH - USED IN THE TEMPUN FILE TO FLAG DATA TO BE PROCESSED C IN ZZSMRY. C STATUS - SAME AS IN ZZINK, SEE THAT SUBROUTINE FOR C DESCRIPTION. C SUBR - THE NUMBER OF THE SUBROUTINE BEING USED. C WRTSUM - COPY SUMMARY TO WRITE UNIT IF TRUE. C SEELEV - CONTROLS THE AMOUNT OF SUMMARY DATA SHOWN ON THE C SCREEN (TAKES ON AN INTEGER VALUE FROM 1 TO 4). C WRITFL - COPY OUTPUT OF THE TEST TO THE WRITE UNIT IF TRUE. C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZBFOR C## S U B R O U T I N E S: NONE ARE CALLED. C## P A R A M E T E R S: C----- DEFINITIONS OF THE I/O UNITS. INTEGER PREPRC, DAUF, INPTUN PARAMETER ( PREPRC = 1, DAUF = 2, INPTUN = 3 ) INTEGER TEMPUN, STDIN, TRMOUT PARAMETER ( TEMPUN = 4, STDIN = 5, TRMOUT = 6 ) INTEGER WRITUN, TRACUN, SUMMUN PARAMETER ( WRITUN = 7, TRACUN = 8, SUMMUN = 9 ) INTEGER COPYUN, TEXUN PARAMETER ( COPYUN =10, TEXUN =11 ) C----- DEFINITION OF SEELEVEL CONSTANTS INTEGER CNONE, CMIN, CMED, CFULL PARAMETER ( CNONE = 1, CMIN = 2, CMED = 3, CFULL = 4 ) C----- DEFINITION OF STATUS CODES. C--ON ENTRY: INTEGER CNORML, CRCSTR, CRCRPT, CRCNFG PARAMETER ( CNORML = 0, CRCSTR = 1, CRCRPT = 2, CRCNFG = 3 ) INTEGER CNRMFG, CPSTHR PARAMETER ( CNRMFG = -1, CPSTHR = -2 ) C--ON EXIT: INTEGER CDONE, CRCF, CRCFG, CRCG PARAMETER ( CDONE = 0, CRCF = 1, CRCFG = 2, CRCG = 3 ) INTEGER CNSTOR, CIPMIN, CIPUNF, CBDMTH PARAMETER ( CNSTOR = -1, CIPMIN = -2, CIPUNF = -3, CBDMTH = -4 ) INTEGER CLSFAL, CNODSC, CXSFNC, CPSBCK PARAMETER ( CLSFAL = -5, CNODSC = -6, CXSFNC = -7, CPSBCK = -8 ) INTEGER CRABRT, CUSERV PARAMETER ( CRABRT = -9, CUSERV = -10 ) C## L O C A L D E C L: NONE ARE DEFINED. C## S A V E: NONE SELECTED. C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NONE ARE SET. C## E X E C U T I O N C## E X E C U T I O N GOTO ( 1000, 2000 ) SUBR C-----NOTHING TO DO FOR BBLNIR. 1000 GOTO 90000 C-----NOTHING TO DO FOR SHANNO'S CONMIN. 2000 GOTO 90000 C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZBFOR. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> bstrsg.f SUBROUTINE ZZBSTR ( STRING, START, END, PTR, NEWSTR, MAX, IGNORE ) C## A R G U M E N T S: CHARACTER * (*) STRING, NEWSTR INTEGER PTR, START, END LOGICAL MAX, IGNORE C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NOT REQUIRED. C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: BSTR.F,V 1.10 91/11/20 10:52:38 BUCKLEY EXP $ C>RCS $LOG: BSTR.F,V $ C>RCS REVISION 1.10 91/11/20 10:52:38 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.9 89/06/30 13:38:13 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 16:42:31 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 12:20:17 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:47:06 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:50:06 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS IS FOR BUILDING A STRING IN "STRING". IT ADDS CHARAC- C TERS FROM NEWSTR. IT ASSUMES THAT ON ENTRY, STRING CONTAINS C PTR CHARACTERS; PTR IS UPDATED BEFORE EXIT. C C IGNORE CONTROLS THE PROCESSING OF TRAILING BLANKS IN NEWSTR. C IF IGNORE IS TRUE, THEY ARE STRIPPED OFF, I.E. IGNORED; C OTHERWISE THEY ARE COPIED TO STRING JUST LIKE ANY OTHER C CHARACTER. C C START AND END CONTROL THE PLACEMENT OF NEWSTR IN STRING. C IF START > PTR ON ENTRY, NEWSTR IS APPENDED ONTO STRING, C STARTING IN POSITION PTR+1. IF START <= PTR ON ENTRY, THEN C NEWSTR IS OVERWRITTEN INTO STRING IN POSITIONS START TO END. C IF THERE IS NOT ENOUGH ROOM, THEN THE TAIL OF STRING IS RIGHT C SHIFTED JUST ENOUGH TO MAKE ROOM. WHEN END < START, THE NEW C STRING IS INSERTED JUST BEFORE POSITION START. C C MAX CONCERNS THE ACTION TAKEN WHEN STRING OVERFLOWS. IF MAX IS C FALSE ON ENTRY, ANY EXCESS CHARACTERS ARE JUST IGNORED AND AS C MANY AS POSSIBLE ARE PUT INTO STRING. PTR IS SET TO THE LENGTH C OF STRING. IF MAX IS TRUE, THEN, WHEN THERE ARE TOO MANY C CHARACTERS IN NEWSTR TO FIT ON THE END OF STRING, THERE IS NO C ACTION TAKEN, AND BOTH STRING AND PTR ARE UNCHANGED. IN EITHER C CASE, ON EXIT, MAX IS TRUE IF STRING DID NOT HAVE ENOUGH ROOM C TO ACCEPT ALL OF THE REQUIRED CHARACTERS (INCLUDING THE C BLANKS IF APPROPRIATE) FROM NEWSTR. C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZBSTR C## S U B R O U T I N E S: ZZLENG NONBLANK LENGTH OF A STRING. C ZZSHFT SHIFT A STRING. C LEN ...INTRINSIC C## P A R A M E T E R S: NONE ARE DEFINED. C## L O C A L D E C L: INTEGER LENS, LENN, ZZLENG, K, ROOM C## S A V E: NONE SELECTED. C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NONE ARE SET. C## E X E C U T I O N C## E X E C U T I O N LENS = LEN ( STRING ) IF ( IGNORE ) THEN LENN = ZZLENG ( NEWSTR ) ELSE LENN = LEN ( NEWSTR ) ENDIF IF ( START .LE. PTR ) THEN IF ( START .GT. END ) THEN ROOM = 0 K = -LENN ELSE ROOM = END - START + 1 K = ROOM - LENN ENDIF IF ( K .GT. 0 ) THEN STRING(START:END) = NEWSTR(1:LENN) MAX = .FALSE. ELSE ROOM = PTR - K IF ( ROOM .GT. LENS ) THEN IF ( MAX ) THEN GOTO 90000 ELSE ROOM = LENS MAX = .TRUE. ENDIF ELSE MAX = .FALSE. ENDIF IF ( END .GT. START ) THEN CALL ZZSHFT ( STRING, END+1, END-K+1, LENS ) ELSE CALL ZZSHFT(STRING,START,START+LENN,LENS) ENDIF STRING(START:START+LENN -1) = NEWSTR(1:LENN) PTR = ROOM ENDIF E L S E K = PTR + LENN IF ( K .LE. LENS ) THEN STRING(PTR+1:K) = NEWSTR(1:LENN) MAX = .FALSE. PTR = K ELSE IF ( MAX ) THEN GOTO 90000 ELSE IF ( PTR .LT. LENS ) THEN STRING ( PTR+1 : LENS ) = NEWSTR ( 1:LENN ) PTR = LENS MAX = .TRUE. ENDIF ENDIF ENDIF PTR = ZZLENG ( STRING ) C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZBSTR. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> dcodsg.f SUBROUTINE ZZDCOD( MODE, LL, LINLEN, LNO, EOPHAS, VERIFY, - OUTPT, KEYWRD, KWDICT, KWINFO, KWLENG, PWDICT, - PWINFO, PWLENG, PARSTR, PARVAL, NPARS, LOOPDL, - TRMODE, TRACE, TRACUN, MAP, UPCASE, * ) C## A R G U M E N T S: C-----ENTRY AND EXIT KEYWORD NUMBER AND MODES OF OPERATION. INTEGER KEYWRD, MODE, OUTPT, TRACUN LOGICAL TRMODE, VERIFY, TRACE, UPCASE C-----FORMAL EXTERNAL DICTIONARY PARAMETERS. INTEGER KWLENG, PWLENG INTEGER MAP( KWLENG ) INTEGER KWINFO( KWLENG, 2 ), PWINFO( PWLENG, 2 ) CHARACTER * (*) KWDICT, PWDICT C-----THE LINE TO BE DECODED AND THE POSITION IN LINE OF THE LAST C-----CHARACTER IN LINE TO BE CONSIDERED. INTEGER NULLIN, MXCRIT, RGL PARAMETER ( NULLIN=0, MXCRIT=20, RGL=MXCRIT+1 ) INTEGER ERL, CPL, SVL PARAMETER ( ERL=MXCRIT+2, CPL=MXCRIT+3, SVL=MXCRIT+4 ) INTEGER NL PARAMETER ( NL = MXCRIT+4 ) INTEGER LINLEN, LNO CHARACTER * (*) LL(*) C----- EXIT VARIABLES. INTEGER NPARS LOGICAL EOPHAS CHARACTER * (*) PARSTR ( * ) CHARACTER*1 LOOPDL REAL PARVAL ( * ) C!!!! DOUBLE PRECISION PARVAL ( * ) C## S T A T U S: C IGNORE LINES BEGINNING WITH "C!!!!" . C C SYSTEM DEPENDENCE: NONE. C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SINGLE/DOUBLE CONVERSION: NOT REQUIRED. C C>RCS $HEADER: DCOD.F,V 2.2 91/11/20 10:52:39 BUCKLEY EXP $ C>RCS $LOG: DCOD.F,V $ C>RCS REVISION 2.2 91/11/20 10:52:39 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 2.1 90/08/08 17:23:12 BUCKLEY C>RCS MINOR FIX TO DECLARATION. C>RCS C>RCS REVISION 2.0 90/07/31 11:23:17 BUCKLEY C>RCS MINOR ERRORS CORRECTED, ESP START=NO C>RCS C>RCS REVISION 1.9 89/06/30 13:32:49 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.6 89/05/21 12:47:48 BUCKLEY C>RCS FIXED DOUBLE LETTER C>RCS C>RCS REVISION 1.5 89/05/20 21:49:22 BUCKLEY C>RCS FINAL DECODE I THINK C>RCS C>RCS REVISION 1.4 89/05/20 20:35:05 BUCKLEY C>RCS TEMP C>RCS C>RCS REVISION 1.3 89/05/18 12:20:18 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:47:09 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:50:07 BUCKLEY C>RCS INITIAL REVISION C>RCS C## D E S C R I P T I O N: C THE PURPOSE OF ZZDCOD IS TO DECODE THE FIRST COMMAND FROM A C LINE OF CHARACTERS. THE COMPLETE SYNTAX FOR A COMMAND IS C SHOWN IN EXTERNAL DOCUMENTATION, BUT MAY BE BRIEFLY C SUMMARIZED AS : C [KEYWORD] [DELIMITER] [PARAMETER] [SEPARATOR] WHERE C THE ITEMS IN THE ARE OPTIONAL AND MAY BE REPEATED AND C THE TERMINATING SEPARATOR IS REQUIRED IF ANOTHER COMMAND FOLLOWS. C C INFORMATION CONCERNING THE LINE OF CHARACTERS IS PASSED INTO C ZZDCOD VIA THE ARGUMENTS : C LINE - THE LINE OF CHARACTERS, OF UNKNOWN LENGTH C LINLEN - THE INDEX OF THE LAST NON-BLANK CHARACTER IN THE C LINE C LP - AN INDEX INTO THE LINE, SEE BELOW C C AFTER A SUCCESSFUL DECODING OF A COMMAND, THE CHARACTERS C FROM THE COMMAND ARE REMOVED FROM LINE AND LINLEN IS C DECREASED. IMPLEMENTATION NOTE : ALL CHARACTERS IN LINE ARE C PUT INTO UPPER CASE; ON SYSTEMS WHICH USE TWO OR MORE C CHARACTER LOCATIONS TO REPRESENT A SINGLE LOWER CASE C CHARACTER THE LINLEN WILL DECREASE DUE TO THIS AS WELL. C C PARAMETER IS A GENERAL CONCEPT AND INCLUDES THE FOLLOWING C FORMS : C C PARAMETER TYPE ACCEPTABLE VALUES C -------------- ----------------------------------- C TLOGIC NONE ARE EXPECTED C TYREAL REAL (DOUBLE PRECISION) VALUES C TINTGR INTEGER VALUES C TINTPW INTEGER VALUES AND PARAMETER WORDS C FROM THE PARAMETER WORD DICTIONARY C DESCRIBED BELOW C TINTLT INTEGER VALUES AND LITERAL STRINGS C TYCHAR SINGLE CHARACTERS C TSTRNG LITERAL STRINGS C C INFORMATION CONCERNING VALID KEYWORDS AND PARAMETER WORDS C IS PASSED INTO ZZDCOD VIA THE FOLLOWING ARGUMENTS : C C ARGUMENT INTERPRETATION C -------- ------------------------------------------- C KWDICT AN ARRAY OF CHARACTER VARIABLES, EACH C CONTAINING A KEYWORD C KWLENG THE NUMBER OF SUCH KEYWORDS (THE DIMENSION) C KWINFO AN INTEGER MATRIX WITH DIMENSIONS KWLENG C ROWS BY 2 COLUMNS. THE FIRST COLUMN C CONTAINS AN INTEGER DICTATING THE MAXIMUM C NUMBER OF PARAMETERS WHICH THE KEYWORD ON C THE SAME ROW IN KWDICT MAY ACCEPT. THE C SECOND COLUMN CONTAINS ONE OF THE PARAMETER C TYPES LISTED ABOVE AND DICTATES THE FORM C OF ACCEPTABLE PARAMETERS. C C PWDICT AN ARRAY OF CHARACTER VARIABLES, EACH C CONTAINING A PARAMETER WORD C PWLENG THE NUMBER OF SUCH PARAMETER WORDS (THE C DIMENSION) C PWINFO AN INTEGER MATRIX WITH DIMENSIONS PWLENG C ROWS BY 2 COLUMNS. THE FIRST COLUMN C CONTAINS THE INDEX IN KWDICT OF THE C KEYWORD ASSOCIATED WITH THE PARAMETER WORD. C THE SECOND COLUMN GIVES AN INTEGER VALUE FOR C THE PARAMETER WORD. C C THE ARGUMENTS MODE AND KEYWRD ARE USED FOR DISTINCT C PURPOSES ON ENTRY AND ON EXIT. C C ! MODE = ! INTERPRETATION C ---+--------+------------------------------------------- C ! DCDNEW ! THE FIRST CALL TO ZZDCOD WITH THIS LINE C ! ! OF CHARACTERS [ LINE( 1:LINLEN ) ] C +--------+------------------------------------------- C ! DCDOLD ! A SUBSEQUENT CALL TO ZZDCOD WHERE NO C O ! ! ERRORS WITH ASSOCIATED REPLACEMENT C N ! ! REQUESTS, OR CONTINUATION REQUESTS WERE C ! ! ENCOUNTERED ON THE PREVIOUS CALL. THE C E ! ! LINE OF CHARACTERS IS LINE( 1:LINLEN ) C N +--------+------------------------------------------- C T ! DCDREP ! A CALL AFTER CHARACTERS CONTAINING AN C R ! ! ERROR IS REPLACED; LINE( 1:LP ) C Y ! ! CONTAINS THE NEW INFORMATION; SEE DCDERR C +--------+------------------------------------------- C ! DCDCON ! A CALL IMMEDIATELY FOLLOWING A RETURN C ! ! FROM ZZDCOD WITH A CONTINUATION REQUEST. C ! ! ALL OF LINE( 1:LINLEN ) IS NEW. C ---+--------+------------------------------------------- C ! DCDDON ! A COMMAND HAS BEEN SUCCESSFULLY DECODED C ! ! AND THE LINE IS EXHAUSTED, I.E. LINLEN = 0 C +--------+------------------------------------------- C ! DCDMOR ! A COMMAND HAS BEEN SUCCESSFULLY DECODED C ! ! AND THE LINE CONTAINS CHARACTERS TO BE C O ! ! DECODED, I.E. LINLEN > 0 C N +--------+------------------------------------------- C ! DCDERR ! AN ERROR WAS FOUND IN THE LINE BETWEEN C E ! ! THE FIRST AND (LP)TH CHARACTER. C X ! ! THE CALLING PROGRAM SHOULD REPLACE THE C I ! ! INFORMATION. NOTE THAT IT IS THE CALLING C T ! ! PROGRAM'S RESPONSIBILITY TO HANDLE ANY C ! ! CHARACTERS ON THE LINE WHICH MAY BE C ! ! LOST DURING THE REPLACEMENT. ZZERRM WILL C ! ! BE CALLED BY ZZDCOD. IF NOT TRMODE THEN C ! ! THE ALTERNATIVE RETURN WILL BE TAKEN. C +--------+------------------------------------------- C ! DCDBAD ! ON ENTRY MODE WAS INVALID. C ---+--------+------------------------------------------- C C C INTERPRETATION ! KEYWRD ! INTERPRETATION C ON ENTRY ! ! ON EXIT C ----------------------+--------+---------------------- C NO DEFAULT KEYWORD ! < 0 ! ERROR WITH NUMBER C ! ! EQUAL TO KEYWRD C +--------+---------------------- C ! = 0 ! NO INPUT ON LINE C ----------------------+--------+---------------------- C A DEFAULT KEYWORD ! > 0 ! KEYWORD WITH INDEX C WITH INDEX INTO ! ! INTO KWDICT EQUAL TO C KWDICT EQUAL TO ! ! KEYWRD WAS FOUND. C KEYWRD IS ASSUMED ! ! C ----------------------+--------+---------------------- C C WHEN KEYWRD IS POSITIVE ON EXIT, THEN INFORMATION C CONCERNING THE DECODED PARAMETERS (IF ANY) IS PASSED OUT C USING THE FOLLOWING ARGUMENTS : C C VARIABLE INTERPRETATION C -------- ------------------------------------------- C PARVAL AN ARRAY OF REALS INTO WHICH REALS AND C CONVERTED INTEGERS ARE PLACED. INTEGERS C MAY REPRESENT VALUES, KEYWORD OR PARAMETER C WORD INDICES, OR THE CHARACTER SEQUENCE C NUMBER OF A CHARACTER PARAMETER C PARSTR AN ARRAY OF CHARACTER VARIABLES INTO WHICH C LITERAL STRINGS ARE PLACED C NPARS THE NUMBER OF PARAMETERS FOUND C C NPARS SHOULD, ON ENTRY, BE THE DIMENSION OF PARVAL AND PARSTR. C C PARAMETER TYPE IN PARSTR IN PARVAL C -------------- --------- --------- C C TLOGIC THE STRING 'TRUE' OR F NOTHING C DEPENDS ON WHETHER KEYWORD C PRECEDED WITH 'NO'. C C TYREAL NOTHING THE REAL VALUE C C TYCHAR THE CHARACTER, FOLLOWED BY THE VALUE OF ICHAR, C BLANKS. CONVERTED TO REAL. C TSTRNG THE STRING, FOLLOWED BY BLANKS. NOTHING C C TINTGR (I) WITH NO RADIX PRESENT C C BLANK CONVERTED VALUE C C (II) RADIX B, O, H OR X PRESENT C C BLANK INTEGER, CONVERTED C ACCORDING TO GIVEN C BASE, AS A REAL. C (III) OTHER RADIX C C , FOLLOWED BY RADIX INTEGER IN BASE 10, C CHARACTER SPECIFIED. CONVERTED TO REAL. C C EOPHAS IS TRUE WHEN (1) A SPECIAL END OF LINE C CHARACTER IS ENCOUNTERED, OR (2) WHEN THE ENTIRE LINE C IS EXHAUSTED (I.E. EXIT IN DCDDON); TRMODE INDICATES C WHETHER THE SESSION IS INTERACTIVE OR NOT. C C ==> FINISH C C## E N T R Y P O I N T S: C ZZDCOD THE NATURAL ENTRY. C ZZDSET INITIALIZE CONTROL VARIABLES. C C## S U B R O U T I N E S: C C ZZBASE CONVERT STRING IN GIVEN BASE TO INTEGER. C ZZERRM WRITE AN ERROR OR INFORMATIVE MESSAGE. C ZZSRCH SEARCH A DICTIONARY. C C ICHAR, INDEX, LEN, REAL(DBLE) ...INTRINSIC C C## P A R A M E T E R S: LOGICAL T, F PARAMETER ( T = .TRUE., F = .FALSE. ) CHARACTER*(*) TRUE, QT, FALSE, QF PARAMETER ( TRUE = 'TRUE', QT = 'T', FALSE = 'FALSE', QF = 'F' ) INTEGER ITRUE, IFALSE PARAMETER ( ITRUE = 1, IFALSE = 0 ) REAL RTRUE, RFALSE C!!!! DOUBLE PRECISION RTRUE, RFALSE PARAMETER ( RTRUE = 1.D0, RFALSE = 0.D0 ) INTEGER CTOUPP, CTOLOW, CTOCAP PARAMETER ( CTOUPP = 1, CTOLOW = 2, CTOCAP = 3 ) C-----CONTROL CONSTANTS INTEGER SINGLE, DOUBLE PARAMETER ( SINGLE = 1, DOUBLE = 2 ) INTEGER TLOGIC, TYREAL, TINTGR, TSTRNG INTEGER TINTPW, TYCHAR, TINTLT, TYNONE PARAMETER ( TLOGIC = 0, TINTGR = 3, TINTPW = 4 ) PARAMETER ( TINTLT = 5, TYCHAR = 6, TSTRNG = 7, TYNONE = 8 ) PARAMETER ( TYREAL = SINGLE ) C!!!! PARAMETER ( TYREAL = DOUBLE ) C MODES FOR DECODING. INTEGER DCDNEW, DCDDON PARAMETER ( DCDNEW = 0, DCDDON = DCDNEW ) INTEGER DCDOLD, DCDMOR PARAMETER ( DCDOLD = 1, DCDMOR = DCDOLD ) INTEGER DCDREP, DCDERR PARAMETER ( DCDREP = 2, DCDERR = DCDREP ) INTEGER DCDCON, DCDBAD PARAMETER ( DCDCON = 3, DCDBAD = 4 ) C-----SPECIAL CHARACTERS AND STRINGS, WHICH SHOULD BE STANDARD. CHARACTER * (*) ALPHBT PARAMETER ( ALPHBT = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' ) CHARACTER * (*) DIGITS PARAMETER ( DIGITS = '0123456789' ) CHARACTER * (*) DECPT , PLUS PARAMETER ( DECPT = '.' , PLUS = '+' ) CHARACTER * (*) MINUS , BLANK PARAMETER ( MINUS = '-' , BLANK = ' ' ) C-----LENGTHS FOR STRING ARRAYS. INTEGER ERRLEN, NERROR, IMPERR PARAMETER ( ERRLEN = 40, NERROR = 23, IMPERR = 4 ) INTEGER TOTERR PARAMETER ( TOTERR = NERROR+IMPERR ) C-----DEFINE INTERNAL DECODING STATES. INTEGER SBEGIN , SBWORD , SXPARM , SBNUMR PARAMETER ( SBEGIN = 1, SBWORD = 2, SXPARM = 3, SBNUMR = 4 ) INTEGER SBPWRD , SBCHAR , SBSTR PARAMETER ( SBPWRD = 5, SBCHAR = 6, SBSTR = 7 ) INTEGER NOSTRT, NOSIGN, NOINTG, NORADX PARAMETER ( NOSTRT = 0, NOSIGN = 1, NOINTG = 2, NORADX = 3 ) INTEGER NORADC, NODECM, NOEXPO, NOEXSG PARAMETER ( NORADC = 4, NODECM = 5, NOEXPO = 6, NOEXSG = 7 ) INTEGER NOEXNO, NOHEXD, NOERRR, NOFRAC PARAMETER ( NOEXNO = 8, NOHEXD = 9, NOERRR = 10, NOFRAC = 11 ) C-----INTERNAL CODES FOR RESULT AFTER DECIDING. INTEGER RESKEY, RESNKY, RESKTR PARAMETER ( RESKEY = 1, RESNKY = 2, RESKTR = 3 ) INTEGER RESPAR, RESSTR, RESBAD PARAMETER ( RESPAR = 4, RESSTR = 5, RESBAD = 6 ) C## L O C A L D E C L: C----- FIRST TIME CALLED LOGICAL FIRST C----- ERROR MESSAGES AND EXIT CODES. CHARACTER * (ERRLEN) MESSAG(TOTERR) INTEGER EXIT (TOTERR) C-----NOTE THAT THE FOLLOWING ARE DEFINED EXTERNALLY AND THE VALUES C-----PASSED INTO ZZDCOD THROUGH THE ENTRY POINT ZZDSET. SEE THE C-----SAVE VARIABLES. C ---SPECIAL CHARACTERS. INTEGER CONT, DEL, ESC, SEP, RADIX, ASSMT, COM1, COM2 INTEGER RADPRB, RADFUN, RADGRP, STRNG1, STRNG2, LOOPA, LOOPG INTEGER NDCCHS PARAMETER ( CONT = 1, DEL = 2, ESC = 3, SEP = 4, - RADIX = 5, ASSMT = 6, COM1 = 7, COM2 = 8, - RADPRB = 9, RADFUN =10, RADGRP =11, STRNG1 =12, - STRNG2 =13, LOOPA =14, LOOPG =15 ) PARAMETER ( NDCCHS = 15 ) CHARACTER*(NDCCHS) DCC CHARACTER * 1 CONTIN, DELIMT, ESCAPC, SEPAR, COMM1 CHARACTER * 1 COMM2, RADX, ALOOP, GLOOP CHARACTER * 1 STR1, STR2, ASSGN C-----RADIX CONVERSIONS. INTEGER RADBAS(5) CHARACTER VALSC*16, RADCON*5 C-----LOCAL VARIABLES. REAL VALUE, RD C!!!! DOUBLE PRECISION VALUE, RD INTEGER DEFKEY, DFPNUM, DFPTYP, DINDEX, I, PTSVL INTEGER KTRIND, MXPARS, KEYPTR, MESSIN, OLDNIN, INLINE INTEGER NEWKIN, NEWPIN, OLDKIN, OLDPIN, PARNUM, NEWNIN INTEGER PARTYP, STATE, SLEN, SMARKR, I1, RESULT, LASTCP INTEGER DIGF, DIGT, TRYF, TRYT, AFTDEC, NOSTAT, B, LP INTEGER OFFST1, OFFST2 LOGICAL CANINT, CANSTR, ESCAPE, GOTALF, GOTDEL, IGN LOGICAL GOTINT, GOTREL, GOTSEP, HAVKTR, KNOWN, MAYBEK, MAYBEP LOGICAL SEPDEL, STILLK, STILLP, TRAILD, COMENT, MAYBEN, STILLN LOGICAL STRNGE, GOTRAD, HARD, GOTNUM, EXCESS, GOTHEX, RADHEX LOGICAL DEFNUM, SKIP, HAVDEC, HAVRDX, HAVFRC, HAVHEX LOGICAL INSTRG CHARACTER * ( 1) NEXTCH, UPCH CHARACTER * ( 2) NO CHARACTER * (20) RFRMAT C## S A V E: C----- ALL VARIABLES SAVED BECAUSE OF POSSIBLE CONTINUATION. SAVE C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: C 1 2 3 4 C MESSAGE LENGTH = 1234567890123456789012345678901234567890 DATA MESSAG(24) / 'DCOD IMPL. ERR: BAD VALUE FOR RESULT' / DATA MESSAG(25) / 'DCOD IMPL. ERR: NOT ENOUGH PARAMETERS.'/ DATA MESSAG(26) / 'DCOD IMPL. ERR: NUMBER STRINGS' / DATA MESSAG(27) / 'DCOD IMPL. ERR: STRING TOO SHORT' / DATA MESSAG(1) / 'INVALID INITIAL CHARACTER.' / DATA MESSAG(2) / 'DELIMITER NOT EXPECTED AFTER KEYWORD.' / DATA MESSAG(3) / 'MISSING AN EXPECTED PARAMETER.' / DATA MESSAG(4) / 'DELIMITER NOT EXPECTED AFTER PARAMETER.' / DATA MESSAG(5) / 'UNKNOWN KEYWORD BEFORE DELIMITER.' / DATA MESSAG(6) / 'UNRECOGNIZED WORD BEFORE SEPARATOR.' / DATA MESSAG(7) / 'BAD CHARACTER IN STRING.' / DATA MESSAG(8) / 'PARAMETER MUST BE NUMERIC.' / DATA MESSAG(9) / 'PARAMETER MUST BEGIN WITH A LETTER.' / DATA MESSAG(10)/ 'THERE ARE TOO MANY PARAMETERS.' / DATA MESSAG(11)/ 'TOO MANY CHARACTERS FOR A NUMBER.' / DATA MESSAG(12)/ 'INVALID LETTER IN NUMBER.' / DATA MESSAG(13)/ 'INVALID SYNTAX FOR A REAL NUMBER.' / DATA MESSAG(14)/ 'INVALID SYNTAX FOR AN INTEGER.' / DATA MESSAG(15)/ 'INVALID CHARACTER FOR A NUMBER.' / DATA MESSAG(16)/ 'UNRECOGNIZED KEYWORD.' / DATA MESSAG(17)/ 'INVALID SYNTAX IN PARAMETER.' / DATA MESSAG(18)/ 'PARAMETER MUST BE A SINGLE CHARACTER.' / DATA MESSAG(19)/ 'KEYWORD FOR SYNONYM IS UNKNOWN.' / DATA MESSAG(20)/ 'SYNONYM IS MISSING.' / DATA MESSAG(21)/ 'INVALID CHARACTER IN KEYWORD.' / DATA MESSAG(22)/ 'PARAMETER NOT EXPECTED WITH SYNONYM.' / DATA MESSAG(23)/ 'INVALID POSITION FOR STRING.' / DATA FIRST /T/ C-----FORMAT STRINGS. DATA RFRMAT / '( BN, F 40 .0 )' / DATA RADBAS / 2, 10, 8, 16, 16 / DATA VALSC / '0123456789ABCDEF' /, RADCON / 'BDOHX' / C## E X E C U T I O N C## E X E C U T I O N C----- DEFINE FUNCTION STATEMENT. RD(I) = REAL(I) C!!!! RD(I) = DBLE(I) C----- TAKE LENGTH OF INPUT LINE. INLINE = LEN(LL(LNO)) C----- SET UP THE EXIT ARRAY IF ( FIRST ) THEN DO 50 I = 1, NERROR EXIT(I) = I 50 CONTINUE TRYF = 10 * NERROR DO 60 I = 1, IMPERR EXIT(NERROR+I) = TRYF + I 60 CONTINUE FIRST = F ENDIF C-----CHECK FOR CORRECT MODE. IF ( MODE .NE. DCDNEW .AND. MODE .NE. DCDOLD .AND. - MODE .NE. DCDREP .AND. MODE .NE. DCDCON ) THEN C => BAD VALUE FOR MODE. CALL ZZERRM ( RD(MODE), *91000, - 'NT DECODE ENTRY WITH BAD MODE VALUE.' ) GOTO 91000 ELSE IF ( MODE .EQ. DCDCON ) THEN C => PICK UP WHERE WE LEFT OFF. LP = 0 ELSE C => INITIALIZE ALL VARIABLES. SLEN = LEN ( PARSTR (1) ) MXPARS = NPARS DEFKEY = KEYWRD IF ( DEFKEY .GT. 0 ) THEN DFPNUM = KWINFO( DEFKEY, 1 ) DFPTYP = KWINFO( DEFKEY, 2 ) CANINT = DFPTYP .EQ. TINTGR .OR. DFPTYP .EQ. TINTPW - .OR. DFPTYP .EQ. TINTLT CANSTR = DFPTYP .EQ. TSTRNG .OR. DFPTYP .EQ. TINTLT ELSE DFPNUM = 0 DFPTYP = TYNONE CANINT = F CANSTR = F ENDIF KEYWRD = 0 NPARS = 0 LASTCP = 0 STATE = SBEGIN NOSTAT = NOSTRT MESSIN = 0 ESCAPE = F EOPHAS = F COMENT = F INSTRG = F LP = 0 LL(ERL)= BLANK LL(SVL)= BLANK PTSVL = 0 SMARKR = 0 KNOWN = F TRAILD = F HAVDEC = F HAVFRC = F HAVRDX = F HAVHEX = F SKIP = F ENDIF C THE FOLLOWING LOGICALS ARE USED THROUGHOUT : C GOTALF = NEXTCH IS ALPHABETIC C GOTDEL = NEXTCH IS DELIMITER OR ASSIGNMENT C GOTSEP = NEXTCH IS SEPARATOR C SEPDEL = GOTDEL OR GOTSEP C GOTINT = NEXTCH IS DIGIT OR + OR - OR / C GOTREL = NEXTCH IS DIGIT OR + OR - OR . OR D OR E. C DEFNUM = NEXTCH IS + OR - OR . OR / ( UNAMBIGUOUS ) C HARD = NEXTCH IS DIGIT OR ALPHABETIC ( AMBIGUOUS ) C----- TOP OF THE LOOP FOR CHARACTER BY CHARACTER PROCESSING. 100 LP = LP + 1 GOTALF = F GOTDEL = F GOTSEP = F GOTINT = F GOTREL = F STRNGE = F GOTRAD = F DEFNUM = F IF ( LP .GT. LINLEN ) THEN C => SUPPLY AN ARTIFICIAL END-OF-LINE CHARACTER. IF ( COMENT ) THEN MODE = DCDCON GOTO 90000 ELSE EOPHAS = T GOTSEP = T GOTO 150 ENDIF ELSE C => CONSIDER THE NEXT CHARACTER IN LINE. NEXTCH = LL(LNO) (LP:LP) UPCH = NEXTCH IF ( .NOT. UPCASE ) THEN CALL ZZCASE(UPCH,CTOUPP) ENDIF ENDIF IF ( COMENT ) THEN C => IGNORE IT. IF ( NEXTCH .EQ. COMM1 .OR. NEXTCH .EQ. COMM2 ) THEN COMENT = F ENDIF GOTO 100 ELSEIF ( ESCAPE ) THEN C => PREVIOUS CHAR WAS ESCAPE CHARACTER. THIS C => CHAR MUST NOT BE GIVEN ANY SPECIAL MEANING. GOTALF = T ESCAPE = F ELSEIF ( INSTRG ) THEN C => DO NOTHING, BUT CHANGE STATE IF ( NEXTCH .EQ. STR1 .OR. NEXTCH .EQ. STR2 ) THEN INSTRG = .NOT. INSTRG GOTO 100 ENDIF ELSEIF ( NEXTCH .EQ. BLANK ) THEN C => IF NOT INSIDE QUOTES IGNORE A BLANK. IF ( STATE .NE. SBSTR ) THEN IF ( STATE .EQ. SBWORD ) THEN PTSVL = PTSVL + 1 LL(SVL)(PTSVL:PTSVL) = BLANK ENDIF GOTO 100 ENDIF ELSEIF (( NEXTCH .EQ. DELIMT ) .OR. ( NEXTCH .EQ. ASSGN ) - .OR. ( NEXTCH .EQ. ALOOP ) .OR. ( NEXTCH .EQ. GLOOP )) THEN GOTDEL = T LOOPDL = NEXTCH ELSEIF ( NEXTCH .EQ. SEPAR ) THEN GOTSEP = T ELSEIF ( NEXTCH .EQ. PLUS .OR. NEXTCH .EQ. MINUS ) THEN GOTREL = T GOTINT = T DEFNUM = T IF ( NOSTAT .EQ. NOSTRT ) THEN NOSTAT = NOSIGN ELSE IF ( NOSTAT .EQ. NOEXPO ) THEN NOSTAT = NOEXSG ELSE NOSTAT = NOERRR ENDIF ELSEIF ( NEXTCH .EQ. DECPT ) THEN GOTREL = T DEFNUM = T HAVDEC = T IF ( NOSTAT .EQ. NOINTG .OR. NOSTAT .EQ. NOSTRT - .OR. NOSTAT .EQ. NOSIGN ) THEN NOSTAT = NODECM ELSE NOSTAT = NOERRR ENDIF ELSEIF ( NEXTCH .EQ. RADX ) THEN GOTINT = T DEFNUM = T HAVRDX = T IF ( NOSTAT .EQ. NOINTG .OR. NOSTAT .EQ. NOHEXD ) THEN NOSTAT = NORADX ELSE NOSTAT = NOERRR ENDIF ELSEIF ( INDEX ( DIGITS, NEXTCH ) .NE. 0 ) THEN GOTINT = T GOTREL = T IF ( NOSTAT .EQ. NOSTRT .OR. NOSTAT .EQ. NOINTG - .OR. NOSTAT .EQ. NOSIGN ) THEN NOSTAT = NOINTG ELSE IF ( NOSTAT .EQ. NOHEXD ) THEN NOSTAT = NOHEXD ELSE IF ( NOSTAT .EQ. NODECM ) THEN NOSTAT = NOFRAC HAVFRC = T ELSE IF ( NOSTAT .EQ. NOEXSG .OR. NOSTAT .EQ. NOEXPO - .OR. NOSTAT .EQ. NOEXNO ) THEN NOSTAT = NOEXNO ELSE IF ( NOSTAT .EQ. NOFRAC ) THEN C NOTHING CHANGES. ELSE NOSTAT = NOERRR ENDIF ELSEIF ( INDEX ( ALPHBT, UPCH ) .NE. 0 ) THEN GOTALF = T GOTHEX = INDEX(VALSC,UPCH) .NE. 0 RADHEX = UPCH .EQ. 'X' .OR. UPCH .EQ. 'H' GOTREL = UPCH .EQ. 'D' .OR. UPCH .EQ. 'E' IF ( GOTREL .AND. ( NOSTAT .EQ. NODECM - .OR. NOSTAT .EQ. NOINTG - .OR. NOSTAT .EQ. NOFRAC ) ) THEN NOSTAT = NOEXPO ELSE IF ( GOTHEX .AND. - (NOSTAT .EQ. NOSTRT .OR. NOSTAT .EQ. NOINTG - .OR. NOSTAT .EQ. NOHEXD .OR. NOSTAT .EQ. NOSIGN ) ) THEN NOSTAT = NOHEXD HAVHEX = T GOTNUM = T ELSE IF ( NOSTAT .EQ. NOINTG ) THEN NOSTAT = NORADC ELSE IF ( NOSTAT .EQ. NOHEXD .AND. RADHEX ) THEN NOSTAT = NORADC ELSE IF ( NOSTAT .EQ. NORADX ) THEN IF ( HAVHEX .AND. RADHEX ) THEN NOSTAT = NORADC ELSE IF ( .NOT. RADHEX ) THEN NOSTAT = NORADC ELSE NOSTAT = NOERRR ENDIF ELSE IF ( NOSTAT .NE. NOSTRT ) THEN NOSTAT = NOERRR ENDIF ELSEIF ( NEXTCH .EQ. ESCAPC ) THEN ESCAPE = T GO TO 100 ELSEIF ( NEXTCH .EQ. COMM1 .OR. NEXTCH .EQ. COMM2 ) THEN COMENT = T GOTO 100 ELSEIF ( NEXTCH .EQ. STR1 .OR. NEXTCH .EQ. STR2 ) THEN INSTRG = T GOTO 100 ELSEIF ( NEXTCH .EQ. CONTIN ) THEN C => DETERMINE HOW TO EXIT. IF ( MESSIN .NE. 0 ) THEN C => IGNORE THE CONTINUATION. GOTSEP = T ELSE C => EXIT NOW. MODE = DCDCON GO TO 90000 ENDIF ELSE STRNGE = T ENDIF 150 SEPDEL = GOTSEP .OR. GOTDEL GOTNUM = GOTINT .OR. GOTREL HARD = GOTALF .OR. ( GOTNUM .AND. .NOT. DEFNUM ) IF ( .NOT. GOTSEP ) THEN C ADD NEXTCH TO STRING BEING BUILT. EXCESS = F C CALL ZZBSTR ( STRING,SMARKR+1,1,SMARKR,NEXTCH,EXCESS,F ) C TO FACILITATE THE INCLUSION OF BLANKS, DON'T USE ZZBSTR, C INSTEAD USE THE FOLLOWING 7 LINES : IF ( SMARKR+1 .LE. INLINE ) THEN LL(ERL)( SMARKR+1 : SMARKR+1 ) = NEXTCH SMARKR = SMARKR+1 ELSE MESSIN = 27 GOTO 82000 ENDIF ENDIF IF (TRACE .AND. SMARKR .NE. 0) WRITE (TRACUN,*) - 'STRING IS NOW==>',LL(ERL)(1:SMARKR) IF (TRACE) WRITE (TRACUN,*) - 'WITH: NEXTCH="',NEXTCH,'" ', - 'SEPDEL,GOTNUM,HARD,STATE,NOSTAT ', - SEPDEL,GOTNUM,HARD,STATE,NOSTAT C....................................................................... C => BRANCH TO CORRECT STATE. 200 IF ( MESSIN .NE. 0 ) THEN GOTO 10000 ELSE GOTO ( 1000, 2000, 3000, 4000, 5000, 6000, 7000 ) STATE ENDIF C....................................................................... C STATE #1 (SBEGIN) FIRST CHARACTER ENCOUNTERED. 1000 IF ( .NOT. GOTSEP ) THEN C => ACT ON THE CHARACTER. TRYF = SMARKR IF ( GOTALF ) THEN C => GO DIRECTLY TO STATE SBWORD. STATE = SBWORD MAYBEK = T OLDKIN = 0 HAVKTR = F MAYBEP = T OLDPIN = 0 ELSEIF( ( GOTINT .AND. CANINT ) .OR. - ( GOTREL .AND. DFPTYP .EQ. TYREAL ) ) THEN C => PREPARE TO GO DIRECTLY TO STATE SBNUMR. STATE = SBNUMR DIGF = SMARKR NPARS = 1 ELSEIF ( DFPTYP .EQ. TYCHAR ) THEN STATE = SBCHAR NPARS = 1 ELSEIF ( DFPTYP .EQ. TSTRNG ) THEN STATE = SBSTR PTSVL = 0 LL(SVL) = BLANK NPARS = 1 ELSE C => BAD CHARACTER. MESSIN = 1 ENDIF ELSE C => IGNORE MULTIPLE SEPARATORS. GOTO 10000 ENDIF IF ( STATE .NE. SBWORD ) THEN KEYWRD = DEFKEY PARNUM = DFPNUM PARTYP = DFPTYP EXCESS = F IGN = T OFFST1 = (KEYWRD-1) * SLEN +1 OFFST2 = KEYWRD * SLEN CALL ZZBSTR( LL(ERL), 1, 0, SMARKR, - KWDICT( OFFST1 : OFFST2 ), EXCESS, IGN ) CALL ZZBSTR( LL(ERL), SMARKR, SMARKR-1, SMARKR, - ASSGN, EXCESS, IGN ) TRYF = SMARKR DIGF = SMARKR ENDIF GOTO 200 C....................................................................... C STATE #2 (SBWORD) HERE WE ARE BUILDING KEYWORDS, BUT THE C SITUATION MAY BE VERY AMBIGUOUS WHEN TRAILING C DIGITS ARE PRESENT, OR THE KEYWORD OR DELIMITER HAS BEEN C LEFT OUT. WE STAY IN THIS STATE FROM THE STARTING ALPHA- C BETIC UNTIL SOME CHARACTER CLARIFIES THE SITUATION. 2000 IF ( SKIP ) THEN IF ( GOTNUM ) THEN DEFNUM = T ELSE IF ( GOTALF ) THEN GOTO 10000 ENDIF ENDIF IF ( HARD ) THEN C => NEXTCH IS ALPHABETIC OR A DIGIT, BUT NOT + - . OR / C => THIS IS WHERE THE SITUATION IS STILL AMBIGUOUS AND C => NO RESOLUTION OF THE MEANING HAS YET BEEN MADE. PTSVL = PTSVL + 1 LL(SVL)(PTSVL:PTSVL) = NEXTCH TRYT = SMARKR IF ( .NOT. TRAILD .AND. GOTNUM ) THEN C => START OF POSSIBLE TRAILING NUMBER. DIGF = SMARKR DIGT = SMARKR TRAILD = T ELSEIF ( TRAILD ) THEN C => IF TRAILING DIGITS ARE ALREADY PRESENT ADD NEXTCH TO THE C => DIGIT STRING. STILL NO RESOLUTION. IF ( NOSTAT .EQ. NOERRR ) THEN TRAILD = F ELSE DIGT = SMARKR ENDIF ELSE C => WHEN THERE ARE NO TRAILING DIGITS ADD NEXTCH TO THE C => STRING OF CHARACTERS TAKEN TO BE NONNUMERIC. C => ALREADY DONE, SO NOTHING EXTRA NEEDED. ENDIF C OF " IF TRAIL D..." IF ( MAYBEK ) THEN C => IF THE TRIAL STRING WITHOUT NEXTCH WAS IN THE C => KEYWORD DICTIONARY, SEE IF THE ADDITION OF NEXTCH C => HAS AFFECTED ITS PRESENCE. NEWKIN = OLDKIN CALL ZZSRCH(LL(ERL)(TRYF:TRYT),SLEN,KWDICT,KWLENG,SLEN, - NEWKIN,T,UPCASE) STILLK = NEWKIN .GT. 0 ENDIF IF ( TRYT .GT. TRYF+1 ) THEN IF ( MAYBEN ) THEN NEWNIN = OLDNIN I = TRYF+2 2020 CALL ZZSRCH(LL(ERL)(I:TRYT),SLEN-2,KWDICT,KWLENG,SLEN, - NEWNIN, T,UPCASE) IF ( NEWNIN .NE. 0 ) THEN IF ( KWINFO(NEWNIN,2) .EQ. TLOGIC ) THEN STILLN = T ELSE NEWNIN = NEWNIN + 1 GOTO 2020 ENDIF ELSE STILLN = F ENDIF ENDIF ELSE NO = LL(ERL)(TRYF:TRYF+1) CALL ZZCASE(NO,CTOUPP) IF ( TRYT .EQ. TRYF .AND. NO(1:1) .EQ. 'N' .OR. - TRYT .EQ. TRYF+1 .AND. NO(1:2) .EQ. 'NO') THEN STILLN = T NEWNIN = 0 ELSE STILLN = F ENDIF ENDIF IF ( MAYBEP ) THEN C => PERFORM A SIMILAR ANALYSIS IF THE TRIAL STRING WAS C => IN THE PARAMETER DICTIONARY. NEWPIN = OLDPIN IF ( PWLENG .NE. 0 ) THEN CALL ZZSRCH(LL(ERL)(TRYF:TRYT),SLEN,PWDICT,PWLENG,SLEN, - NEWPIN, T,UPCASE) STILLP = NEWPIN .GT. 0 ELSE STILLP = F ENDIF ENDIF IF ( .NOT. ( STILLK .OR. STILLP .OR. STILLN ) ) THEN C => THE TRIAL STRING WITH THE ADDITION OF NEXTCH IS C => NEITHER A KEYWORD NOR A PARAMETER AND SO WE MUST BE C => ABLE TO MAKE A DECISION NOW. MAYBEK = F MAYBEP = F MAYBEN = F C THIS IS CASE #1. ASSIGN 2100 TO AFTDEC GOTO 81000 C GOTO 100 ELSE IF ( SMARKR .GT. SLEN ) THEN C => SET FLAG TO SKIP SUCCEEDING ALPHABETIC CHARACTERS. C (CASE # 2 WAS DROPPED.) SKIP = T ENDIF C FOR " NOT STILL..." C => UPDATE MAYBEK AND MAYBEP AND THE RELATED DICTIONARY C => INDEXES AS APPROPRIATE. IF MAYBEK THEN CHECK THE C => KEYWORD DICTIONARY FOR AN ACCEPTABLE KEYWORD WHICH C => PERMITS INTEGER OR REAL PARAMETERS. MAYBEK = STILLK IF ( MAYBEK ) THEN OLDKIN = NEWKIN PARTYP = KWINFO( NEWKIN, 2 ) IF ( PARTYP .EQ. TYREAL .OR. PARTYP .EQ. TINTGR - .OR. PARTYP .EQ. TINTLT .OR. PARTYP .EQ. TINTPW) THEN HAVKTR = T KEYPTR = SMARKR KTRIND = NEWKIN NOSTAT = NOSTRT TRAILD = F ENDIF ELSE HAVKTR = F ENDIF MAYBEP = STILLP IF ( MAYBEP ) THEN OLDPIN = NEWPIN ENDIF MAYBEN = STILLN IF ( MAYBEN ) THEN OLDNIN = NEWNIN ENDIF C.....=> IN ALL CASES FOLLOWING, THE SITUATION IS NO LONGER C..... AMBIGUOUS, ALTHOUGH IT MAY STILL NEED FINAL CLARIFICATION. ELSEIF ( DEFNUM ) THEN C => DEFINITELY NUMERIC!. IF ( .NOT. KNOWN ) THEN TRAILD = T TRYT = SMARKR MAYBEK = F MAYBEN = F MAYBEP = F C CASE #3. ASSIGN 2300 TO AFTDEC GOTO 81000 ELSE STATE = SBNUMR DIGF = SMARKR GOTO 200 ENDIF ELSEIF ( SEPDEL ) THEN C => SEVERAL POSSIBILITIES STILL, SINCE NOT RESOLVED YET. C => IF KNOWN IS TRUE, KEYWORD HAS BEEN FOUND, SO LITTLE TO DO. IF ( KNOWN ) THEN C => WE HAVE ALREADY INTERPRETED THE STRING, TAKE THE C => APPROPRIATE ACTION. ONLY CASES: A LONG KEYWORD C => OR PARAMETER WORD. IF ( RESULT .EQ. RESKEY .OR. RESULT .EQ. RESNKY ) THEN C => STRING IS INTERPRETABLE AS A KEYWORD. IF ( GOTSEP .AND. PARTYP .EQ. TLOGIC ) THEN IF ( RESULT .EQ. RESKEY ) THEN PARSTR(1) = 'TRUE' ELSE PARSTR(1) = 'FALSE' ENDIF ENDIF ELSEIF ( RESULT .EQ. RESPAR ) THEN C => LL(ERL) IS INTERPRETABLE AS A PARAMETER. IF ( GOTDEL ) THEN IF ( PARNUM .GT. 1 ) THEN STATE = SXPARM ELSE MESSIN = 4 ENDIF ELSE GO TO 10000 ENDIF ELSE C => STRING IS NOT PROPER. NOTE THAT WE WILL NOT C => ARRIVE HERE WHEN A LITERAL STRING IS PROPER, C => AS THIS POSSIBILITY IS HANDLED IMMEDIATELY C => UPON DISCOVERY THAT NEITHER OF STILLK OR C => STILLP IS TRUE. IF ( GOTDEL ) THEN C => UNKNOWN KEYWORD. MESSIN = 5 ELSE C => UNKNOWN KEYWORD WHICH DOES NOT PERMIT A PARAMETER C => OR AN UNKNOWN PARAMETER WITHOUT ITS KEYWORD. MESSIN = 6 ENDIF ENDIF ELSE C NOW INTERPRET. C CASE #4. ASSIGN 2400 TO AFTDEC GOTO 81000 ENDIF ELSE C => MUST BE A SPECIAL CHARACTER. TRAILD = F MAYBEP = F MAYBEN = F C CASE #5. ASSIGN 2500 TO AFTDEC GOTO 81000 ENDIF GOTO 10000 C............... C => THESE ARE THE RETURNS AFTER USING DECIDE. C CASE # 1. RESULT MUST BE RESKTR, RESSTR OR RESBAD. 2100 IF ( RESULT .EQ. RESKTR ) THEN STATE = SBNUMR ELSE IF ( RESULT .EQ. RESSTR ) THEN PTSVL = PTSVL - 1 STATE = SBSTR ELSE IF ( RESULT .EQ. RESBAD ) THEN MESSIN = 6 ELSE MESSIN = -4 ENDIF GOTO 200 C CASE #3. RESULT IS RESKTR OR RESBAD. 2300 IF ( RESULT .EQ. RESKTR ) THEN STATE = SBNUMR ELSE IF ( RESULT .EQ. RESBAD ) THEN MESSIN = 16 ELSE MESSIN = -4 ENDIF GOTO 200 C CASE #4. ANY VALUE OF RESULT IS POSSIBLE. 2400 IF ( RESULT .EQ. RESKEY .OR. RESULT .EQ. RESNKY ) THEN C => NOTHING TO DO. ELSE IF ( RESULT .EQ. RESKTR ) THEN STATE = SBNUMR DIGT = SMARKR - 1 GOTO 200 ELSE IF ( RESULT .EQ. RESPAR ) THEN C => NOTHING TO DO. ELSE IF ( RESULT .EQ. RESSTR ) THEN PTSVL = PTSVL - 1 STATE = SBSTR GOTO 200 ELSE IF ( RESULT .EQ. RESBAD ) THEN MESSIN = 5 ENDIF GOTO 10000 C CASE #5. RESULT CAN BE RESSTR OR RESBAD. 2500 IF ( RESULT .EQ. RESSTR ) THEN PTSVL = PTSVL - 1 STATE = SBSTR ELSE IF ( RESULT .EQ. RESKEY ) THEN IF ( PARTYP .EQ. TYCHAR) THEN STATE = SBCHAR ELSE IF ( PARTYP .EQ. TSTRNG ) THEN STATE = SBSTR PTSVL = 0 LL(SVL) = BLANK ELSE MESSIN = 7 ENDIF ELSE IF ( RESULT .EQ. RESBAD ) THEN MESSIN = 21 ELSE MESSIN = -4 ENDIF GOTO 200 C....................................................................... C-----STATE #3 (SXPARM) EXPECTING PARAMETER C => TEST TO SEE WHETHER ANOTHER PARAMETER IS VALID, AND IF SO, IF C THERE IS ROOM IN PARS FOR IT. THE TYPE AND KEYWORD ARE KNOWN. 3000 IF ( NPARS .GE. PARNUM ) THEN C => TOO MANY PARAMETERS. MESSIN = 10 GOTO 10000 ELSEIF ( NPARS .GE. MXPARS ) THEN C => IMPLEMENTATION ERROR. MESSIN = 25 GOTO 10000 ENDIF KNOWN = F TRYF = SMARKR IF ( PARTYP .EQ. TYCHAR ) THEN STATE = SBCHAR ELSE IF ( PARTYP .EQ. TSTRNG ) THEN STATE = SBSTR PTSVL = 0 LL(SVL) = BLANK ELSEIF ( GOTALF ) THEN C => IF AN (ALPHABETIC) PARAMETER WORD IS PROPER, C => GO TO STATE SBPWRD; OTHERWISE, IF A LITERAL STRING IS C => PROPER, GO TO STATE SBSTR. IF ( PARTYP .EQ. TYREAL .OR. PARTYP .EQ. TINTGR ) THEN MESSIN = 8 ELSE IF ( PARTYP .EQ. TINTLT ) THEN STATE = SBSTR PTSVL = 0 LL(SVL) = BLANK ELSE STATE = SBPWRD ENDIF ELSEIF ( INSTRG ) THEN IF ( PARTYP .EQ. TSTRNG .OR. PARTYP .EQ. TINTLT ) THEN STATE = SBSTR PTSVL = 0 LL(SVL) = BLANK ELSE MESSIN = 23 ENDIF ELSEIF ( GOTNUM ) THEN C => IF A NUMBER IS PROPER, GO TO STATE SBNUMR. STATE = SBNUMR DIGF = SMARKR ELSEIF ( SEPDEL ) THEN C => NO SEPARATOR OR DELIMITER IS ACCEPTABLE NOW. MESSIN = 3 ELSE C => AND NEITHER IS ANY OTHER CHARACTER. MESSIN = 7 ENDIF IF ( MESSIN .EQ. 0 ) THEN NPARS = NPARS + 1 ENDIF GOTO 200 C....................................................................... C-----STATE #4 (SBNUMR) BUILDING NUMERIC PARAMETER. HERE THE KEYWORD AND C TYPE ARE BOTH KNOWN. 4000 IF ( GOTNUM .OR. GOTALF ) THEN C => CHARACTER IS PROPER FOR A NUMBER. CHECK SYNTAX. IF ( NOSTAT .EQ. NOERRR ) THEN MESSIN = 15 ELSE DIGT = SMARKR ENDIF ELSEIF ( SEPDEL ) THEN C => INTERPRET NUMBER AS A REAL OR INTEGER. PARSTR(NPARS) = BLANK IF ( HAVFRC .OR. NOSTAT .EQ. NOEXNO ) THEN I = DIGT - DIGF + 1 WRITE ( RFRMAT(8:13), '(I6)' ) I READ ( LL(ERL)(DIGF:DIGT), RFRMAT ) VALUE IF ( PARTYP .NE. TYREAL .AND. - RD( NINT(VALUE) ) .NE. VALUE ) THEN MESSIN = 15 ENDIF ELSE IF ( NOSTAT .EQ. NOINTG ) THEN B = 10 ELSE IF ( NOSTAT .EQ. NODECM ) THEN B = 10 DIGT = DIGT -1 ELSE IF ( NOSTAT .EQ. NOHEXD ) THEN B = 16 ELSE IF ( NOSTAT .EQ. NORADC ) THEN I = INDEX ( RADCON, LL(ERL)(DIGT:DIGT) ) IF ( I .NE. 0 ) THEN B = RADBAS(I) ELSE PARSTR(1) = RADX // LL(ERL)(DIGT:DIGT) DIGT = DIGT - 1 B = 10 ENDIF IF ( HAVRDX ) THEN DIGT = DIGT - 1 ENDIF ENDIF IF ( MESSIN .EQ. 0 ) THEN CALL ZZBASE(I1,B,LL(ERL)(DIGF:DIGT),*4200) ENDIF VALUE = RD(I1) ENDIF GOTO 4300 4200 MESSIN = 15 4300 CONTINUE IF ( MESSIN .EQ. 0 ) THEN PARVAL(NPARS) = VALUE ENDIF ELSE MESSIN = 15 ENDIF GO TO 10000 C....................................................................... C STATE #5 (SBPWRD) BUILDING ALPHABETIC PARAMETER TO BE C OBTAINED FROM PARAMETER DICTIONARY. 5000 IF ( HARD ) THEN C => NEXTCH IS PROPER FOR AN ALPHABETIC PARAMETER. TRYT = SMARKR ELSEIF ( SEPDEL ) THEN C => SEARCH FOR THE STRING IN THE PARAMETER WORD DICTIONARY. C => NOTE THAT THE PARAMETER WORD MAY HAVE ALREADY BEEN C => DETERMINED FROM STATE SBEGIN IF VERY LONG. IF ( .NOT. KNOWN ) THEN C ===> CHECK THIS DINDEX = 0 5100 CALL ZZSRCH ( LL(ERL)(TRYF:TRYT),SLEN,PWDICT,PWLENG,SLEN, - DINDEX, T,UPCASE) IF ( DINDEX .NE. 0 ) THEN IF ( MAP(PWINFO( DINDEX, 1) ) .NE. KEYWRD ) THEN DINDEX = DINDEX + 1 GO TO 5100 ENDIF ENDIF IF ( DINDEX .NE. 0 ) THEN C => IT WAS FOUND IN A DICTIONARY, ACCEPT IT. PARVAL(NPARS) = RD ( PWINFO( DINDEX, 2 ) ) PARSTR(NPARS) = BLANK CALL ZZSHFT ( LL(ERL), TRYT+1, TRYF, SMARKR ) OFFST1 = (DINDEX-1) * SLEN +1 OFFST2 = DINDEX * SLEN EXCESS = T IGN = F CALL ZZBSTR( LL(ERL), TRYF, 0, SMARKR, - PWDICT( OFFST1 : OFFST2 ), EXCESS, IGN ) IF (EXCESS) THEN WRITE ( OUTPT, '(A)' ) ' INTERNAL DECODE STRING'// - ' CAPACITY EXCEEDED' ENDIF ELSE MESSIN = 16 ENDIF ENDIF ELSE MESSIN = 17 ENDIF GO TO 10000 C....................................................................... C-----STATE # 6 (SBCHAR) A SINGLE CHARACTER PARAMETER. 6000 IF ( .NOT. SEPDEL ) THEN IF ( NPARS .EQ. LASTCP ) THEN IF ( NPARS .GE. PARNUM ) THEN C => THE USER HAS SPECIFIED TOO MANY PARAMETERS. MESSIN = 10 GOTO 10000 ELSEIF ( NPARS .GE. MXPARS ) THEN C => IMPLEMENTATION ERROR. MESSIN = -3 GOTO 10000 ENDIF NPARS = NPARS + 1 ENDIF PARSTR(NPARS) = NEXTCH PARVAL(NPARS) = RD( ICHAR(NEXTCH) ) LASTCP = NPARS ENDIF GO TO 10000 C....................................................................... C-----STATE # 7 (SBSTR) BUILD A LITERAL STRING. 7000 IF ( .NOT. SEPDEL ) THEN C => ADD NEXTCH TO THE STRING. TRYT = SMARKR PTSVL = PTSVL + 1 LL(SVL)(PTSVL:PTSVL) = NEXTCH ELSE PARSTR(NPARS) = LL(ERL)(TRYF:TRYT) ENDIF GO TO 10000 C....................................................................... C END OF PROCESSING FOR THIS CHARACTER. 10000 IF ( GOTDEL ) THEN STATE = SXPARM NOSTAT = NOSTRT ELSE IF ( GOTSEP ) THEN IF ( MESSIN .NE. 0 ) THEN IF ( LP .GT. LINLEN ) THEN MODE = DCDDON ELSE MODE = DCDERR LINLEN = LP - 1 ENDIF GOTO 82000 ELSE C => EXIT AFTER SUCCESSFULLY ANALYZING A STRING. IF ( PARTYP .EQ. TLOGIC ) THEN IF ( RESULT .EQ. RESKEY ) THEN PARSTR(1) = 'TRUE' ELSE PARSTR(1) = 'FALSE' ENDIF NPARS = 1 ENDIF IF ( LP .LT. LINLEN ) THEN C => DROP ANALYZED PORTION. CALL ZZSHFT ( LL(LNO), LP+1, 1, LINLEN ) LINLEN = LINLEN - LP MODE = DCDMOR ELSE LINLEN = 0 LL(LNO) = BLANK MODE = DCDDON ENDIF GOTO 90000 ENDIF ENDIF GOTO 100 C>>>>>>>>>>>>>>>>>>>>> R E M O T E B L O C K 1 <<<<<<<<<<<<<<<<<<<<< C => DECIDE ON THE INTERPRETATION OF THE STRING. C RESULT: RESKEY. A KEYWORD. C RESNKY. A KEYWORD PRECEDED BY "NO". C RESKTR. A KEYWORD WITH A TRAILING NUMBER. C RESPAR. A PARAMETER WORD FROM A DICTIONARY. C RESSTR. A LITERAL STRING. C RESBAD. INVALID INTERPRETATION. 81000 KNOWN = T IGN = F IF (TRACE) WRITE (TRACUN,*) - 'MAYBEK,MAYBEN,MAYBEP,HAVKTR ', - MAYBEK,MAYBEN,MAYBEP,HAVKTR IF ( MAYBEP ) THEN I = MAP( PWINFO( OLDPIN, 1 )) IF ( DEFKEY .GT. 0 .AND. DFPTYP .EQ. TINTPW - .AND. I .NE. DEFKEY ) THEN C => SEARCH THE PARAMETER DICTIONARY. NEWPIN = OLDPIN 81100 NEWPIN = NEWPIN + 1 CALL ZZSRCH(LL(ERL)(TRYF:TRYT),SLEN,PWDICT,PWLENG,SLEN, - NEWPIN, T,UPCASE ) IF ( NEWPIN .GT. 0 ) THEN I = MAP( PWINFO( NEWPIN, 1 )) NEWKIN = MAP( PWINFO( NEWPIN, 1 ) ) IF ( NEWKIN .NE. DEFKEY ) THEN C => TRY AGAIN. GOTO 81100 ELSE C => WE HAVE FOUND A SUITABLE PARAMETER WORD SO C => WE MUST USE THIS PARAMETER FOR THE DEFAULT. OLDKIN = DEFKEY OLDPIN = NEWPIN ENDIF ELSE C => NOTHING BETTER FOUND SO C => RETAIN ORIGINAL INTERPRETATION. ENDIF ELSE IF ( I .EQ. DEFKEY ) THEN OLDKIN = DEFKEY ENDIF C FOR IF FOUND ANOTHER. ENDIF IF ( MAYBEP .AND. OLDKIN .EQ. DEFKEY ) THEN C => ACCEPT A PARAMETER. GIVE PREFERENCE TO A PARAMETER C => WHICH FITS STRING AND HAS DEFKEY AS ITS KEYWORD. KEYWRD = OLDKIN NPARS = 1 PARVAL(1) = RD ( PWINFO(OLDPIN,2) ) RESULT = RESPAR OFFST1 = (KEYWRD-1) * SLEN +1 OFFST2 = KEYWRD * SLEN CALL ZZBSTR( LL(ERL), 1, 0, SMARKR, - KWDICT( OFFST1 : OFFST2 ), EXCESS, IGN ) CALL ZZBSTR( LL(ERL), SLEN+1, 0, SMARKR, - ASSGN, EXCESS, IGN ) TRYF = TRYF + SLEN +1 TRYT = TRYT + SLEN +1 CALL ZZSHFT ( LL(ERL), TRYT+1, TRYF, SMARKR ) OFFST1 = (OLDPIN-1) * SLEN +1 OFFST2 = OLDPIN * SLEN CALL ZZBSTR( LL(ERL), TRYF, 0, SMARKR, - PWDICT( OFFST1 : OFFST2 ), EXCESS, IGN ) ELSE IF ( MAYBEK .AND. MAYBEN ) THEN C => ACCEPT THE KEYWORD FOUND C WITHOUT THE "NO". KEYWRD = OLDKIN RESULT = RESKEY CALL ZZSHFT ( LL(ERL), TRYT+1, TRYF, SMARKR ) OFFST1 = (KEYWRD-1) * SLEN +1 OFFST2 = KEYWRD * SLEN CALL ZZBSTR( LL(ERL), TRYF, 0, SMARKR, - KWDICT( OFFST1 : OFFST2 ), EXCESS, IGN ) ELSE IF ( MAYBEK ) THEN C KEYWORD. KEYWRD = OLDKIN RESULT = RESKEY CALL ZZSHFT ( LL(ERL), TRYT+1, TRYF, SMARKR ) OFFST1 = (KEYWRD-1) * SLEN +1 OFFST2 = KEYWRD * SLEN CALL ZZBSTR( LL(ERL), TRYF, 0, SMARKR, - KWDICT( OFFST1 : OFFST2 ), EXCESS, IGN ) ELSE IF ( MAYBEN .AND. OLDNIN .NE. 0 ) THEN C "NO" KEYWORD. KEYWRD = OLDNIN RESULT = RESNKY CALL ZZSHFT ( LL(ERL), TRYT+1, TRYF+2, SMARKR ) OFFST1 = (KEYWRD-1) * SLEN +1 OFFST2 = KEYWRD * SLEN CALL ZZBSTR( LL(ERL), TRYF+2, 0, SMARKR, - KWDICT( OFFST1 : OFFST2 ), EXCESS, IGN ) ELSE IF ( HAVKTR .AND. TRAILD .AND. TRYT .GT. KEYPTR ) THEN KEYWRD = KTRIND DIGF = KEYPTR + 1 NPARS = 1 RESULT = RESKTR CALL ZZSHFT ( LL(ERL), KEYPTR+1, TRYF, SMARKR ) OFFST1 = (KEYWRD-1) * SLEN +1 OFFST2 = KEYWRD * SLEN CALL ZZBSTR( LL(ERL), TRYF, 0, SMARKR, - KWDICT( OFFST1 : OFFST2 ), EXCESS, IGN ) CALL ZZBSTR( LL(ERL), SMARKR, 0, SMARKR, ASSGN, EXCESS,IGN) DIGF = DIGF + SLEN - TRYT +2 DIGT = DIGT + SLEN - TRYT +2 ELSE IF ( MAYBEP ) THEN C => ACCEPT A PARAMETER. GIVE PREFERENCE TO A PARAMETER C => WHICH FITS STRING AND HAS DEFKEY AS ITS KEYWORD. KEYWRD = MAP(PWINFO(OLDPIN,1)) NPARS = 1 PARVAL(1) = RD ( PWINFO(OLDPIN,2) ) RESULT = RESPAR OFFST1 = (KEYWRD-1) * SLEN +1 OFFST2 = KEYWRD * SLEN CALL ZZBSTR( LL(ERL), 1, 0, SMARKR, - KWDICT( OFFST1 : OFFST2 ), EXCESS, IGN ) CALL ZZBSTR( LL(ERL), SLEN+1, 0, SMARKR, - ASSGN, EXCESS, IGN ) TRYF = TRYF + SLEN +1 TRYT = TRYT + SLEN +1 CALL ZZSHFT ( LL(ERL), TRYT+1, TRYF, SMARKR ) OFFST1 = (OLDPIN-1) * SLEN +1 OFFST2 = OLDPIN * SLEN CALL ZZBSTR( LL(ERL), TRYF, 0, SMARKR, - PWDICT( OFFST1 : OFFST2 ), EXCESS, IGN ) ELSE C => TAKE IT AS A LITERAL STRING, IF POSSIBLE. IF ( CANSTR ) THEN KEYWRD = DEFKEY NPARS = 1 RESULT = RESSTR ELSE RESULT = RESBAD ENDIF ENDIF IF ( RESULT .NE. RESBAD ) THEN PARNUM = KWINFO(KEYWRD,1) PARTYP = KWINFO(KEYWRD,2) ENDIF IF (TRACE) WRITE (TRACUN,*) 'RESULT,KEYWRD,PARNUM,PARTYP ', - RESULT,KEYWRD,PARNUM,PARTYP GOTO AFTDEC C## E R R O R S: C EXIT WITH AN ERROR CONDITION. 82000 MODE = DCDERR KEYWRD = -EXIT( MESSIN ) IF ( KEYWRD .LT. -NERROR ) THEN C => ALWAYS A FATAL ERROR. CALL ZZERRM ( VALUE, *91000, - 'NT DECODE FATAL ERROR : ' // MESSAG( MESSIN ) ) ELSE C => LEAVE IT TO USER TO DECIDE. CALL ZZERRM ( VALUE, *91000, - 'NT DECODE ERROR : ' // MESSAG( MESSIN ) ) ENDIF GO TO 90000 C## E N T R Y ZZZZZZ: ENTRY ZZDSET ( DCC ) CONTIN = DCC(CONT :CONT ) DELIMT = DCC(DEL :DEL ) ESCAPC = DCC(ESC :ESC ) SEPAR = DCC(SEP :SEP ) RADX = DCC(RADIX :RADIX ) COMM1 = DCC(COM1 :COM1 ) COMM2 = DCC(COM2 :COM2 ) GLOOP = DCC(LOOPG :LOOPG ) ALOOP = DCC(LOOPA :LOOPA ) STR1 = DCC(STRNG1:STRNG1) STR2 = DCC(STRNG2:STRNG2) ASSGN = DCC(ASSMT :ASSMT ) RETURN C## E X I T 90000 CONTINUE IF ( MODE .NE. DCDCON ) THEN IF (TRACE) WRITE (TRACUN,*) 'MODE, KEYWRD, NPARS==> ', - MODE,KEYWRD,NPARS IF (TRACE) WRITE (TRACUN,*) 'STRINGS==> ', - (PARSTR(I),I=1,NPARS) IF (TRACE) WRITE (TRACUN,*) 'VALUES ==> ', - (PARVAL(I),I=1,NPARS) IF ( VERIFY .AND. SMARKR .NE. 0 ) THEN I = 1 90500 IF ( I+INLINE .LT. SMARKR ) THEN WRITE ( OUTPT, '(A,A)' ) ' ',LL(ERL)(I:I+INLINE-1) I = I + INLINE GOTO 90500 ENDIF WRITE ( OUTPT, '(A,A)' ) ' ', LL(ERL)(I:SMARKR) ENDIF ENDIF RETURN C-----RETURN ON ERROR. 91000 RETURN 1 C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZDCOD. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> dsolsg.f SUBROUTINE ZZDSOL ( N, F, X, W, SOLNS, DF, DX, SOLNF, SOLNX ) C## A R G U M E N T S: INTEGER N, SOLNF, SOLNX REAL F, X(N), W(*), SOLNS(*), DF, DX C!!!! DOUBLE PRECISION F, X(N), W(*), SOLNS(*), DF, DX C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C>RCS $HEADER: DSOL.F,V 2.1 91/11/20 10:52:43 BUCKLEY EXP $ C>RCS $LOG: DSOL.F,V $ C>RCS REVISION 2.1 91/11/20 10:52:43 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 2.0 90/07/31 11:24:09 BUCKLEY C>RCS ADDED BLAS CALL. C>RCS C>RCS REVISION 1.9 89/06/30 13:40:52 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.1 89/01/17 16:50:08 BUCKLEY C>RCS INITIAL REVISION C>RCS C## D E S C R I P T I O N: C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZDSOL. C## S U B R O U T I N E S: ABS, MAX, NINT INTRINSIC C ZZVECT GENERATE VECTORS C## P A R A M E T E R S: REAL ZERO, ONE, TWO, THREE C!!!! DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) REAL FOUR, FIVE, SIX, SEVEN C!!!! DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) REAL EIGHT, NINE, TEN C!!!! DOUBLE PRECISION EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 9D0, TEN = 10D0 ) C## L O C A L D E C L: INTEGER I, K, NSOLNS, PT, NCYC, DIM REAL Z, ZZNRM2, ARGS, TF C!!!! DOUBLE PRECISION Z, ZZNRM2, ARGS, TF C## S A V E: NONE SELECTED. C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NO DATA VALUES SET. C## E X E C U T I O N C## E X E C U T I O N NSOLNS = NINT(SOLNS(1)) PT = 2 DF = -ONE DX = -ONE SOLNX = 0 SOLNF = 0 DO 500 I = 1,NSOLNS DIM = NINT (SOLNS(PT+1)) IF ( DIM .EQ. N .OR. DIM .EQ. 0 ) THEN IF ( DF .EQ. -ONE ) THEN DF = ABS ( F-SOLNS(PT+2) ) TF = SOLNS(PT+2) SOLNF = I ELSE IF ( ABS (F-SOLNS(PT+2)) .LT. DF ) THEN DF = ABS ( F-SOLNS(PT+2) ) TF = SOLNS(PT+2) SOLNF = I ENDIF NCYC = NINT (SOLNS(PT)) IF ( NCYC .NE. 0 ) THEN DO 190 K = 1,NCYC W(K) = SOLNS(PT+2+K) 190 CONTINUE C C IF THE VALUE OF NCYC IS 1, THEN THAT ONE NUMBER IN THE CYCLE SPECIFIES C THE SPECIAL VECTOR IN ZZVECT TO BE USED AS A SOLUTION VECTOR. C IF ( NCYC .EQ. 1 ) NCYC = -NINT( SOLNS(PT+3) ) C C SET ARGS FOR SOLUTIONS IN WHICH MORE THAN ONE COMPONENT HAS THE C VALUE X(1). I.E. FUNCTIONS BRWNAL AND BOX66. C IF ( NCYC .EQ. -16 .OR. - NCYC .EQ. -17 .OR. - NCYC .EQ. -18 ) ARGS = X(1) C C SET ARGS FOR SOLUTIONS IN WHICH MORE THAN ONE COMPONENT HAS THE C VALUE X(3). I.E. FUNCTION TOIN4. C IF ( NCYC .EQ. -19 ) ARGS = X(3) C CALL ZZVECT ( NCYC, N, SOLNS(PT+3), W, ARGS ) CALL ZZAXPY ( N, -ONE, X, 1, W, 1 ) Z = ZZNRM2 ( N, W ) IF ( DX .EQ. -ONE ) THEN DX = Z SOLNX = I ELSE IF ( Z .LT. DX ) THEN DX = Z SOLNX = I ENDIF ENDIF ENDIF PT = PT + 3 + MAX(NCYC,0) 500 CONTINUE IF ( DF .NE. -ONE ) F = TF GOTO 90000 C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZDSOL. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> dsrtsg.f SUBROUTINE ZZDSRT ( DICT, DKINF, DICTLN, KEYLEN, MAP, INVMAP, - FORW, MAPFL, STR1, STR2 ) C## A R G U M E N T S: INTEGER DICTLN, FORW, KEYLEN LOGICAL MAPFL INTEGER DKINF(DICTLN,2), MAP(DICTLN) INTEGER INVMAP(DICTLN) CHARACTER*(*) DICT, STR1, STR2 C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NOT REQUIRED. C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: DSRT.F,V 1.10 91/11/20 10:52:44 BUCKLEY EXP $ C>RCS $LOG: DSRT.F,V $ C>RCS REVISION 1.10 91/11/20 10:52:44 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.9 89/06/30 13:38:15 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 16:42:36 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 12:20:23 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:47:20 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:50:08 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE SORTS A DICTIONARY ( OF LENGTH DICTLN ENTRIES ) C INTO INCREASING ALPHABETICAL ORDER. THE DICTIONARY ENTRIES ARE C PACKED INTO A SINGLE LONG STRING. THE CORRESPONDING ENTRIES C OF DKINF ARE SORTED ALSO. C C SORTING STARTS FROM THE ELEMENT INDICATED BY FORW. IF FORW C IS POSITIVE, SORTING IS DONE FROM THERE TO THE END OF THE ARRAY C IN FORWARD ORDER, BUT IF IT IS NEGATIVE, SORTING IS FROM ELEMENT C ABS(FORW) IN REVERSE ORDER TO THE START OF THE ARRAY. THIS IS C NICE FOR SINGLE REPLACEMENTS SINCE A BUBBLE SORT IS USED. C C IF MAPFL IS TRUE, THEN THE CORRESPONDENCE BETWEEN THE ORIGINAL C AND FINAL ORDER IS KEPT IN THE INDEX ARRAYS MAP AND INVMAP. C OTHERWISE, MAP AND INVMAP ARE NOT ACCESSED IN THIS ROUTINE. C C STR1, STR2 TEMPORARY STRINGS OF THE SAME LENGTH AS THE INDIVI- C DUAL ENTRIES IN THE DICTIONARY, I.E. THE SAME LENGTH C AS EACH KEYWORD IN THE DICTIONARY. C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZDSRT C## S U B R O U T I N E S: ABS, LGT ...INTRINSIC C## P A R A M E T E R S: NONE ARE DEFINED. C## L O C A L D E C L: INTEGER PT1, PT2, TP1,INCR, LAST, FIRST,I INTEGER KEYLN1, PTK1, PTK2, QUIT, ENDPS1 LOGICAL ADV C## S A V E: NONE SELECTED. C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NONE ARE SET. C## E X E C U T I O N C## E X E C U T I O N ADV = FORW .GE. 0 IF ( ADV ) THEN INCR = 1 FIRST = DICTLN LAST = FORW + 1 ELSE INCR = -1 FIRST = 1 LAST = ABS(FORW) - 1 ENDIF ENDPS1 = FIRST KEYLN1 = KEYLEN - 1 800 IF ( ( FORW .GT. 0 .AND. ENDPS1 .GE. LAST ) .OR. - ( FORW .LT. 0 .AND. ENDPS1 .LE. LAST ) ) THEN PT1 = LAST - INCR PTK1 = PT1 * KEYLEN STR1 = DICT(PTK1-KEYLN1:PTK1) QUIT = PT1 DO 1000 PT2 = LAST, ENDPS1, INCR PTK2 = PT2 * KEYLEN STR2 = DICT(PTK2-KEYLN1:PTK2) IF ( ADV .EQV. LGT (STR1 , STR2) ) THEN C DO EXCHANGES. DICT(PTK2-KEYLN1:PTK2) = STR1 DICT(PTK1-KEYLN1:PTK1) = STR2 TP1 = DKINF(PT1,1) DKINF(PT1,1) = DKINF(PT2,1) DKINF(PT2,1) = TP1 TP1 = DKINF(PT1,2) DKINF(PT1,2) = DKINF(PT2,2) DKINF(PT2,2) = TP1 IF ( MAPFL ) THEN TP1 = INVMAP(PT1) INVMAP(PT1) = INVMAP(PT2) INVMAP(PT2) = TP1 ENDIF QUIT = PT1 PT1 = PT2 PTK1 = PT1*KEYLEN ELSE PT1 = PT2 PTK1 = PT1*KEYLEN STR1 = STR2 ENDIF 1000 CONTINUE ENDPS1 = QUIT GOTO 800 ENDIF C FOR THE "IF LAST PASS..." IF ( MAPFL ) THEN DO 3000 I = 1, DICTLN MAP ( INVMAP(I) ) = I 3000 CONTINUE ENDIF GOTO 90000 C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZDSRT. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> fnssg.f SUBROUTINE ZZFNS ( IFG, N, X, F, G, IW, WORK, DUMMY ) C!!!! SUBROUTINE ZZFNS ( IFG, N, X, F, G, IW, DUMMY, WORK ) C## A R G U M E N T S: INTEGER N, IFG, IW(*) REAL F, X(N), G(N), WORK(*) C!!!! DOUBLE PRECISION F, X(N), G(N), WORK(*) C *** THESE ARE **DELIBERATELY** OPPOSITE TO OTHER PAIRS. DOUBLE PRECISION DUMMY(*) C!!!! REAL DUMMY(*) C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: FNS.F,V 2.1 91/11/20 10:52:45 BUCKLEY EXP $ C>RCS $LOG: FNS.F,V $ C>RCS REVISION 2.1 91/11/20 10:52:45 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 2.0 90/07/31 11:29:18 BUCKLEY C>RCS DRIVER LEFT AFTER SPLITTING INTO 4 PARTS. C>RCS C>RCS REVISION 1.9 89/06/30 13:32:52 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.5 89/05/29 21:57:35 BUCKLEY C>RCS FIXES FUNCTION NO = 0 C>RCS C>RCS REVISION 1.3.1.1 89/05/20 16:42:37 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 12:20:24 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:47:22 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:50:08 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE DETERMINES THE SUBROUTINE TO BE CALLED THAT C WILL EVALUATE ONE OF THE STANDARD TEST FUNCTIONS. THE TEST C FUNCTIONS ARE SEPARATED INTO FOUR ROUTINES BECAUSE A SINGLE C ROUTINE IS TOO LARGE FOR SOME COMPILERS. THE ARGUMENTS IN THE C CALLING SEQUENCE HAVE PRECISELY THE SAME MEANING AS IN THE C ROUTINE ZZEVAL. C C THE TEST FUNCTION TO USE IS SELECTED BY CALLING THE ENTRY C POINT ZZFSET. THE VALUE OF THE INTEGER ARGUMENT FUNC SPECIFIES C WHICH OF THE TEST FUNCTIONS IS TO BE USED; THE SUBROUTINE C CONTAINING THE SPECIFIED TEST FUNCTION IS CHOSEN USING A COMPUTED C GOTO. C C SOME OF THE FUNCTIONS NEED SPECIAL ARGUMENTS (OTHER THAN THE C VALUE OF X); THESE ARE PROVIDED THROUGH THE ENTRY POINT ZZFPAR. A C MAXIMUM OF FNO (CURRENTLY TEN) ARGUMENTS ARE PROVIDED. IF THE C MAXIMUM NUMBER OF ARGUMENTS IS TO BE INCREASED, THE PARAMETER FNO C SHOULD BE INCREASED IN THE APPROPRIATE INCLUDE FILE. C C ALL FUNCTION ARGUMENTS ARE REAL (OR DOUBLE PRECISION). INTEGER C VALUES MAY BE PASSED BY ASSIGNING THE INTEGER VALUE TO A REAL C ARGUMENT AND THEN USING NINT TO RECOVER THE INTEGER VALUE. C C THE AMOUNT OF SPACE AVAILABLE IN THE ARRAY WORK IS DEFINED C BY CALLING THE ENTRY POINT ZZFSET. THIS MEANS THAT IT DOES NOT C HAVE TO BE PROVIDED IN THE CALL TO ZZFNS OR IN THE CALL TO ZZEVAL. C IT IS ALSO EASIER SINCE IT SELDOM CHANGES. C C>>>>> NOTE : IF WE SUPPOSE THAT EACH OF THE TEST FUNCTIONS HAD C>>>>> BEEN CODED AS A SEPARATE ROUTINE, THEN, UNLESS C>>>>> OTHERWISE SPECIFIED, ALL TEST FUNCTIONS WOULD HAVE C>>>>> HAD AN ARGUMENT LIST AS FOLLOWS: C>>>>> C>>>>> ( IFG, N, X, F, G ) C>>>>> C>>>>> THOSE WHICH WOULD REQUIRE ADDITIONAL ARGUMENTS ARE C>>>>> NOTED BY GIVING A SUITABLE CALLING SEQUENCE. THIS C>>>>> SERVES TO DEFINE THE SPECIAL ARGUMENTS FOR THOSE TEST C>>>>> FUNCTIONS. SEE FOR EXAMPLE PENAL2 AT 5100 IN ZZFNS1. C C## E N T R Y P O I N T S: C C ZZFNS THE NATURAL ENTRY POINT. C ZZFSET THE ENTRY POINT TO SELECT A PARTICULAR FUNCTION. C IT ALSO SETS THE SIZE OF WORKING STORAGE AVAILABLE. C ZZFFDF AN ENTRY TO REDEFINE CODES FOR FUNCTION EVALUATIONS. C ZZFRDF AN ENTRY TO REDEFINE CODES FOR RETURN CODES. C ZZFPAR AN ENTRY TO DEFINE ARGUMENTS NEEDED BY TEST FUNCTIONS. C C## S U B R O U T I N E S: C C ZZFNS1, ZZFNS2, ZZFNS3, ZZFNS4: ROUTINES CONTAINING THE TEST C FUNCTIONS. C C## P A R A M E T E R S: INTEGER JUSTF, BOTH, JUSTG, NOOP PARAMETER ( JUSTF = 1, BOTH = 0, JUSTG = -1, NOOP = 2 ) INTEGER PNAMLN, FNAMLN, GNAMLN PARAMETER ( PNAMLN = 8, FNAMLN = PNAMLN, GNAMLN = PNAMLN ) INTEGER TITLEN, PDESCL PARAMETER ( TITLEN = 72, PDESCL = 72 ) INTEGER NOFNS, DFPRBS, MXGRPS, MXGSZ PARAMETER ( NOFNS = 80, DFPRBS = 450, MXGRPS = 50, MXGSZ = 200 ) INTEGER FNO PARAMETER ( FNO = 10 ) C THE RETURN CODES TO BE USED BY THE FUNCTION EVALUATION ROUTINE C TO INDICATE TO THE MINIMIZATION ROUTINE WHETHER OR NOT THE CALL C WAS SUCCESSFUL. INTEGER COK, CABORT, CLIMIT PARAMETER ( COK = 0, CABORT = -1, CLIMIT = -2 ) INTEGER CNOF, CNOG, CNOFG PARAMETER ( CNOF = -3, CNOG = -4, CNOFG = -5 ) C## L O C A L D E C L: INTEGER SOK, SABORT, SLIMIT, SNOF, SNOG, SNOFG CHARACTER*(FNAMLN) NAMES(NOFNS), SETFNC INTEGER DIMNS(NOFNS) INTEGER FUNCNO, SIZE, SDOF, SDOFG, SDOG, SNOOP INTEGER SETSIZ, DIMN, FUNC, I, STATUS(7) INTEGER DOF, DOFG, DOG, NEITHR LOGICAL FIRST, FONLY, GONLY REAL FARG ( FNO ), SARG ( FNO ) C!!!! DOUBLE PRECISION FARG ( FNO ), SARG ( FNO ) C## S A V E: SAVE FUNCNO, FARG, SIZE, FIRST SAVE DOF, DOG, DOFG, NEITHR SAVE STATUS SAVE NAMES C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA NAMES /'ROSENB','HELIX ','PWSING','WOODS ','NONDIA', - 'TRIDIA','POWER ','EXTRSN','CHNRSN','MANCIN', - 'BIGGS ','POWBSC','JENSMP','FRDRTH','BROWNB', - 'BOX66 ','HILBRT','HIMM1 ','HIMLN3','BEAL58', - 'ENGVL1','DIXON ','ZANGWL','SCHMVT','ENGVL2', - 'BARD70','CRGLVY','HIMM25','QUARTC','TRIGTO', - 'HIMM28','TOINT ','GULF ','ARGAUS','MEYER ', - 'BROWND','KOWOSB','OSBRN1','OSBRN2','PENAL1', - 'PENAL2','WATSON','PENAL3','VAROSB','VARDIM', - 'RECIPE','CLIFF ','CHEBYQ','HIMM32','HIMM27', - 'BRYTRI','BRWNAL','ARGQDN','ARGQDO','ARGQDZ', - 'MOREBV','BROY7D','BRKMCC','HIMM29','HIMM33', - 'HIMM30','GOTTFR','BRYBND','CLUSTR','ARTRIG', - 'SQRTMX','MNSRF1','HYPCIR','SISSER','DIX7DG', - 'MORCIN','BOOTH ','POWSSQ','MNSRF2','GENRSN', - 'FRANK ','TDQUAD','TOIN2 ','TOIN4 ',' '/ DATA DIMNS / 2, 3, 4, 4, 2, 2, 2, 2, 2, 2, - 3, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 3, 3, 3, 3, 4, 2, 2, 25, - 2, 50, 3, 2, 3, 4, 4, 5, 11, 2, - 2, 2, 2, 2, 2, 3, 2, 2, 4, 2, - 2, 2, 2, 2, 2, 2, 60, 2, 2, 2, - 3, 2, 2, 2, 2, 9, 2, 2, 2, 9, - 10, 2, 2, 2, 2, 2, 3, 3, 4, 0/ DATA FUNCNO /1/, SIZE /1/ DATA FARG / FNO * 1.D0 / DATA FIRST/.TRUE./ DATA DOF/JUSTF/, DOFG/ BOTH/, DOG/JUSTG/, NEITHR/NOOP/ DATA STATUS(1), STATUS(2), STATUS(3) - / COK, CABORT, CLIMIT / DATA STATUS(4), STATUS(5), STATUS(6) - / CNOF, CNOG, CNOFG / C## E X E C U T I O N C## E X E C U T I O N C--------- SET LOGICAL FLAGS AND SELECT FUNCTION. FONLY = IFG .EQ. DOF GONLY = IFG .EQ. DOG GOTO( - 1000, 2000, 1000, 2000, 2000, 2000, 2000, 2000, 3000, 2000, - 1000, 2000, 2000, 2000, 2000, 1000, 2000, 2000, 2000, 2000, - 2000, 2000, 2000, 1000, 1000, 1000, 1000, 2000, 2000, 3000, - 3000, 3000, 3000, 3000, 3000, 3000, 3000, 3000, 3000, 1000, - 1000, 3000, 3000, 3000, 3000, 3000, 3000, 3000, 3000, 3000, - 3000, 3000, 4000, 4000, 4000, 4000, 4000, 4000, 4000, 4000, - 4000, 4000, 4000, 4000, 4000, 4000, 4000, 4000, 4000, 4000, - 4000, 4000, 4000, 4000, 2000, 2000, 2000, 2000, 2000, 900 - ) FUNCNO 900 IFG = STATUS(2) GOTO 90000 1000 CALL ZZFNS1( N, X, F, G, WORK, SIZE, FONLY, GONLY, FIRST, FARG, - FUNCNO, STATUS ) IFG = STATUS(7) GOTO 90000 2000 CALL ZZFNS2( N, X, F, G, WORK, SIZE, FONLY, GONLY, FIRST, FARG, - FUNCNO, STATUS ) IFG = STATUS(7) GOTO 90000 3000 CALL ZZFNS3( N, X, F, G, WORK, SIZE, FONLY, GONLY, FIRST, FARG, - FUNCNO, STATUS ) IFG = STATUS(7) GOTO 90000 4000 CALL ZZFNS4( N, X, F, G, WORK, SIZE, FONLY, GONLY, FIRST, FARG, - FUNCNO, STATUS ) IFG = STATUS(7) GOTO 90000 C## E N T R Y ZZFFDF: ENTRY ZZFFDF ( SDOF, SDOG, SDOFG, SNOOP ) DOF = SDOF DOG = SDOG DOFG = SDOFG NEITHR = SNOOP RETURN C## E N T R Y ZZFRDF: ENTRY ZZFRDF(SOK,SABORT,SLIMIT,SNOF,SNOG,SNOFG) STATUS(1) = SOK STATUS(2) = SABORT STATUS(3) = SLIMIT STATUS(4) = SNOF STATUS(5) = SNOG STATUS(6) = SNOFG RETURN C## E N T R Y ZZFSET: ENTRY ZZFSET ( SETFNC, SETSIZ, FUNC, DIMN ) FUNCNO = 0 DO 82000 I = 1,NOFNS IF ( SETFNC .EQ. NAMES(I) ) THEN FUNCNO = I GOTO 82100 ENDIF 82000 CONTINUE 82100 SIZE = SETSIZ FIRST = .TRUE. FUNC = FUNCNO IF ( DIMN .NE. 0 ) THEN IF ( FUNCNO .GT. 0 ) THEN DIMN = DIMNS(FUNCNO) ELSE DIMN = 2 ENDIF ENDIF C PRINT*,'FUNCNO = ',FUNC RETURN C## E N T R Y ZZFPAR: ENTRY ZZFPAR ( SARG ) DO 80000 I = 1, FNO FARG (I) = SARG (I) 80000 CONTINUE RETURN C## E X I T 90000 CONTINUE RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZFNS. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> fns1sg.f SUBROUTINE ZZFNS1 ( N, X, F, G, WORK, SIZE, FONLY, GONLY, - FIRST, FARG, FUNCNO, STATUS ) C## A R G U M E N T S: INTEGER N, SIZE, FUNCNO, STATUS(7) LOGICAL FIRST, FONLY, GONLY REAL F, X(N), G(N), WORK(SIZE), FARG(*) C!!!! DOUBLE PRECISION F, X(N), G(N), WORK(SIZE), FARG(*) C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: FNS1.F,V 1.2 92/01/07 15:12:07 BUCKLEY EXP $ C>RCS $LOG: FNS1.F,V $ C>RCSREVISION 1.2 92/01/07 15:12:07 BUCKLEY C>RCSMINOR FIX C>RCS C>RCSREVISION 1.1 91/11/20 10:52:47 BUCKLEY C>RCSFINAL SUBMISSION TO TOMS C>RCS C>RCSREVISION 1.0 90/07/31 13:01:55 BUCKLEY C>RCSINITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS SUBROUTINE EVALUATES ONE OF THE STANDARD TEST FUNCTIONS. C THE TEST FUNCTIONS ARE DIVIDED AMOUNG FOUR ROUTINES BECAUSE A C SINGLE ROUTINE WOULD BE TOO LARGE FOR SOME COMPILERS. C THE ARGUMENTS IN THE CALLING SEQUENCE HAVE PRECISELY THE SAME C MEANING AS IN THE ROUTINE ZZEVAL. C C THE VALUE OF THE INTEGER PARAMETER FUNCNO SPECIFIES C WHICH OF THE TEST FUNCTIONS IS TO BE USED; THE FUNCTION C IS CHOSEN USING A COMPUTED GOTO. C C THE PARAMETERS FONLY AND GONLY SPECIFY FUNCTION AND C GRADIENT EVALUATIONS. THE PARAMETER FIRST SPECIFIES CODE TO BE C EVALUATED ONLY ON THE FIRST CALL TO A PARTICULAR FUNCTION. C THE PARAMETER STATUS STORES THE RETURN CODES. C C## E N T R Y P O I N T S: ZZFNS1 THE NATURAL ENTRY POINT. C C## S U B R O U T I N E S: C C PREDEFINED FUNCTIONS : SIN, COS, TAN, ACOS, ATAN, ABS, MAX, NINT C EXP, LOG, MIN, MOD, SIGN, SQRT, REAL(DBLE) C C STATEMENT FUNCTION: RD C C## P A R A M E T E R S: REAL ZERO, ONE, TWO, THREE C!!!! DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) REAL FOUR, FIVE, SIX, SEVEN C!!!! DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) REAL EIGHT, NINE, TEN C!!!! DOUBLE PRECISION EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 9D0, TEN = 10D0 ) REAL TENTH, FIFTH, HALF C!!!! DOUBLE PRECISION TENTH, FIFTH, HALF PARAMETER ( TENTH = .1D0, FIFTH = .2D0, HALF = .5D0 ) REAL RPT9, RPT8, RD29 C!!!! DOUBLE PRECISION RPT9, RPT8, RD29 PARAMETER ( RPT9 = .9D0, RPT8 = .8D0, RD29 = 1D0/29D0 ) REAL R11, R12, R13, R14 C!!!! DOUBLE PRECISION R11, R12, R13, R14 PARAMETER ( R11 = 11D0, R12 = 12D0, R13 = 13D0,R14 = 14D0) REAL R15, R16, R17, R18 C!!!! DOUBLE PRECISION R15, R16, R17, R18 PARAMETER ( R15 = 15D0, R16 = 16D0, R17 = 17D0,R18 = 18D0) REAL R19, R20, R25, R29 C!!!! DOUBLE PRECISION R19, R20, R25, R29 PARAMETER ( R19 = 19D0, R20 = 20D0, R25 = 25D0,R29 = 29D0) REAL R32, R36, R40, R42 C!!!! DOUBLE PRECISION R32, R36, R40, R42 PARAMETER ( R32 = 32D0, R36 = 36D0, R40 = 40D0,R42 = 42D0) REAL R45, R49 C!!!! DOUBLE PRECISION R45, R49 PARAMETER ( R45 = 45D0, R49 = 49D0 ) REAL R50, R56, R84, R90 C!!!! DOUBLE PRECISION R50, R56, R84, R90 PARAMETER ( R50 = 50D0, R56 = 56D0, R84 = 84D0,R90 = 90D0) REAL R100, R180, R200 C!!!! DOUBLE PRECISION R100, R180, R200 PARAMETER ( R100 = 100D0, R180 = 180D0, R200 = 200D0 ) REAL R256, R360, R400 C!!!! DOUBLE PRECISION R256, R360, R400 PARAMETER ( R256 = 256D0, R360 = 360D0, R400 = 400D0 ) REAL R600, R681, R991 C!!!! DOUBLE PRECISION R600, R681, R991 PARAMETER ( R600 = 600D0, R681 = 681D0, R991 = 991D0 ) REAL R1162, R2324 C!!!! DOUBLE PRECISION R1162, R2324 PARAMETER ( R1162 = 1162D0, R2324 = 2324D0 ) REAL R10000, R40000 C!!!! DOUBLE PRECISION R10000, R40000 PARAMETER ( R10000 = 10000D0, R40000 = 40000D0 ) REAL R1PD6, R2PDM6 C!!!! DOUBLE PRECISION R1PD6, R2PDM6 PARAMETER ( R1PD6 = 1D6, R2PDM6 = 2D-6 ) REAL RP04, RP01, R1PZ1 C!!!! DOUBLE PRECISION RP04, RP01, R1PZ1 PARAMETER ( RP04 = 4D-2, RP01 = .01D0, R1PZ1 = 1.0001D0 ) REAL R1P2, R7P5, RP1136 C!!!! DOUBLE PRECISION R1P2, R7P5, RP1136 PARAMETER ( R1P2 = 1.2D0, R7P5 = 7.5D0, RP1136 = 0.1136D0 ) REAL R1P5, R2P5, R2P625 C!!!! DOUBLE PRECISION R1P5, R2P5, R2P625 PARAMETER ( R1P5 = 1.5D0, R2P5 = 2.5D0, R2P625 = 2.625D0 ) REAL R10P1, R19P8, R20P2 C!!!! DOUBLE PRECISION R10P1, R19P8, R20P2 PARAMETER ( R10P1 = 10.1D0,R19P8 = 19.8D0,R20P2 = 20.2D0 ) REAL R2D3, R4D3, R7D3 C!!!! DOUBLE PRECISION R2D3, R4D3, R7D3 PARAMETER ( R2D3 = 2D0/3D0,R4D3 = 4D0/3D0,R7D3 = 7D0/3D0 ) REAL R2P25 C!!!! DOUBLE PRECISION R2P25 PARAMETER ( R2P25 = 2.25D0 ) C## L O C A L D E C L: INTEGER OK, ABORT, LIMIT, NOF, NOG, NOFG INTEGER I1, I2, IB, IY, I, IDUMMY, J, K, RET LOGICAL GFIRST REAL ZZMPAR, HUGE C!!!! DOUBLE PRECISION ZZMPAR, HUGE C--------- VARIABLES FOR THE TEST FUNCTIONS. REAL X1, X2, X3, X4, X5, X6 C!!!! DOUBLE PRECISION X1, X2, X3, X4, X5, X6 REAL G1, G2, G3, G4, G5, G6 C!!!! DOUBLE PRECISION G1, G2, G3, G4, G5, G6 REAL W1, W2, W3, W4, W5, W6 C!!!! DOUBLE PRECISION W1, W2, W3, W4, W5, W6 REAL W7, W8, W9, W10, W11, W12 C!!!! DOUBLE PRECISION W7, W8, W9, W10, W11, W12 REAL T, BIGGST, SMLLST C!!!! DOUBLE PRECISION T, BIGGST, SMLLST REAL RI, TI, YI, PI, AI, BI C!!!! DOUBLE PRECISION RI, TI, YI, PI, AI, BI REAL R2P, RD, TPI, TPIS C!!!! DOUBLE PRECISION R2P, RD, TPI, TPIS REAL RF1, RF2 C!!!! DOUBLE PRECISION RF1, RF2 C--------- DATA ARRAYS FOR FUNCTIONS REAL BARD7Y (15) C!!!! DOUBLE PRECISION BARD7Y (15) C## S A V E: SAVE GFIRST, PI, TPI, TPIS, R2P, BIGGST, SMLLST, HUGE SAVE OK, ABORT, LIMIT, NOF, NOG, NOFG C--------- SAVE DATA ARRAYS FOR THE TEST FUNCTIONS. SAVE BARD7Y C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA GFIRST/.TRUE./ C--------- DATA FOR MINTEST FUNCTION BARD70 DATA BARD7Y( 1), BARD7Y( 2), BARD7Y( 3), BARD7Y( 4), BARD7Y( 5) - / .14 D0 , .18 D0 , .22 D0 , .25 D0 , .29 D0 / DATA BARD7Y( 6), BARD7Y( 7), BARD7Y( 8), BARD7Y( 9), BARD7Y(10) - / .32 D0 , .35 D0 , .39 D0 , .37 D0 , .58 D0 / DATA BARD7Y(11), BARD7Y(12), BARD7Y(13), BARD7Y(14), BARD7Y(15) - / .73 D0 , .96 D0 , 1.34 D0 , 2.10 D0 , 4.39 D0 / C## E X E C U T I O N C## E X E C U T I O N C--------- FUNCTION DEFINITION RD (IDUMMY) = REAL (IDUMMY) C!!!! RD (IDUMMY) = DBLE (IDUMMY) C--------- SOME ONE TIME ONLY CONSTANTS. IF ( GFIRST ) THEN PI = ACOS(-ONE) TPI = TWO * PI TPIS = TPI * PI R2P = ONE / TPI HUGE = ZZMPAR(3)/TEN SMLLST = LOG(ZZMPAR(2)*TEN) BIGGST = LOG(HUGE) OK = STATUS(1) ABORT = STATUS(2) LIMIT = STATUS(3) NOF = STATUS(4) NOG = STATUS(5) NOFG = STATUS(6) ENDIF C--------- SET LOGICAL FLAGS AND SELECT FUNCTION. RET = OK GOTO( - 1100, 1000, 1300, 1000, 1000, 1000, 1000, 1000, 1000, 1000, - 2100, 1000, 1000, 1000, 1000, 2600, 1000, 1000, 1000, 1000, - 1000, 1000, 1000, 3400, 3500, 3600, 3700, 1000, 1000, 1000, - 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 5000, - 5100, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, - 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, - 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, - 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000 - ) FUNCNO 1000 STATUS(7) = ABORT GOTO 91000 C--------- ROSENB C AI IS ALPHA, TAKEN FROM FARG 1 C BI IS BETA, TAKEN FROM FARG 2 C IY IS GAMMA, TAKEN FROM FARG 3 1100 CONTINUE AI = FARG(1) BI = FARG(2) IY = NINT(FARG(3)) W1 = X(1) IF ( .NOT. GONLY ) THEN F = BI * (ONE-W1)**2 ENDIF IF ( .NOT. FONLY ) THEN G(1) = -TWO * BI * (ONE-W1) ENDIF DO 1110 I=2,N W2 = X(I) W4 = W1**(IY-1) W3 = W2 - W1*W4 IF ( .NOT. GONLY ) THEN F = F + AI * W3**2 ENDIF IF ( .NOT. FONLY ) THEN G(I-1) = G(I-1) - TWO * AI * IY * W4 * W3 G(I) = TWO*AI * W3 ENDIF W1 = W2 1110 CONTINUE GOTO 90000 C--------- MINTEST FUNCTION PWSING 1300 IF ( .NOT. GONLY ) THEN F = ZERO ENDIF IF ( 4 * (N/4) .NE. N ) THEN IF ( .NOT. FONLY ) THEN DO 1310 I = 1,N G(I) = ZERO 1310 CONTINUE ENDIF ELSE DO 1320 I=1,N/4 J = 4*I W1 = X(J-3) W2 = X(J-2) W3 = X(J-1) W4 = X(J ) W5 = W1 + TEN * W2 W6 = W3 - W4 W2 = W2 - TWO * W3 W3 = W2 * W2 *W2 W1 = W1 - W4 W4 = W1 * W1 * W1 IF ( .NOT. GONLY ) THEN F = F + W5*W5 + FIVE*W6*W6 + W2*W3 + TEN*W1*W4 ENDIF IF ( .NOT. FONLY ) THEN G(J-3) = TWO * W5 + R40 * W4 G(J-2) = R20 * W5 + FOUR * W3 G(J-1) = TEN * W6 - EIGHT * W3 G(J ) = -TEN * W6 - R40 * W4 ENDIF 1320 CONTINUE ENDIF GOTO 90000 C--------- MINTEST FUNCTION BIGGS ( IFG, N, X, F, G, NINT(FARG(1))) C--------- NINT(FARG(1)) IS M 2100 IB = NINT(FARG(1)) X1 = X(1) X2 = X(2) IF ( N .EQ. 2 ) THEN X3 = ONE X4 = FIVE X5 = ZERO X6 = ZERO ELSE IF ( N .EQ. 3 ) THEN X3 = ONE X4 = X(3) X5 = ZERO X6 = ZERO ELSE IF ( N .EQ. 4 ) THEN X3 = X(3) X4 = X(4) X5 = ZERO X6 = ZERO ELSE IF ( N .EQ. 5 ) THEN X3 = X(3) X4 = X(4) X5 = X(5) X6 = THREE ELSE IF ( N .EQ. 6 ) THEN X3 = X(3) X4 = X(4) X5 = X(5) X6 = X(6) ENDIF IF ( .NOT. GONLY ) THEN F = ZERO ENDIF IF ( .NOT. FONLY ) THEN G(1) = ZERO G(2) = ZERO G(3) = ZERO G(4) = ZERO G(5) = ZERO G(6) = ZERO ENDIF DO 2110 I = 1, IB T = RD(I) TI = T/TEN IF ( MAX(-T,-TI*FOUR,-TI*X1,-TI*X2,-TI*X5) .LE. BIGGST ) THEN IF ( N .LE. 4 ) THEN YI = EXP(-TI) - FIVE * EXP(-T) ELSE YI = EXP(-TI) - FIVE * EXP(-T) + THREE*EXP(-FOUR*TI) END IF W1 = EXP(-TI*X1) W2 = EXP(-TI*X2) W5 = EXP(-TI*X5) ELSE RET = NOFG GOTO 90000 ENDIF RI = X3*W1 - X4*W2 + X6*W5 - YI IF ( .NOT. GONLY ) THEN F = F + RI*RI ENDIF IF ( .NOT. FONLY ) THEN W7 = TI*RI G(1) = G(1) - TWO * X3 * W1 * W7 G(2) = G(2) + TWO * X4 * W2 * W7 IF ( N .EQ. 3 ) THEN G(3) = G(3) - TWO * W2 * RI ELSE IF ( N .GE. 4 ) THEN G(3) = G(3) + TWO * W1 * RI G(4) = G(4) - TWO * W2 * RI IF ( N .GE. 5 ) THEN G(5) = G(5) - TWO * X6 * W5 * W7 IF ( N .EQ. 6 ) G(6) = G(6) + TWO * W5 * RI ENDIF ENDIF ENDIF 2110 CONTINUE GOTO 90000 C--------- MINTEST FUNCTION BOX663 ( N, X, F, G, IFG, NINT(FARG(1))) C--------- NINT(FARG(1)) IS M 2600 IF ( .NOT. GONLY ) THEN F = ZERO ENDIF IF ( .NOT. FONLY ) THEN G1 = ZERO G2 = ZERO IF ( N .EQ. 3 ) G3 = ZERO ENDIF DO 2610 I = 1,NINT(FARG(1)) W2 = RD(I) TI = W2/TEN IF ( MAX(-W2,-TI,-TI*X(1),-TI*X(2)) .LE. BIGGST ) THEN W3 = EXP(-TI * X(1)) W4 = EXP(-TI * X(2)) W5 = EXP(-TI) - EXP(-W2) ELSE RET = NOFG GOTO 90000 ENDIF IF ( N .EQ. 3 ) THEN RI = W3 - W4 - W5*X(3) ELSE RI = W3 - W4 - W5 ENDIF IF ( .NOT. GONLY ) THEN IF ( ABS(RI) .LE. SQRT(HUGE-MAX(F,ZERO)) ) THEN F = F + RI**2 ELSE RET = NOFG GOTO 90000 ENDIF ENDIF IF ( .NOT. FONLY ) THEN W2 = TI*RI G1 = G1 - W3*W2 G2 = G2 + W4*W2 IF ( N .EQ. 3 ) G3 = G3 - W5*RI ENDIF 2610 CONTINUE IF ( .NOT. FONLY ) THEN G(1) = TWO * G1 G(2) = TWO * G2 IF ( N .EQ. 3 ) G(3) = TWO * G3 ENDIF GOTO 90000 C--------- MINTEST FUNCTION SCHMVT EXTENSION DUE TO TOI83B #35. C---- FARG(1) IS ALPHA. 3400 CONTINUE AI = FARG(1) IF ( .NOT. GONLY ) THEN F = ZERO ENDIF IF ( .NOT. FONLY ) THEN DO 3410 I = 1, N G(I) = ZERO 3410 CONTINUE END IF DO 3420 I = 1, N-2 W1 = X(I) - X(I+1) W2 = X(I) + X(I+2) W3 = ONE + W1*W1 W4 = (PI*X(I+1) + X(I+2)) / TWO W5 = (W2/X(I+1)) - TWO IF ( -W5**2 .LE. BIGGST ) THEN W6 = EXP(-W5*W5) ELSE RET = NOFG GOTO 90000 ENDIF IF ( .NOT. GONLY ) THEN F = F + AI - ((ONE/W3) + SIN(W4) + W6 ) ENDIF IF ( .NOT. FONLY ) THEN W3 = TWO*W1/(W3*W3) W4 = COS(W4)/TWO W6 = TWO*W5*W6/X(I+1) G(I ) = G(I ) + W3 + W6 G(I+1) = G(I+1) - W3 - PI*W4 - W6*W2/X(I+1) G(I+2) = G(I+2) - W4 + W6 ENDIF 3420 CONTINUE GOTO 90000 C--------- MINTEST FUNCTION ENGVL2 3500 X1 = X(1) X2 = X(2) X3 = X(3) W1 = X1*X1 W2 = X1*W1 W3 = X2*X2 W4 = X3*X3 W5 = X3 - TWO W6 = FIVE*X3 - X1 + ONE W7 = W1 + W3 - ONE W8 = W7 + W4 W9 = W7 + W5*W5 W10 = X1 + X2 + X3 - ONE W11 = X1 + X2 - X3 + ONE W12 = W2 + THREE*W3 + W6*W6 - R36 IF ( .NOT. GONLY ) THEN F = W8*W8 + W9*W9 + W10*W10 + W11*W11 + W12*W12 ENDIF IF ( .NOT. FONLY ) THEN W10 = W8 + W9 G(1) = TWO*(TWO*X1*W10 + TWO*(X1+X2) + W12*(THREE*W1-TWO*W6)) G(2) = TWO*(TWO*X2*W10 + TWO*(X1+X2) + SIX*W12*X2) G(3) = TWO*(TWO*(W8*X3+W5*W9) + TWO*X3 - TWO + TEN*W12*W6) ENDIF GOTO 90000 C--------- MINTEST FUNCTION BARD70 3600 X1 = X(1) X2 = X(2) X3 = X(3) IF ( .NOT. GONLY ) THEN F = ZERO ENDIF IF ( .NOT. FONLY ) THEN G1 = ZERO G2 = ZERO G3 = ZERO ENDIF DO 3610 I=1,15 W1 = RD(I) W2 = RD(16-I) W3 = MIN(W1,W2) W4 = X2*W2 + X3*W3 RI = BARD7Y(I) - (X1 + W1/W4) W4 = W4*W4 IF ( .NOT. GONLY ) THEN F = F + RI*RI ENDIF IF ( .NOT. FONLY ) THEN W4 = RI*W1/W4 G1 = G1 - RI G2 = G2 + W2*W4 G3 = G3 + W3*W4 ENDIF 3610 CONTINUE IF ( .NOT. FONLY ) THEN G(1) = G1*TWO G(2) = G2*TWO G(3) = G3*TWO ENDIF GOTO 90000 C--------- MINTEST FUNCTION CRGLVY 3700 K = (N-2) / 2 F = ZERO IF ( .NOT. GONLY ) THEN DO 3720 I = 1, K W1 = X(2*I) - X(2*I+1) W2 = X(2*I+1) - X(2*I+2) W3 = X(2*I+2) - ONE IF ( X(2*I-1) .LE. BIGGST ) THEN W4 = EXP(X(2*I-1)) ELSE RET = NOFG GOTO 90000 ENDIF W5 = W4 - X(2*I) W6 = TAN(W2) F = F + W5**4 + R100*W1**6 + W6**4 + X(2*I-1)**8 + W3*W3 3720 CONTINUE ENDIF IF ( .NOT. FONLY ) THEN W1 = EXP(X(1)) W2 = FOUR*(W1 - X(2))**3 G(1) = W1*W2 + EIGHT*X(1)**7 G(2) = -W2 + R600*(X(2) - X(3))**5 DO 3740 I = 3, N-2 IF ( INT(I/2)*2 .NE. I ) THEN C ODD I W1 = R600 * (X(I-1) - X(I))**5 W2 = X(I) - X(I+1) W3 = FOUR * TAN(W2)**3 / COS(W2)**2 W4 = EXP(X(I)) W5 = FOUR*(W4 - X(I+1))**3 G(I) = -W1 + W3 + W4*W5 + EIGHT*X(I)**7 ELSE C EVEN I W6 = R600 * (X(I) - X(I+1))**5 G(I) = -W3 + TWO*(X(I) - ONE) - W5 + W6 ENDIF 3740 CONTINUE W2 = X(N-1) - X(N) W3 = FOUR * TAN(W2)**3 / COS(W2)**2 G(N-1) = -R600 * (X(N-2) - X(N-1))**5 + W3 G(N ) = -W3 + TWO*(X(N) - ONE) ENDIF GOTO 90000 C--------- MINTEST FUNCTION PENAL1 ( N, X, F, G, IFG, C FARG(1), FARG(2) ) C--------- FARG(1) IS A C--------- FARG(2) IS B 5000 RF1 = FARG ( 1 ) RF2 = FARG ( 2 ) W1 = - ONE / FOUR W2 = ZERO DO 5010 J = 1, N W3 = X(J) W1 = W1 + W3*W3 W3 = W3 - ONE W2 = W2 + W3*W3 5010 CONTINUE IF ( .NOT. GONLY ) THEN F = RF1*W2 + RF2 *W1*W1 ENDIF IF ( .NOT. FONLY ) THEN W1 = FOUR*RF2*W1 W2 = TWO*RF1 DO 5020 J = 1, N W3 = X(J) G(J) = W2 * (W3 - ONE) + W3*W1 5020 CONTINUE ENDIF GOTO 90000 C--------- MINTEST FUNCTION PENAL2 ( N, X, F, G, IFG, C FARG(1), FARG(2), WORK, SIZE) C--------- FARG(1) IS A C--------- FARG(2) IS B 5100 RF1 = FARG ( 1 ) RF2 = FARG ( 2 ) IF ( SIZE .LT. 2 * N ) THEN F = ZERO DO 5110 K = 1, N G(K) = ZERO 5110 CONTINUE GO TO 90000 ENDIF W1 = EXP(TENTH) W2 = EXP(-TENTH) W3 = ZERO I1 = 0 I2 = N DO 5120 K = 1, N W4 = X(K) W3 = W3 + RD( N - K + 1 ) * W4 * W4 IF ( TENTH*W4 .LE. BIGGST ) THEN W5 = EXP (TENTH * W4) ELSE RET = NOFG GOTO 90000 ENDIF IF ( K .EQ. 1 ) THEN W6 = ZERO W7 = ONE ELSE W7 = W9 * W1 W10 = W5 + W8 - (W7 + W9) W11 = W5 - W2 IF ( .NOT. FONLY ) THEN WORK(I1+K) = W10 WORK(I2+K) = W11 ENDIF IF ( .NOT. GONLY ) THEN W6 = W6 + W10*W10 + W11*W11 ENDIF ENDIF W8 = W5 W9 = W7 5120 CONTINUE W1 = X(1) - FIFTH W2 = W3 - ONE IF ( .NOT. GONLY ) THEN F = RF1 * W6 + RF2* ( W1*W1 + W2*W2 ) ENDIF IF ( .NOT. FONLY ) THEN W3 = FIFTH * RF1 W2 = FOUR * RF2 * W2 DO 5130 K = 1, N C ---NOTE THAT W8 DOES NOT NEED TO BE PRE-DEFINED WHEN K = 1. W4 = X(K) IF ( TENTH*W4 .LE. BIGGST ) THEN W5 = EXP(TENTH * W4) ELSE RET = NOFG GOTO 90000 ENDIF W6 = W8 W7 = WORK(I2+K) IF ( K .LT. N ) THEN W8 = WORK(I1+K+1) IF ( K .EQ. 1 ) THEN G(1) = W3 * W5 * ( W8 ) - + W2 * W4 * RD(N) + W1 * TWO * RF2 ELSE G(K) = W3 * W5 * ( W6 + W7 + W8 ) - + W2 * W4 * RD( N - K + 1 ) ENDIF ELSE G(N) = W3 * W5 * ( W6 + W7 ) - + W2 * W4 ENDIF 5130 CONTINUE ENDIF GOTO 90000 C## E X I T 90000 STATUS(7) = RET 91000 GFIRST = .FALSE. RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZFNS1. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> fns2sg.f SUBROUTINE ZZFNS2 ( N, X, F, G, WORK, SIZE, FONLY, GONLY, - FIRST, FARG, FUNCNO, STATUS ) C## A R G U M E N T S: INTEGER N, SIZE, FUNCNO, STATUS(7) LOGICAL FIRST, FONLY, GONLY REAL F, X(N), G(N), WORK(SIZE), FARG(*) C!!!! DOUBLE PRECISION F, X(N), G(N), WORK(SIZE), FARG(*) C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: FNS2.F,V 1.1 91/11/20 10:52:48 BUCKLEY EXP $ C>RCS $LOG: FNS2.F,V $ C>RCSREVISION 1.1 91/11/20 10:52:48 BUCKLEY C>RCSFINAL SUBMISSION TO TOMS C>RCS C>RCSREVISION 1.0 90/07/31 13:01:56 BUCKLEY C>RCSINITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS SUBROUTINE EVALUATES ONE OF THE STANDARD TEST FUNCTIONS. C THE TEST FUNCTIONS ARE DIVIDED AMOUNG FOUR ROUTINES BECAUSE A C SINGLE ROUTINE WOULD BE TOO LARGE FOR SOME COMPILERS. C THE ARGUMENTS IN THE CALLING SEQUENCE HAVE PRECISELY THE SAME C MEANING AS IN THE ROUTINE ZZEVAL. C C THE VALUE OF THE INTEGER PARAMETER FUNCNO SPECIFIES C WHICH OF THE TEST FUNCTIONS IS TO BE USED; THE FUNCTION C IS CHOSEN USING A COMPUTED GOTO. C C THE PARAMETERS FONLY AND GONLY SPECIFY FUNCTION AND C GRADIENT EVALUATIONS. THE PARAMETER FIRST SPECIFIES CODE TO BE C EVALUATED ONLY ON THE FIRST CALL TO A PARTICULAR FUNCTION. C THE PARAMETER STATUS STORES THE RETURN CODES. C C## E N T R Y P O I N T S: ZZFNS2 THE NATURAL ENTRY POINT. C C## S U B R O U T I N E S: C C PREDEFINED FUNCTIONS : SIN, COS, TAN, ACOS, ATAN, ABS, MAX, NINT C EXP, LOG, MIN, MOD, SIGN, SQRT, REAL(DBLE) C C STATEMENT FUNCTION: RD C C## P A R A M E T E R S: REAL ZERO, ONE, TWO, THREE C!!!! DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) REAL FOUR, FIVE, SIX, SEVEN C!!!! DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) REAL EIGHT, NINE, TEN C!!!! DOUBLE PRECISION EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 9D0, TEN = 10D0 ) REAL TENTH, FIFTH, HALF C!!!! DOUBLE PRECISION TENTH, FIFTH, HALF PARAMETER ( TENTH = .1D0, FIFTH = .2D0, HALF = .5D0 ) REAL RPT9, RPT8, RD29 C!!!! DOUBLE PRECISION RPT9, RPT8, RD29 PARAMETER ( RPT9 = .9D0, RPT8 = .8D0, RD29 = 1D0/29D0 ) REAL R11, R12, R13, R14 C!!!! DOUBLE PRECISION R11, R12, R13, R14 PARAMETER ( R11 = 11D0, R12 = 12D0, R13 = 13D0,R14 = 14D0) REAL R15, R16, R17, R18 C!!!! DOUBLE PRECISION R15, R16, R17, R18 PARAMETER ( R15 = 15D0, R16 = 16D0, R17 = 17D0,R18 = 18D0) REAL R19, R20, R25, R29 C!!!! DOUBLE PRECISION R19, R20, R25, R29 PARAMETER ( R19 = 19D0, R20 = 20D0, R25 = 25D0,R29 = 29D0) REAL R32, R36, R40, R42 C!!!! DOUBLE PRECISION R32, R36, R40, R42 PARAMETER ( R32 = 32D0, R36 = 36D0, R40 = 40D0,R42 = 42D0) REAL R45, R49 C!!!! DOUBLE PRECISION R45, R49 PARAMETER ( R45 = 45D0, R49 = 49D0 ) REAL R50, R56, R84, R90 C!!!! DOUBLE PRECISION R50, R56, R84, R90 PARAMETER ( R50 = 50D0, R56 = 56D0, R84 = 84D0,R90 = 90D0) REAL R100, R180, R200 C!!!! DOUBLE PRECISION R100, R180, R200 PARAMETER ( R100 = 100D0, R180 = 180D0, R200 = 200D0 ) REAL R256, R360, R400 C!!!! DOUBLE PRECISION R256, R360, R400 PARAMETER ( R256 = 256D0, R360 = 360D0, R400 = 400D0 ) REAL R600, R681, R991 C!!!! DOUBLE PRECISION R600, R681, R991 PARAMETER ( R600 = 600D0, R681 = 681D0, R991 = 991D0 ) REAL R1162, R2324 C!!!! DOUBLE PRECISION R1162, R2324 PARAMETER ( R1162 = 1162D0, R2324 = 2324D0 ) REAL R10000, R40000 C!!!! DOUBLE PRECISION R10000, R40000 PARAMETER ( R10000 = 10000D0, R40000 = 40000D0 ) REAL R1PD6, R2PDM6 C!!!! DOUBLE PRECISION R1PD6, R2PDM6 PARAMETER ( R1PD6 = 1D6, R2PDM6 = 2D-6 ) REAL RP04, RP01, R1PZ1 C!!!! DOUBLE PRECISION RP04, RP01, R1PZ1 PARAMETER ( RP04 = 4D-2, RP01 = .01D0, R1PZ1 = 1.0001D0 ) REAL R1P2, R7P5, RP1136 C!!!! DOUBLE PRECISION R1P2, R7P5, RP1136 PARAMETER ( R1P2 = 1.2D0, R7P5 = 7.5D0, RP1136 = 0.1136D0 ) REAL R1P5, R2P5, R2P625 C!!!! DOUBLE PRECISION R1P5, R2P5, R2P625 PARAMETER ( R1P5 = 1.5D0, R2P5 = 2.5D0, R2P625 = 2.625D0 ) REAL R10P1, R19P8, R20P2 C!!!! DOUBLE PRECISION R10P1, R19P8, R20P2 PARAMETER ( R10P1 = 10.1D0,R19P8 = 19.8D0,R20P2 = 20.2D0 ) REAL R2D3, R4D3, R7D3 C!!!! DOUBLE PRECISION R2D3, R4D3, R7D3 PARAMETER ( R2D3 = 2D0/3D0,R4D3 = 4D0/3D0,R7D3 = 7D0/3D0 ) REAL R2P25 C!!!! DOUBLE PRECISION R2P25 PARAMETER ( R2P25 = 2.25D0 ) INTEGER ALPHA, BETA, GAMMA PARAMETER ( ALPHA = 5, BETA = 14, GAMMA = 3 ) C## L O C A L D E C L: INTEGER OK, ABORT, LIMIT, NOF, NOG, NOFG INTEGER I1, IC, IR, IS, IV, IDUMMY, I, J, K, M, RET, ALPHA2 LOGICAL GFIRST REAL ZZMPAR, HUGE C!!!! DOUBLE PRECISION ZZMPAR, HUGE C--------- VARIABLES FOR THE TEST FUNCTIONS. REAL X1, X2, X3, X4, G1, G2 C!!!! DOUBLE PRECISION X1, X2, X3, X4, G1, G2 REAL W1, W2, W3, W4, W5, W6 C!!!! DOUBLE PRECISION W1, W2, W3, W4, W5, W6 REAL W7, W8, W9, W10 C!!!! DOUBLE PRECISION W7, W8, W9, W10 REAL BIGGST, SMLLST C!!!! DOUBLE PRECISION BIGGST, SMLLST REAL RI, XI, PI C!!!! DOUBLE PRECISION RI, XI, PI REAL R2P, RD, TPI, TPIS C!!!! DOUBLE PRECISION R2P, RD, TPI, TPIS REAL RF1, RF2, RF3, RF4 C!!!! DOUBLE PRECISION RF1, RF2, RF3, RF4 C## S A V E: SAVE GFIRST, PI, TPI, TPIS, R2P, BIGGST, SMLLST SAVE HUGE, M SAVE OK, ABORT, LIMIT, NOF, NOG, NOFG C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA GFIRST/.TRUE./ C## E X E C U T I O N C## E X E C U T I O N C--------- FUNCTION DEFINITION RD (IDUMMY) = REAL (IDUMMY) C!!!! RD (IDUMMY) = DBLE (IDUMMY) C--------- SOME ONE TIME ONLY CONSTANTS. IF ( GFIRST ) THEN PI = ACOS(-ONE) TPI = TWO * PI TPIS = TPI * PI R2P = ONE / TPI HUGE = ZZMPAR(3)/TEN SMLLST = LOG(ZZMPAR(2)*TEN) BIGGST = LOG(HUGE) OK = STATUS(1) ABORT = STATUS(2) LIMIT = STATUS(3) NOF = STATUS(4) NOG = STATUS(5) NOFG = STATUS(6) ENDIF C--------- SET LOGICAL FLAGS AND SELECT FUNCTION. RET = OK GOTO( - 1000, 1200, 1000, 1400, 1500, 1600, 1700, 1800, 1000, 2000, - 1000, 2200, 2300, 2400, 2500, 1000, 2700, 2800, 2900, 3000, - 3100, 3200, 3300, 1000, 1000, 1000, 1000, 3800, 3900, 1000, - 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, - 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, - 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, - 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, - 1000, 1000, 1000, 1000, 8500, 8600, 8700, 8800, 8900, 1000 - ) FUNCNO 1000 STATUS(7) = ABORT GOTO 91000 C--------- HELIX 1200 X1 = X(1) X2 = X(2) X3 = X(3) W4 = X1*X1 + X2*X2 W2 = SQRT(W4) W1 = R2P*ATAN( X2/X1 ) IF ( X1 .LT. ZERO ) THEN W1 = W1 + HALF ENDIF W3 = X3 - TEN*W1 W1 = W2 - ONE IF ( .NOT. GONLY ) THEN F = R100 * ( W3*W3 + W1*W1 ) + X3*X3 ENDIF IF ( .NOT. FONLY ) THEN W2 = ONE - ONE/W2 W4 = TEN * W3 * R2P / W4 G(1) = R200 * ( X2 * W4 + X1 * W2 ) G(2) = R200 * (-X1 * W4 + X2 * W2 ) G(3) = R200*W3 + TWO*X3 ENDIF GOTO 90000 C---- WOODS 1400 CONTINUE IF ( .NOT. GONLY ) THEN F = ZERO ENDIF M = N/4 IF (M*4 .NE. N) THEN RET = NOFG GOTO 90000 ENDIF DO 1480 K = 1,M X1 = X(4*K-3) X2 = X(4*K-2) X3 = X(4*K-1) X4 = X(4*K ) W1 = X2 - X1*X1 W2 = ONE - X1 W3 = X4 - X3*X3 W4 = ONE - X3 W5 = X2 - ONE W6 = X4 - ONE IF (.NOT. GONLY) THEN F = F + R100*W1*W1 + W2*W2 + R90*W3*W3 + W4*W4 - + R10P1*(W5*W5 + W6*W6) + R19P8*W5*W6 ENDIF IF (.NOT. FONLY) THEN G(4*K-3) = -R400*X1*W1 - TWO*W2 G(4*K-2) = R200 * W1 + R20P2*W5 + R19P8*W6 G(4*K-1) = -R360*X3*W3 - TWO*W4 G(4*K ) = R180 * W3 + R20P2*W6 + R19P8*W5 ENDIF 1480 CONTINUE GOTO 90000 C--------- MINTEST FUNCTION NONDIA 1500 IF ( .NOT. GONLY ) THEN F = ZERO ENDIF IF ( .NOT. FONLY ) THEN G1 = ZERO ENDIF X1 = X(1) DO 1510 I=2,N XI = X(I) W2 = X1 - XI*XI W3 = ONE - XI IF ( .NOT. GONLY ) THEN F = F + R100* W2*W2 + W3 * W3 ENDIF IF ( .NOT. FONLY ) THEN G1 = G1 + W2 G(I) = - ( R400 * XI * W2 ) - TWO * W3 ENDIF 1510 CONTINUE IF ( .NOT. FONLY ) THEN G(1) = R200 * G1 ENDIF GOTO 90000 C--------- MINTEST FUNCTION TRIDIA ( N, X, F, G, IFG, C FARG(1), FARG(2), FARG(3), FARG(4)) C RF1 IS ALPHA. C RF2 IS BETA. C RF3 IS GAMMA. C RF4 IS DELTA. 1600 W1 = X(1) W4 = ZERO RF1 = FARG(1) RF2 = FARG(2) RF3 = FARG(3) RF4 = FARG(4) IF ( .NOT. GONLY ) THEN F = RF3 * (RF4*W1 - ONE)**2 ENDIF DO 1610 I=2,N W2 = X(I) W3 = RF1*W2 - RF2*W1 IF ( .NOT. GONLY ) THEN F = F + RD(I) * W3**2 ENDIF IF ( .NOT. FONLY ) THEN W5 = TWO * RD(I) * W3 G(I-1) = RF1*W4 - RF2*W5 W4 = W5 ENDIF W1 = W2 1610 CONTINUE IF ( .NOT. FONLY ) THEN G(1) = G(1) + TWO * RF3 * RF4 * ( RF4*X(1) - ONE ) G(N) = RF1 * W4 ENDIF GOTO 90000 C--------- MINTEST FUNCTION POWER C W3 = FARG(1) IS C. C W5 = FARG(2) IS ALPHA. C W6 = FARG(3) IS BETA. 1700 W1 = ZERO W3 = FARG(1) W5 = FARG(2) W6 = FARG(3) DO 1710 I=1,N W2 = X(I) W1 = W1 + W2 * W2 * RD(I)**W6 1710 CONTINUE W4 = W1 + W3 IF ( .NOT. GONLY ) THEN F = W4**W5 ENDIF IF ( .NOT. FONLY ) THEN DO 1720 I = 1,N G(I) = TWO * W5 * RD(I)**W6 * X(I) * W4**(W5-ONE) 1720 CONTINUE ENDIF GOTO 90000 C--------- MINTEST FUNCTION EXTRSN 1800 IF ( .NOT. GONLY ) THEN F = ZERO DO 1810 I = 1,N/2 J = 2*I W1 = X(J-1) W2 = X(J) - W1*W1 W3 = ONE - W1 F = F + R100*W2*W2 + W3*W3 1810 CONTINUE ENDIF IF ( .NOT. FONLY ) THEN DO 1820 I = 1,N IF ( MOD(I,2) .NE. 1 ) THEN W1 = X(I-1) G(I) = R200 * (X(I) - W1*W1 ) ELSE W1 = X(I) G(I) = - TWO * (ONE - W1 + W1 * (X(I+1)-W1*W1)*R200 ) ENDIF 1820 CONTINUE ENDIF GOTO 90000 C--------- MINTEST FUNCTION MANCIN ( N, X, F, G, IFG, WORK, SIZE ) 2000 IF ( .NOT. FONLY ) THEN DO 2010 I =1,N G(I) = ZERO 2010 CONTINUE ENDIF IF ( .NOT. GONLY ) THEN F = ZERO ENDIF IF ( (.NOT. FONLY .AND. 4*N .LE. SIZE) .OR. - ( FONLY .AND. N .LE. SIZE) ) THEN IR = 0 IV = IR + N IC = IV + N IS = IC + N W1 = RD( BETA * N ) W2 = RD( N/2 ) ALPHA2 = ALPHA - 2 DO 2040 I = 1,N W3 = W1*X(I) W4 = RD(I) W5 = (W4 - W2)**GAMMA W6 = ZERO C COMPUTE THE SUM OF H(I,J) IN Y. DO 2020 J = 1,N W7 = X(J) IF ( I .NE. J ) THEN W8 = SQRT( W7*W7 + W4/RD(J) ) IF ( .NOT. FONLY ) WORK(IV+J) = W8 W9 = LOG(W8) W10 = SIN(W9) IF ( .NOT. FONLY ) WORK(IS+J) = W10 W9 = COS(W9) IF ( .NOT. FONLY ) WORK(IC+J) = W9 W6 = W6 + W8*( W10**ALPHA + W9**ALPHA ) ENDIF 2020 CONTINUE RI = W6 + W3 + W5 IF ( .NOT. GONLY ) THEN F = F + RI*RI WORK(IR+I) = RI ENDIF IF ( .NOT. FONLY ) THEN DO 2030 K = 1,N IF ( K .NE. I ) THEN W5 = WORK(IS+K) W6 = W5 ** ALPHA2 W8 = WORK(IC+K) W9 = W8 ** ALPHA2 G(K) = G(K) + RI * X(K) * ( W6*W5*W5 + W9*W8*W8 + - RD(ALPHA) * W5* W8* (W6-W9))/WORK(IV+K) ELSE G(K) = G(K) + RI*W1 ENDIF 2030 CONTINUE ENDIF 2040 CONTINUE IF ( .NOT. FONLY ) THEN CALL ZZSCAL ( N, TWO, G, 1 ) ENDIF ENDIF GOTO 90000 C--------- MINTEST FUNCTION POWBSC 2200 CONTINUE C CHECK FOR POSSIBLE OVERFLOW DO 2220 I = 1, N IF ( -X(I) .GT. BIGGST ) THEN RET = NOFG GOTO 90000 ENDIF 2220 CONTINUE IF ( .NOT. GONLY ) THEN F = ZERO W1 = EXP(-X(1)) DO 2240 I = 1, N-1 W2 = EXP(-X(I+1)) W3 = W1 + W2 - R1PZ1 W4 = R10000 * X(I) * X(I+1) - ONE W1 = W2 F = F + W4*W4 + W3*W3 2240 CONTINUE ENDIF IF ( .NOT. FONLY ) THEN W1 = EXP(-X(1)) W2 = EXP(-X(2)) W4 = TWO * R10000 W5 = R10000*X(1)*X(2) - ONE W7 = W1 + W2 - R1PZ1 G(1) = W4 * X(2) * W5 - TWO * W1 * W7 DO 2260 I = 2, N-1 W3 = EXP(-X(I+1)) W6 = R10000*X(I)*X(I+1) - ONE W8 = W2 + W3 - R1PZ1 G(I) = W4 * ( X(I-1)*W5 + X(I+1)*W6 ) - TWO * W2 * (W7+W8) W2 = W3 W5 = W6 W7 = W8 2260 CONTINUE G(N) = W4*X(N-1)*W5 - TWO*W2*(EXP(-X(N-1)) + W2 - R1PZ1) ENDIF GOTO 90000 C--------- MINTEST FUNCTION JENSMP ( N, X, F, G, IFG, NINT(FARG(1))) C--------- NINT(FARG(1)) IS M1 2300 X1 = X(1) X2 = X(2) IF ( .NOT. GONLY ) THEN F = ZERO ENDIF IF ( .NOT. FONLY ) THEN G1 = ZERO G2 = ZERO ENDIF DO 2310 I = 1, NINT(FARG(1)) W3 = RD(I) IF ( MAX(W3*X1,W3*X2) .LE. BIGGST ) THEN W1 = EXP(W3 * X1) W2 = EXP(W3 * X2) ELSE RET = NOFG GOTO 90000 ENDIF RI = TWO + TWO*W3 - W1 - W2 IF ( .NOT. GONLY ) THEN F = F + RI*RI ENDIF IF ( .NOT. FONLY ) THEN W3 = RI*W3 G1 = G1 + W1*W3 G2 = G2 + W2*W3 ENDIF 2310 CONTINUE IF ( .NOT. FONLY ) THEN G(1) = -TWO * G1 G(2) = -TWO * G2 ENDIF GOTO 90000 C--------- MINTEST FUNCTION FRDRTH 2400 CONTINUE IF ( .NOT. GONLY ) THEN F = ZERO ENDIF W3 = ZERO W4 = ZERO DO 2450 I = 1,N-1 W1 = X(I) + X(I+1)*(X(I+1)*(FIVE - X(I+1)) - TWO) - R13 W2 = X(I) + X(I+1)*(X(I+1)*( X(I+1) + ONE) - R14) - R29 IF ( .NOT. GONLY ) THEN F = F + W1*W1 + W2*W2 ENDIF IF ( .NOT. FONLY ) THEN G(I) = TWO * ( W1 + W2 - + W3 * (X(I)*(TEN-THREE*X(I))-TWO) - + W4 * (X(I)*(TWO+THREE*X(I))-R14) ) W3 = W1 W4 = W2 ENDIF 2450 CONTINUE IF ( .NOT. FONLY ) THEN G(N) = TWO * ( W3 * (X(N)*(TEN-THREE*X(N))-TWO) - + W4 * (X(N)*(TWO+THREE*X(N))-R14) ) ENDIF GOTO 90000 C--------- MINTEST FUNCTION BROWNB 2500 X1 = X(1) X2 = X(2) W1 = X1 - R1PD6 W2 = X2 - R2PDM6 W3 = X1*X2 - TWO IF ( .NOT. GONLY ) THEN F = W1*W1 + W2*W2 + W3*W3 ENDIF IF ( .NOT. FONLY ) THEN G(1) = TWO * (W1 + X2*W3) G(2) = TWO * (W2 + X1*W3) ENDIF GOTO 90000 C--------- MINTEST FUNCTION HILBRT ( N, X, F, G, IFG, FARG(1) ) C--------- FARG(1) IS FACTOR A. C--------- FARG(2) IS DIAGONAL ELEMENT D. 2700 IF ( .NOT. GONLY ) THEN F = ZERO ENDIF W5 = FARG(1) DO 2710 I=1,N W2 = ZERO I1 = I - 1 DO 2720 J = 1,N IF ( I .EQ. J ) THEN W3 = FARG(2) ELSE W3 = ZERO ENDIF W2 = W2 + X(J)*( W3 + ONE/RD(I1+J) ) 2720 CONTINUE IF ( .NOT. FONLY ) THEN CCC G(I) = W2 G(I) = TWO * W5 * W2 ENDIF IF ( .NOT. GONLY ) THEN F = F + X(I)*W2 ENDIF 2710 CONTINUE IF ( .NOT. GONLY ) THEN CCC F= F / TWO F= W5 * F ENDIF GOTO 90000 C --------- MINTEST FUNCTION ZANGW1 2800 X1 = X(1) X2 = X(2) IF (.NOT. GONLY) THEN F = ( R16*(X1*X1 + X2*X2) - EIGHT*X1*(X2+SEVEN) - - R256*X2 + R991 ) / R15 ENDIF IF (.NOT. FONLY) THEN G(1) = (R32*X1 - EIGHT*X2 - R56 ) / R15 G(2) = (R32*X2 - EIGHT*X1 - R256) / R15 ENDIF GOTO 90000 C --------- MINTEST FUNCTION HIMLN3 2900 X1 = X(1) X2 = X(2) W1 = X1 * X1 W2 = X1 * W1 W3 = X2 * X2 IF ( .NOT. GONLY ) THEN F = W2 + W3 - THREE*X1 - TWO*X2 + TWO ENDIF IF ( .NOT. FONLY ) THEN G(1) = THREE*W1 - THREE G(2) = TWO*X2 - TWO ENDIF GOTO 90000 C--------- MINTEST FUNCTION BEAL58 3000 X1 = X(1) X2 = X(2) W1 = X2 * X2 W3 = ONE - X2 W2 = ONE - W1 W1 = ONE - W1*X2 W4 = R1P5 - X1*W3 W5 = R2P25 - X1*W2 W6 = R2P625 - X1*W1 IF ( .NOT. GONLY ) THEN F = W4*W4 + W5*W5 + W6*W6 ENDIF IF ( .NOT. FONLY ) THEN G(1) = -TWO * ( W4*W3 + W5*W2 + W6*W1 ) G(2) = TWO * X1 * ( W4 + (TWO*W5 + THREE*W6*X2) * X2 ) ENDIF GOTO 90000 C--------- MINTEST FUNCTION ENGVL1 3100 CONTINUE IF ( .NOT. GONLY ) THEN F = ZERO ENDIF W1 = X(1)**2 W3 = ZERO DO 3150 I = 1,N-1 W2 = X(I+1)**2 W4 = W1 + W2 IF ( .NOT. GONLY ) THEN F = F + W4**2 - FOUR*X(I) + THREE ENDIF IF ( .NOT. FONLY ) THEN G(I) = FOUR * (X(I) * (W3+W4) - ONE) W3 = W4 ENDIF W1 = W2 3150 CONTINUE G(N) = FOUR * (X(N) * W3) GOTO 90000 C--------- DIXON 3200 CONTINUE IF ( .NOT. GONLY ) THEN F = (ONE-X(1))**2 + (ONE-X(10))**2 DO 3250 I = 2,9 F = F + (X(I)-X(I+1))**2 3250 CONTINUE ENDIF IF ( .NOT. FONLY ) THEN G(1) = -TWO*(ONE -X(1)) G(2) = TWO*(X(2)-X(3)) DO 3275 I = 3,9 G(I) = TWO*(TWO*X(I) - X(I-1) - X(I+1) ) 3275 CONTINUE G(10) = -TWO*(ONE + X(9) - TWO*X(10) ) ENDIF GOTO 90000 C--------- ZANGW2 3300 X1 = X(1) X2 = X(2) X3 = X(3) W1 = X1 - X2 + X3 W2 = -X1 + X2 + X3 W3 = X1 + X2 - X3 IF ( .NOT. GONLY ) THEN F = W1*W1 + W2*W2 + W3*W3 ENDIF IF ( .NOT. FONLY ) THEN G(1) = TWO * ( THREE*X1 - X2 - X3 ) G(2) = TWO * ( -X1 + THREE*X2 - X3 ) G(3) = TWO * ( -X1 - X2 + THREE*X3 ) ENDIF GOTO 90000 C--------- FUNCTION HIMM25 3800 CONTINUE W1 = X(1) - FIVE W2 = X(2) - SIX IF ( .NOT. GONLY ) THEN F = FOUR*W1*W1 + W2*W2 ENDIF IF ( .NOT. FONLY ) THEN G(1) = EIGHT*W1 G(2) = TWO*W2 ENDIF GOTO 90000 C--------- QUARTC 3900 CONTINUE IF ( .NOT. GONLY ) THEN F = ZERO DO 3930 I = 1,N F = F + (X(I) - RD(I))**4 3930 CONTINUE ENDIF IF ( .NOT. FONLY ) THEN DO 3960 I = 1,N G(I) = FOUR*(X(I) - RD(I))**3 3960 CONTINUE ENDIF GOTO 90000 C---- GENRSN C GILL AND MURRAY'S GENERALIZED ROSENBROCK FUNCTION. C (GILM79 #7, AND TOI83B #10 AND #48). 8500 CONTINUE IF ( .NOT. GONLY ) THEN F = ZERO DO 8510 I = 2, N F = F + R100*( X(I) - X(I-1)**2 )**2 + ( X(I) - ONE )**2 8510 CONTINUE ENDIF IF ( .NOT. FONLY ) THEN W1 = X(2) - X(1)**2 G(1) = -R400 * X(1) * W1 DO 8520 I = 2, N-1 W2 = X(I+1) - X(I)**2 G(I) = R200 * W1 + TWO * (X(I) - ONE) - R400 * X(I) * W2 W1 = W2 8520 CONTINUE G(N) = R200 * W1 + TWO * ( X(N) - ONE ) ENDIF GOTO 90000 C---- GREKAR (FUNCTION TRIDIAG FROM BRE73 PP 142-143.) 8600 CONTINUE IF ( .NOT. GONLY ) THEN F = (X(1) - X(2))*X(1) + (-X(N-1) + TWO*X(N))*X(N) - TWO*X(1) DO 8610 I = 2, N-1 F = F + ( -X(I-1) + TWO*X(I) - X(I+1) ) * X(I) 8610 CONTINUE ENDIF IF ( .NOT. FONLY ) THEN G(1) = TWO * ( X(1) - X(2) - ONE ) DO 8620 I = 2, N-1 G(I) = -TWO * ( X(I-1) - TWO*X(I) + X(I+1) ) 8620 CONTINUE G(N) = -TWO * X(N-1) + FOUR * X(N) ENDIF GOTO 90000 C---- TDQUAD C TOINT'S DIAGONAL QUADRATIC FUNCTION (PROBLEM #22 IN TOI83B). 8700 CONTINUE IF ( .NOT. GONLY ) THEN F = ZERO DO 8710 I = 1, N-2 F = F + R100 * ( X(I+1)**2 + X(I+2)**2 ) + X(I)**2 8710 CONTINUE ENDIF IF ( .NOT. FONLY ) THEN DO 8720 I = 1, N G(I) = ZERO 8720 CONTINUE DO 8730 I = 1, N-2 G(I) = G(I) + TWO * X(I) G(I+1) = G(I+1) + R200 * X(I+1) G(I+2) = G(I+2) + R200 * X(I+2) 8730 CONTINUE ENDIF GOTO 90000 C---- TOIN2 C TOINT'S SECOND PROBLEM (PROBLEM #2 IN TOI83B). 8800 CONTINUE IF ( .NOT. GONLY ) THEN F = X(1)**2 + ( (X(1) - X(2))**2 + (X(2) - X(3))**2 ) / TWO ENDIF IF ( .NOT. FONLY ) THEN G(1) = THREE * X(1) - X(2) G(2) = -X(1) + TWO * X(2) - X(3) G(3) = X(3) - X(2) ENDIF GOTO 90000 C---- TOIN4 C TOINT'S FOURTH PROBLEM (PROBLEM #4 IN TOI83B). 8900 CONTINUE X1 = X(1) X2 = X(2) X3 = X(3) X4 = X(4) IF ( .NOT. GONLY ) THEN F = X1**2 + X2**2 + TWO + ( (X1 - X2)**2 + (X3 - X4)**2 ) / TWO ENDIF IF ( .NOT. FONLY ) THEN G(1) = THREE * X1 - X2 G(2) = -X1 + THREE * X2 G(3) = X3 - X4 G(4) = X4 - X3 ENDIF GOTO 90000 C## E X I T 90000 STATUS(7) = RET 91000 GFIRST = .FALSE. RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZFNS2. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> fns3sg.f SUBROUTINE ZZFNS3 ( N, X, F, G, WORK, SIZE, FONLY, GONLY, - FIRST, FARG, FUNCNO, STATUS ) C## A R G U M E N T S: INTEGER N, SIZE, FUNCNO, STATUS(7) LOGICAL FIRST, FONLY, GONLY REAL F, X(N), G(N), WORK(SIZE), FARG(*) C!!!! DOUBLE PRECISION F, X(N), G(N), WORK(SIZE), FARG(*) C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: FNS3.F,V 1.1 91/11/20 10:52:50 BUCKLEY EXP $ C>RCS $LOG: FNS3.F,V $ C>RCSREVISION 1.1 91/11/20 10:52:50 BUCKLEY C>RCSFINAL SUBMISSION TO TOMS C>RCS C>RCSREVISION 1.0 90/07/31 13:01:56 BUCKLEY C>RCSINITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS SUBROUTINE EVALUATES ONE OF THE STANDARD TEST FUNCTIONS. C THE TEST FUNCTIONS ARE DIVIDED AMOUNG FOUR ROUTINES BECAUSE A C SINGLE ROUTINE WOULD BE TOO LARGE FOR SOME COMPILERS. C THE ARGUMENTS IN THE CALLING SEQUENCE HAVE PRECISELY THE SAME C MEANING AS IN THE ROUTINE ZZEVAL. C C THE VALUE OF THE INTEGER PARAMETER FUNCNO SPECIFIES C WHICH OF THE TEST FUNCTIONS IS TO BE USED; THE FUNCTION C IS CHOSEN USING A COMPUTED GOTO. C C THE PARAMETERS FONLY AND GONLY SPECIFY FUNCTION AND C GRADIENT EVALUATIONS. THE PARAMETER FIRST SPECIFIES CODE TO BE C EVALUATED ONLY ON THE FIRST CALL TO A PARTICULAR FUNCTION. C THE PARAMETER STATUS STORES THE RETURN CODES. C C## E N T R Y P O I N T S: ZZFNS3 THE NATURAL ENTRY POINT. C C## S U B R O U T I N E S: C C PREDEFINED FUNCTIONS : SIN, COS, TAN, ACOS, ATAN, ABS, MAX, NINT C EXP, LOG, MIN, MOD, SIGN, SQRT, REAL(DBLE) C C STATEMENT FUNCTION: RD C C## P A R A M E T E R S: REAL ZERO, ONE, TWO, THREE C!!!! DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) REAL FOUR, FIVE, SIX, SEVEN C!!!! DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) REAL EIGHT, NINE, TEN C!!!! DOUBLE PRECISION EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 9D0, TEN = 10D0 ) REAL TENTH, FIFTH, HALF C!!!! DOUBLE PRECISION TENTH, FIFTH, HALF PARAMETER ( TENTH = .1D0, FIFTH = .2D0, HALF = .5D0 ) REAL RPT9, RPT8, RD29 C!!!! DOUBLE PRECISION RPT9, RPT8, RD29 PARAMETER ( RPT9 = .9D0, RPT8 = .8D0, RD29 = 1D0/29D0 ) REAL R11, R12, R13, R14 C!!!! DOUBLE PRECISION R11, R12, R13, R14 PARAMETER ( R11 = 11D0, R12 = 12D0, R13 = 13D0,R14 = 14D0) REAL R15, R16, R17, R18 C!!!! DOUBLE PRECISION R15, R16, R17, R18 PARAMETER ( R15 = 15D0, R16 = 16D0, R17 = 17D0,R18 = 18D0) REAL R19, R20, R25, R29 C!!!! DOUBLE PRECISION R19, R20, R25, R29 PARAMETER ( R19 = 19D0, R20 = 20D0, R25 = 25D0,R29 = 29D0) REAL R32, R36, R40, R42 C!!!! DOUBLE PRECISION R32, R36, R40, R42 PARAMETER ( R32 = 32D0, R36 = 36D0, R40 = 40D0,R42 = 42D0) REAL R45, R49 C!!!! DOUBLE PRECISION R45, R49 PARAMETER ( R45 = 45D0, R49 = 49D0 ) REAL R50, R56, R84, R90 C!!!! DOUBLE PRECISION R50, R56, R84, R90 PARAMETER ( R50 = 50D0, R56 = 56D0, R84 = 84D0,R90 = 90D0) REAL R100, R180, R200 C!!!! DOUBLE PRECISION R100, R180, R200 PARAMETER ( R100 = 100D0, R180 = 180D0, R200 = 200D0 ) REAL R256, R360, R400 C!!!! DOUBLE PRECISION R256, R360, R400 PARAMETER ( R256 = 256D0, R360 = 360D0, R400 = 400D0 ) REAL R600, R681, R991 C!!!! DOUBLE PRECISION R600, R681, R991 PARAMETER ( R600 = 600D0, R681 = 681D0, R991 = 991D0 ) REAL R1162, R2324 C!!!! DOUBLE PRECISION R1162, R2324 PARAMETER ( R1162 = 1162D0, R2324 = 2324D0 ) REAL R10000, R40000 C!!!! DOUBLE PRECISION R10000, R40000 PARAMETER ( R10000 = 10000D0, R40000 = 40000D0 ) REAL R1PD6, R2PDM6 C!!!! DOUBLE PRECISION R1PD6, R2PDM6 PARAMETER ( R1PD6 = 1D6, R2PDM6 = 2D-6 ) REAL RP04, RP01, R1PZ1 C!!!! DOUBLE PRECISION RP04, RP01, R1PZ1 PARAMETER ( RP04 = 4D-2, RP01 = .01D0, R1PZ1 = 1.0001D0 ) REAL R1P2, R7P5, RP1136 C!!!! DOUBLE PRECISION R1P2, R7P5, RP1136 PARAMETER ( R1P2 = 1.2D0, R7P5 = 7.5D0, RP1136 = 0.1136D0 ) REAL R1P5, R2P5, R2P625 C!!!! DOUBLE PRECISION R1P5, R2P5, R2P625 PARAMETER ( R1P5 = 1.5D0, R2P5 = 2.5D0, R2P625 = 2.625D0 ) REAL R10P1, R19P8, R20P2 C!!!! DOUBLE PRECISION R10P1, R19P8, R20P2 PARAMETER ( R10P1 = 10.1D0,R19P8 = 19.8D0,R20P2 = 20.2D0 ) REAL R2D3, R4D3, R7D3 C!!!! DOUBLE PRECISION R2D3, R4D3, R7D3 PARAMETER ( R2D3 = 2D0/3D0,R4D3 = 4D0/3D0,R7D3 = 7D0/3D0 ) REAL R2P25 C!!!! DOUBLE PRECISION R2P25 PARAMETER ( R2P25 = 2.25D0 ) C## L O C A L D E C L: INTEGER OK, ABORT, LIMIT, NOF, NOG, NOFG INTEGER I1, I2, F1, I, IDUMMY, J, K, NOVER2, IEG, IY, RET, L LOGICAL EVEN, GFIRST, ERROR REAL ZZMPAR, HUGE C!!!! DOUBLE PRECISION ZZMPAR, HUGE C--------- VARIABLES FOR THE TEST FUNCTIONS. REAL X1, X2, X3, X4, X5, X6, S1, T1, T2, T3, T4 C!!!! DOUBLE PRECISION X1, X2, X3, X4, X5, X6, S1, T1, T2, T3, T4 REAL X7, X8, X9, X10, X11 C!!!! DOUBLE PRECISION X7, X8, X9, X10, X11 REAL G1, G2, G3, G4, G5, G6 C!!!! DOUBLE PRECISION G1, G2, G3, G4, G5, G6 REAL G7, G8, G9, G10, G11 C!!!! DOUBLE PRECISION G7, G8, G9, G10, G11 REAL W1, W2, W3, W4, W5, W6 C!!!! DOUBLE PRECISION W1, W2, W3, W4, W5, W6 REAL W7, W8, W9 C!!!! DOUBLE PRECISION W7, W8, W9 REAL R, S, T, BIGGST, SMLLST C!!!! DOUBLE PRECISION R, S, T, BIGGST, SMLLST REAL RI, RK , SK, TI C!!!! DOUBLE PRECISION RI, RK , SK, TI REAL XI, XK, YI, PI, U C!!!! DOUBLE PRECISION XI, XK, YI, PI, U REAL R2P, RD, TPI, TPIS C!!!! DOUBLE PRECISION R2P, RD, TPI, TPIS REAL KAP1, KAP2, RF1 C!!!! DOUBLE PRECISION KAP1, KAP2, RF1 C--------- DATA ARRAYS FOR FUNCTIONS REAL AL (50), ARGASY (15) C!!!! DOUBLE PRECISION AL (50), ARGASY (15) REAL HIM32A (7), HIM32B (7) C!!!! DOUBLE PRECISION HIM32A (7), HIM32B (7) REAL KOWOSU (11), KOWOSY (11) C!!!! DOUBLE PRECISION KOWOSU (11), KOWOSY (11) REAL ORBETA (33), OD (33), MEY (16) C!!!! DOUBLE PRECISION ORBETA (33), OD (33), MEY (16) REAL OSB1Y (33), OSB2Y (65) C!!!! DOUBLE PRECISION OSB1Y (33), OSB2Y (65) INTEGER A (50), B (56) C## S A V E: SAVE GFIRST, PI, TPI, TPIS, R2P, BIGGST, SMLLST SAVE HUGE SAVE OK, ABORT, LIMIT, NOF, NOG, NOFG C--------- SAVE DATA ARRAYS FOR THE TEST FUNCTIONS. SAVE ARGASY, AL, HIM32A, HIM32B, KOWOSU, KOWOSY SAVE ORBETA, MEY , OD, OSB1Y , OSB2Y , A , B C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA GFIRST/.TRUE./ C--------- DATA FOR FUNCTION ARGAUS DATA ARGASY( 1), ARGASY( 2), ARGASY( 3), ARGASY( 4), ARGASY( 5) - / 9.000 D-4, 4.400 D-3, 1.750 D-2, 5.400 D-2, 1.295 D-1 / DATA ARGASY( 6), ARGASY( 7), ARGASY( 8), ARGASY( 9), ARGASY(10) - / 2.420 D-1, 3.521 D-1, 3.989 D-1, 3.521 D-1, 2.420 D-1 / DATA ARGASY(11), ARGASY(12), ARGASY(13), ARGASY(14), ARGASY(15) - / 1.295 D-1, 5.400 D-2, 1.750 D-2, 4.400 D-3, 9.000 D-4 / C--------- DATA FOR FUNCTION HIMM32 DATA HIM32A(1), HIM32A(2), HIM32A(3), HIM32A(4) - / 0.0D0, 4.28D-4, 1.0D-3, 1.61D-3 / DATA HIM32A(5), HIM32A(6), HIM32A(7) - / 2.09D-3, 3.48D-3, 5.25D-3 / DATA HIM32B(1), HIM32B(2), HIM32B(3), HIM32B(4) - / 7.391D0, 1.118D1, 1.644D1, 1.62D1 / DATA HIM32B(5), HIM32B(6), HIM32B(7) - / 2.22D1, 2.402D1, 3.132D1 / C--------- DATA FOR FUNCTION KOWOSB DATA KOWOSU(1), KOWOSU(2), KOWOSU(3), KOWOSU(4) - / 4.0D0, 2.0D0, 1.0D0, 0.5D0 / DATA KOWOSU(5), KOWOSU(6), KOWOSU(7), KOWOSU(8) - / 0.25D0, 0.167D0, 0.125D0, 0.1D0 / DATA KOWOSU(9), KOWOSU(10), KOWOSU(11) - / 0.0833D0, 0.0714D0, 0.0625D0 / DATA KOWOSY(1), KOWOSY(2), KOWOSY(3), KOWOSY(4) - / 0.1957D0, 0.1947D0, 0.1735D0, 0.1600D0 / DATA KOWOSY(5), KOWOSY(6), KOWOSY(7), KOWOSY(8) - / 0.0844D0, 0.0627D0, 0.0456D0, 0.0342D0 / DATA KOWOSY(9), KOWOSY(10), KOWOSY(11) - / 0.0323D0, 0.0235D0, 0.0246D0 / C--------- DATA FOR FUNCTION MEYER DATA MEY(1), MEY(2), MEY(3), MEY(4), MEY(5), MEY(6) - /3.478D4, 2.861D4, 2.365D4, 1.963D4, 1.637D4, 1.372D4/ DATA MEY(7), MEY(8), MEY(9), MEY(10), MEY(11), MEY(12) - /1.154D4, 9.744D3, 8.261D3, 7.030D3, 6.005D3, 5.147D3/ DATA MEY(13), MEY(14), MEY(15), MEY(16) - /4.427D3, 3.820D3, 3.307D3, 2.872D3/ C--------- DATA FOR FUNCTION ORTOIT DATA ORBETA(1),ORBETA(2),ORBETA(3),ORBETA(4),ORBETA(5) - /1.0D0, 1.5D0, 1.0D0, 0.1D0, 1.5D0/ DATA ORBETA(6),ORBETA(7),ORBETA(8),ORBETA(9),ORBETA(10) - /2.0D0, 1.0D0, 1.5D0, 3.0D0, 2.0D0/ DATA ORBETA(11),ORBETA(12),ORBETA(13),ORBETA(14),ORBETA(15) - /1.0D0, 3.0D0, 0.1D0, 1.5D0, 0.15D0/ DATA ORBETA(16),ORBETA(17),ORBETA(18),ORBETA(19),ORBETA(20) - /2.0D0, 1.0D0, 0.1D0, 3.0D0, 0.1D0/ DATA ORBETA(21),ORBETA(22),ORBETA(23),ORBETA(24),ORBETA(25) - /1.2D0, 1.0D0, 0.1D0, 2.0D0, 1.2D0/ DATA ORBETA(26),ORBETA(27),ORBETA(28),ORBETA(29),ORBETA(30) - /3.0D0, 1.5D0, 3.0D0, 2.0D0, 1.0D0/ DATA ORBETA(31),ORBETA(32),ORBETA(33) - /1.2D0, 2.0D0, 1.0D0/ DATA OD(1), OD(2), OD(3), OD(4), OD(5), OD(6) - / 5.0D0,5.0D0,5.0D0,2.5D0,6.0D0,6.0D0 / DATA OD(7), OD(8), OD(9), OD(10), OD(11), OD(12) - / 5.0D0,6.0D0,10.0D0,6.0D0,5.0D0,9.0D0 / DATA OD(13), OD(14), OD(15), OD(16), OD(17), OD(18) - / 2.0D0,7.0D0,2.5D0,6.0D0,5.0D0,2.0D0 / DATA OD(19), OD(20), OD(21), OD(22), OD(23), OD(24) - / 9.0D0,2.0D0,5.0D0,5.0D0,2.5D0,5.0D0 / DATA OD(25), OD(26), OD(27), OD(28), OD(29), OD(30) - / 6.0D0,10.0D0,7.0D0,10.0D0,6.0D0,5.0D0 / DATA OD(31), OD(32), OD(33) - / 4.0D0,4.0D0,4.0D0 / DATA A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9) - / -31,-1,-2,-4,-6,-8,-10,-12,+11 / DATA A(10),A(11),A(12),A(13),A(14),A(15),A(16),A(17),A(18) - / +13,-14,-16,+9,-18,+5,+20,-21,-19 / DATA A(19),A(20),A(21),A(22),A(23),A(24),A(25),A(26),A(27) - / -23,+7,-25,-28,-29,-32,+3,-33,-35 / DATA A(28),A(29),A(30),A(31),A(32),A(33),A(34),A(35),A(36) - / -36,+30,-37,+38,-39,-40,-41,-44,-46 / DATA A(37),A(38),A(39),A(40),A(41),A(42),A(43),A(44),A(45) - / +42,+45,+48,-50,+26,+34,-43,+15,+17 / DATA A(46),A(47),A(48),A(49),A(50) - / +24,-47,-49,-22,-27 / DATA B(1),B(2),B(3),B(4),B(5),B(6),B(7),B(8),B(9) - / -1,+2,-3,+4,-5,+6,-7,+8,-9 / DATA B(10),B(11),B(12),B(13),B(14),B(15),B(16),B(17),B(18) - / +10,-11,+12,-13,+14,-15,+16,-17,+18 / DATA B(19),B(20),B(21),B(22),B(23),B(24),B(25),B(26),B(27) - / -19,-20,0,+22,+23,-24,+25,-26,+27 / DATA B(28),B(29),B(30),B(31),B(32),B(33),B(34),B(35),B(36) - / -28,+29,-30,+31,-32,+33,-34,-35,+21 / DATA B(37),B(38),B(39),B(40),B(41),B(42),B(43),B(44),B(45),B(46) - / -36,+37,-38,-39,-40,+41,-42,+43,+44,-50 / DATA B(47),B(48),B(49),B(50),B(51),B(52),B(53),B(54),B(55),B(56) - / +45,+46,-47,-48,-49,0,0,0,0,0 / C----- ARRAY AL IS USED BY MINTEST FUNCTIONS ORTOIT AND CHNRSN DATA AL(1), AL(2), AL(3), AL(4), AL(5), AL(6), AL(7), AL(8) - / 1.25D0,1.40D0,2.40D0,1.40D0,1.75D0,1.20D0,2.25D0,1.20D0/ DATA AL(9) ,AL(10),AL(11),AL(12),AL(13),AL(14),AL(15),AL(16) - / 1.00D0,1.10D0,1.50D0,1.60D0,1.25D0,1.25D0,1.20D0,1.20D0/ DATA AL(17),AL(18),AL(19),AL(20),AL(21),AL(22),AL(23),AL(24) - / 1.40D0,0.50D0,0.50D0,1.25D0,1.80D0,0.75D0,1.25D0,1.40D0/ DATA AL(25),AL(26),AL(27),AL(28),AL(29),AL(30) - / 1.60D0,2.00D0,1.00D0,1.60D0,1.25D0,2.75D0/ DATA AL(31),AL(32),AL(33),AL(34),AL(35),AL(36),AL(37),AL(38) - / 1.25D0,1.25D0,1.25D0,3.00D0,1.50D0,2.00D0,1.25D0,1.40D0/ DATA AL(39),AL(40),AL(41),AL(42),AL(43),AL(44),AL(45),AL(46) - / 1.80D0,1.50D0,2.20D0,1.40D0,1.50D0,1.25D0,2.00D0,1.50D0/ DATA AL(47),AL(48),AL(49),AL(50) - / 1.25D0,1.40D0,0.60D0,1.50D0/ C--------- DATA FOR FUNCTION OSBRN1 DATA OSB1Y(1), OSB1Y(2), OSB1Y(3), OSB1Y(4), OSB1Y(5) -/.844D0, .908D0, .932D0, .936D0, .925D0/ DATA OSB1Y(6), OSB1Y(7), OSB1Y(8), OSB1Y(9), OSB1Y(10) -/.908D0, .881D0, .850D0, .818D0, .784D0/ DATA OSB1Y(11), OSB1Y(12), OSB1Y(13), OSB1Y(14), OSB1Y(15) -/.751D0, .718D0, .685D0, .658D0, .628D0/ DATA OSB1Y(16), OSB1Y(17), OSB1Y(18), OSB1Y(19), OSB1Y(20) -/.603D0, .580D0, .558D0, .538D0, .522D0/ DATA OSB1Y(21), OSB1Y(22), OSB1Y(23), OSB1Y(24), OSB1Y(25) -/.506D0, .490D0, .478D0, .467D0, .457D0/ DATA OSB1Y(26), OSB1Y(27), OSB1Y(28), OSB1Y(29), OSB1Y(30) -/.448D0, .438D0, .431D0, .424D0, .420D0/ DATA OSB1Y(31), OSB1Y(32), OSB1Y(33) -/.414D0, .411D0, .406D0/ C--------- DATA FOR FUNCTION OSBRN2 DATA OSB2Y(1), OSB2Y(2), OSB2Y(3), OSB2Y(4), OSB2Y(5) -/1.366D0, 1.191D0, 1.112D0, 1.013D0, .991D0/ DATA OSB2Y(6), OSB2Y(7), OSB2Y(8), OSB2Y(9), OSB2Y(10) -/.885D0, .831D0, .847D0, .786D0, .725D0/ DATA OSB2Y(11), OSB2Y(12), OSB2Y(13), OSB2Y(14), OSB2Y(15) -/.746D0, .679D0, .608D0, .655D0, .616D0/ DATA OSB2Y(16), OSB2Y(17), OSB2Y(18), OSB2Y(19), OSB2Y(20) -/.606D0, .602D0, .626D0, .651D0, .724D0/ DATA OSB2Y(21), OSB2Y(22), OSB2Y(23), OSB2Y(24), OSB2Y(25) -/.649D0, .649D0, .694D0, .644D0, .624D0/ DATA OSB2Y(26), OSB2Y(27), OSB2Y(28), OSB2Y(29), OSB2Y(30) -/.661D0, .612D0, .558D0, .533D0, .495D0/ DATA OSB2Y(31), OSB2Y(32), OSB2Y(33), OSB2Y(34), OSB2Y(35) -/.50D0, .423D0, .395D0, .375D0, .372D0/ DATA OSB2Y(36), OSB2Y(37), OSB2Y(38), OSB2Y(39), OSB2Y(40) -/.391D0, .396D0, .405D0, .428D0, .429D0/ DATA OSB2Y(41), OSB2Y(42), OSB2Y(43), OSB2Y(44), OSB2Y(45) -/.523D0, .562D0, .607D0, .653D0, .672D0/ DATA OSB2Y(46), OSB2Y(47), OSB2Y(48), OSB2Y(49), OSB2Y(50) -/.708D0, .633D0, .668D0, .645D0, .632D0/ DATA OSB2Y(51), OSB2Y(52), OSB2Y(53), OSB2Y(54), OSB2Y(55) -/.591D0, .559D0, .597D0, .625D0, .739D0/ DATA OSB2Y(56), OSB2Y(57), OSB2Y(58), OSB2Y(59), OSB2Y(60) -/.710D0, .729D0, .720D0, .636D0, .581D0/ DATA OSB2Y(61), OSB2Y(62), OSB2Y(63), OSB2Y(64), OSB2Y(65) -/.428D0, .292D0, .162D0, .098D0, .054D0/ C## E X E C U T I O N C## E X E C U T I O N C--------- FUNCTION DEFINITION RD (IDUMMY) = REAL (IDUMMY) C!!!! RD (IDUMMY) = DBLE (IDUMMY) C--------- SOME ONE TIME ONLY CONSTANTS. IF ( GFIRST ) THEN PI = ACOS(-ONE) TPI = TWO * PI TPIS = TPI * PI R2P = ONE / TPI HUGE = ZZMPAR(3)/TEN SMLLST = LOG(ZZMPAR(2)*TEN) BIGGST = LOG(HUGE) OK = STATUS(1) ABORT = STATUS(2) LIMIT = STATUS(3) NOF = STATUS(4) NOG = STATUS(5) NOFG = STATUS(6) ENDIF C--------- SET LOGICAL FLAGS AND SELECT FUNCTION. RET = OK GOTO( - 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1900, 1000, - 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, - 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 4000, - 4100, 4200, 4300, 4400, 4500, 4600, 4700, 4800, 4900, 1000, - 1000, 5200, 5300, 5400, 5500, 5600, 5700, 5800, 5900, 6000, - 6100, 6200, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, - 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, - 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000 - ) FUNCNO 1000 STATUS(7) = ABORT GOTO 91000 C--------- MINTEST FUNCTION CHNRSN 1900 IF ( .NOT. GONLY ) THEN F = ZERO W1 = X(1) DO 1910 I=2,N W2 = X(I) W3 = W1 - W2*W2 W4 = ONE - W2 F = F + FOUR * AL(I) * W3*W3 + W4*W4 W1 = W2 1910 CONTINUE ENDIF IF ( .NOT. FONLY ) THEN W2 = X(2) W1 = EIGHT * AL(2) * ( X(1) - W2*W2 ) G(1) = W1 DO 1920 I = 3,N W4 = X(I) W3 = EIGHT * AL(I) * (W2 - W4*W4) G(I-1) = TWO*(-W1*W2 - (ONE - W2)) + W3 W1 = W3 W2 = W4 1920 CONTINUE G(N) = -TWO * (W1*W4 + (ONE - W4)) ENDIF GOTO 90000 C--------- TRIGTO 4000 CONTINUE IF ( .NOT. GONLY ) THEN F = ZERO ENDIF IF ( .NOT. FONLY ) THEN DO 4010 K=1,N G(K)=ZERO 4010 CONTINUE ENDIF DO 4070 I=1,N S = RD(I) S1 = ONE + S/TEN DO 4020 J=1,I-1 T = RD(J) T1 = ONE + T/TEN T2 = RD(5*(1+MOD(I,5)+MOD(J,5))) T3 = (S+T)/TEN T4 = S1*X(I) + T1*X(J) + T3 IF ( .NOT. GONLY ) THEN F = F + T2*SIN(T4) ENDIF IF ( .NOT. FONLY ) THEN G(I) = G(I) + S1*T2*COS(T4) ENDIF 4020 CONTINUE IF ( .NOT. FONLY ) THEN DO 4040 J=I+1,N T = RD(J) T1 = ONE + T/TEN T2 = RD(5*(1+MOD(I,5)+MOD(J,5))) T3 = (S+T)/TEN T4 = S1*X(I) + T1*X(J) + T3 G(I) = G(I) + T2*S1*COS(T4) 4040 CONTINUE ENDIF 4070 CONTINUE GOTO 90000 C--------- MINTEST FUNCTION HIMM28 4100 X1 = X(1) X2 = X(2) W1 = X1*X1 + X2 - R11 W2 = X2*X2 + X1 - SEVEN IF ( .NOT. GONLY ) THEN F = W1*W1 + W2*W2 ENDIF IF ( .NOT. FONLY ) THEN G(1) = FOUR*X1*W1 + TWO*W2 G(2) = FOUR*X2*W2 + TWO*W1 ENDIF GOTO 90000 C--------- MINTEST FUNCTION ORTOIT ( N, X, F, G, IFG, NINT(FARG(1)), C WORK, SIZE ) C C--------- NINT(FARG(1)) SELECTS QOR, GOQ OR PSP - TOINT. 4200 F1 = NINT( FARG( 1 ) ) IF ( .NOT. GONLY ) THEN F = ZERO ENDIF IF ( SIZE .LT. 83 ) THEN IF ( .NOT. FONLY ) THEN DO 4201 I = 1,N G(I) = ZERO 4201 CONTINUE ENDIF GOTO 90000 ENDIF C-----SET POINTERS FOR WORK ARRAYS. IY = 0 IEG = IY + 33 DO 4202 I = 1, 33 WORK(IY+I) = OD(I) 4202 CONTINUE C *** ADD (SUBTRACT) X(K) TO (FROM) THE PROPER Y(I). J = 1 L = 1 DO 4206 K = 1, 50 W2 = X(K) W1 = AL(K) I = A(K) WORK(IY+J) = WORK(IY+J) - X(ABS(I)) IF ( I .LT. 0 ) J = J + 1 I = B(K) IF ( I .NE. 0 ) WORK(IY+L) = WORK(IY+L) + X(ABS(I)) IF ( I .LE. 0 ) L = L + 1 C ****** AS APPROPRIATE ADD THE FIRST SUM TO F AND THE FIRST C TERM TO G(K). THE SUM AND TERMS INVOLVE ALPHA(K) AND X(K). GO TO (4203, 4204, 4205), F1 C ****** QORTOI ONLY. 4203 IF ( .NOT. GONLY ) THEN F = F + W1 * W2 * W2 ENDIF IF ( .NOT. FONLY ) THEN G(K) = W1 * W2 ENDIF GO TO 4206 C ****** GORTOI ONLY. 4204 IF ( W2 .GE. ZERO ) THEN W3 = ONE + W2 IF ( .NOT. GONLY ) THEN F = F + W1 * W2 * LOG(W3) ENDIF IF ( .NOT. FONLY ) THEN G(K) = W1 * ( (W2 / W3) + LOG(W3) ) ENDIF ELSE W3 = ONE - W2 IF ( .NOT. GONLY ) THEN F = F - W1 * W2 * LOG(W3) ENDIF IF ( .NOT. FONLY ) THEN G(K) = W1 * ( (W2 / W3) - LOG(W3) ) ENDIF ENDIF GO TO 4206 C ****** PSPTOI ONLY. 4205 W2 = W2 - FIVE IF ( .NOT. GONLY ) THEN F = F + W1 * W2 * W2 ENDIF IF ( .NOT. FONLY ) THEN G(K) = W1 * W2 * TWO ENDIF 4206 CONTINUE C *** FOR THE FUNCTION VALUE, ADD THE SUM INVOLVING Y(I). IF ( .NOT. GONLY ) THEN DO 4210 I = 1, 33 W3 = WORK(IY+I) W1 = W3 * W3 W2 = ORBETA(I) GO TO (4207, 4208, 4209), F1 C ********* QORTOI ONLY. 4207 F = F + W2 * W1 GO TO 4210 C ********* GORTOI ONLY. 4208 IF ( W3 .GE. ZERO ) THEN F = F + W2 * W1 * LOG(ONE + W3) ELSE F = F + W2 * W1 ENDIF GO TO 4210 C ********* PSPTOI ONLY. 4209 IF ( W3 .GE. TENTH ) THEN F = F + W2 / W3 ELSE F = F + W2 * R20 * (ONE - FIVE * W3) ENDIF 4210 CONTINUE ENDIF C *** FOR THE GRADIENTS ADD THE SUMS INVOLVING Y(I). IF ( .NOT. FONLY ) THEN J = 1 L = 1 DO 4214 K = 1, 50 GO TO (4211, 4212, 4213), F1 C ********* QORTOI ONLY. 4211 I = A(K) W1 = - ORBETA(J) * WORK(IY+J) G(ABS(I)) = G(ABS(I)) + W1 IF ( I .LT. 0 ) J = J + 1 I = B(K) W1 = ORBETA(L) * WORK(IY+L) IF ( I .NE. 0 ) G(ABS(I)) = G(ABS(I)) + W1 IF ( I .LE. 0 ) L = L + 1 GO TO 4214 C ********* GORTOI ONLY. 4212 I = A(K) W2 = WORK(IY+J) IF ( W2 .GE. ZERO ) THEN W1 = -ORBETA(J) * W2 * ( (TWO * LOG(ONE + W2)) + - (W2 / (ONE + W2)) ) ELSE W1 = -ORBETA(J) * TWO * W2 ENDIF G(ABS(I)) = G(ABS(I)) + W1 IF ( I .LT. 0 ) J = J + 1 I = B(K) IF ( I .NE. 0 ) THEN W2 = WORK(IY+L) IF ( W2 .GE. ZERO ) THEN W1 = ORBETA(L) * W2 * ( (TWO * LOG(ONE + W2)) + - (W2 / (ONE + W2)) ) ELSE W1 = ORBETA(L) * TWO * W2 ENDIF G(ABS(I)) = G(ABS(I)) + W1 ENDIF IF ( I .LE. 0 ) L = L + 1 GO TO 4214 C ********* PSPTOI ONLY. (NOTE THAT THE MINUS SIGNS ON C THE SUM AND FUNCTION HAVE CANCELED EACH OTHER.) 4213 I = A(K) W2 = WORK(IY+J) IF ( W2 .GE. TENTH ) THEN W1 = ORBETA(J) / ( W2 * W2 ) ELSE W1 = ORBETA(J) * R100 ENDIF G(ABS(I)) = G(ABS(I)) + W1 IF ( I .LT. 0 ) J = J + 1 I = B(K) IF ( I .NE. 0 ) THEN W2 = WORK(IY+L) C ********* NOTE THAT THE MINUS SIGN IS DUE TO C THE FUNCTIONS USED. IF ( W2 .GE. TENTH ) THEN W1 = - ORBETA(L) / ( W2 * W2 ) ELSE W1 = - ORBETA(L) * R100 ENDIF G(ABS(I)) = G(ABS(I)) + W1 ENDIF IF ( I .LE. 0 ) L = L + 1 4214 CONTINUE DO 4229 K = 1,50 GOTO ( 4222, 4224, 4226 ), F1 4222 G(K) = G(K) * TWO GOTO 4229 4224 CONTINUE GOTO 4229 4226 CONTINUE GOTO 4229 4229 CONTINUE ENDIF GO TO 90000 C--------- MINTEST FUNCTION GULF ( N, X, F, G, IFG, NINT(FARG(1))) C--------- NINT(FARG(1)) IS M 4300 X1 = X(1) X2 = X(2) X3 = X(3) IF ( X1 .EQ. ZERO ) THEN RET = NOFG GOTO 90000 ENDIF IF ( .NOT. GONLY ) THEN F = ZERO ENDIF IF ( .NOT. FONLY ) THEN G1 = ZERO G2 = ZERO G3 = ZERO ENDIF DO 4310 I = 1,NINT(FARG(1)) W1 = RD(I)/R100 YI = (-R50*LOG(W1)) ** R2D3 + R25 - X2 IF ( X3*LOG(ABS(YI)) .LE. BIGGST ) THEN W2 = ( ABS(YI)**X3 ) / X1 ELSE RET = NOFG GOTO 90000 ENDIF IF ( -W2 .LE. BIGGST ) THEN W3 = EXP(-W2) ELSE RET = NOFG GOTO 90000 ENDIF RI = W3 - W1 IF ( .NOT. GONLY ) THEN F = F + RI*RI ENDIF IF ( .NOT. FONLY ) THEN W1 = RI*W2*W3 G1 = G1 + W1 G2 = G2 + W1 / YI G3 = G3 - W1 * LOG(ABS(YI)) ENDIF 4310 CONTINUE IF ( .NOT. FONLY ) THEN G(1) = TWO * G1 / X1 G(2) = TWO * G2 * X3 G(3) = TWO * G3 ENDIF GOTO 90000 C--------- MINTEST FUNCTION ARGAUS 4400 IF ( .NOT. GONLY ) THEN F = ZERO ENDIF X1 = X(1) X2 = X(2) X3 = X(3) G1 = ZERO G2 = ZERO G3 = ZERO DO 4410 I = 1, 15 W1 = FOUR - RD(I)/TWO - X3 W2 = -HALF * X2 * W1 * W1 IF ( W2 .LE. BIGGST ) THEN W3 = EXP(W2) ELSE RET = NOFG GOTO 90000 ENDIF RI = X1 * W3 - ARGASY(I) IF ( .NOT. GONLY ) THEN F = F + RI * RI ENDIF IF ( .NOT. FONLY ) THEN W2 = W3 * RI W3 = W1 * W2 G1 = G1 + W2 G2 = G2 - W1 * W3 G3 = G3 + W3 ENDIF 4410 CONTINUE IF ( .NOT. FONLY ) THEN G(1) = TWO * G1 G(2) = X1 * G2 G(3) = TWO * X1 * X2 * G3 ENDIF GOTO 90000 C--------- MINTEST FUNCTION MEYER 4500 X1 = X(1) X2 = X(2) X3 = X(3) IF ( .NOT. GONLY ) THEN F = ZERO ENDIF IF ( .NOT. FONLY ) THEN G1 = ZERO G2 = ZERO G3 = ZERO ENDIF DO 4510 I = 1,16 TI = R45 + RD(I)*FIVE W1 = TI + X3 IF ( X2/W1 .LE. BIGGST ) THEN W2 = EXP(X2/W1) ELSE RET = NOFG GOTO 90000 ENDIF RI = X1*W2 - MEY(I) IF ( .NOT. GONLY ) THEN F = F + RI*RI ENDIF IF ( .NOT. FONLY ) THEN W2 = RI*W2 G1 = G1 + W2 G2 = G2 + W2/W1 G3 = G3 + W2/(W1*W1) ENDIF 4510 CONTINUE IF ( .NOT. FONLY ) THEN G(1) = TWO*G1 G(2) = TWO*G2*X1 G(3) = - TWO*G3*X1*X2 ENDIF GOTO 90000 C--------- MINTEST FUNCTION BROWND ( N, X, F, G, IFG, NINT(FARG(1))) C--------- NINT(FARG(1)) IS M 4600 IF ( .NOT. GONLY ) THEN F = ZERO ENDIF IF ( .NOT. FONLY ) THEN G1 = ZERO G2 = ZERO G3 = ZERO G4 = ZERO ENDIF DO 4610 I = 1,NINT(FARG(1)) W1 = RD(I)/FIVE W2 = SIN(W1) IF ( W1 .LE. BIGGST ) THEN W3 = X(1) + W1*X(2) - EXP(W1) ELSE RET = NOFG GOTO 90000 ENDIF W4 = X(3) + W2*X(4) - COS(W1) RI = W3*W3 + W4*W4 IF ( .NOT. GONLY ) THEN F = F + RI*RI ENDIF IF ( .NOT. FONLY ) THEN W3 = W3*RI W4 = W4*RI G1 = G1 + W3 G2 = G2 + W1*W3 G3 = G3 + W4 G4 = G4 + W2*W4 ENDIF 4610 CONTINUE IF ( .NOT. FONLY ) THEN G(1) = FOUR * G1 G(2) = FOUR * G2 G(3) = FOUR * G3 G(4) = FOUR * G4 ENDIF GOTO 90000 C--------- MINTEST FUNCTION KOWOSB 4700 IF ( .NOT. GONLY ) THEN F = ZERO ENDIF IF ( .NOT. FONLY ) THEN G1 = ZERO G2 = ZERO G3 = ZERO G4 = ZERO ENDIF X1 = X(1) X2 = X(2) X3 = X(3) X4 = X(4) DO 4710 I = 1,11 W1 = KOWOSU(I) W2 = W1*W1 W3 = W2 + W1*X2 W4 = W2 + W1*X3 + X4 W5 = W3/W4 RI = KOWOSY(I) - X1*W5 IF ( .NOT. GONLY ) THEN F = F + RI*RI ENDIF IF ( .NOT. FONLY ) THEN G1 = G1 + RI*W5 G2 = G2 + RI*W1/W4 W5 = RI*W5/W4 G3 = G3 + W5*W1 G4 = G4 + W5 ENDIF 4710 CONTINUE IF ( .NOT. FONLY ) THEN G(1) = - TWO*G1 G(2) = - TWO*G2*X1 G(3) = TWO*G3*X1 G(4) = TWO*G4*X1 ENDIF GOTO 90000 C--------- MINTEST FUNCTION OSBRN1 4800 IF ( .NOT. GONLY ) THEN F = ZERO ENDIF IF ( .NOT. FONLY ) THEN G1 = ZERO G2 = ZERO G3 = ZERO G4 = ZERO G5 = ZERO ENDIF X2 = X(2) X3 = X(3) DO 4810 I = 1,33 TI = TEN*(REAL(I) - ONE) IF ( MAX(-TI*X(4),-TI*X(5)) .LE. BIGGST ) THEN W1 = EXP(-TI*X(4)) W2 = EXP(-TI*X(5)) ELSE RET = NOFG GOTO 90000 ENDIF RI = X(1) + X2*W1 + X3*W2 - OSB1Y(I) IF ( .NOT. GONLY ) THEN F = F + RI*RI ENDIF IF ( .NOT. FONLY ) THEN W1 = W1*RI W2 = W2*RI G1 = G1 + RI G2 = G2 + W1 G3 = G3 + W2 G4 = G4 + W1*TI G5 = G5 + W2*TI ENDIF 4810 CONTINUE IF ( .NOT. FONLY ) THEN G(1) = TWO * G1 G(2) = TWO * G2 G(3) = TWO * G3 G(4) = -TWO*X2*G4 G(5) = -TWO*X3*G5 ENDIF GOTO 90000 C--------- MINTEST FUNCTION OSBRN2 4900 IF ( .NOT. GONLY ) THEN F = ZERO ENDIF IF ( .NOT. FONLY ) THEN G1 = ZERO G2 = ZERO G3 = ZERO G4 = ZERO G5 = ZERO G6 = ZERO G7 = ZERO G8 = ZERO G9 = ZERO G10= ZERO G11= ZERO ENDIF X1 = X(1) X2 = X(2) X3 = X(3) X4 = X(4) X5 = X(5) X6 = X(6) X7 = X(7) X8 = X(8) DO 4910 I = 1,65 TI = (REAL(I) - ONE)/TEN X9 = TI - X(9) W6 = X9*X9 X10 = TI - X(10) W7 = X10*X10 X11 = TI - X(11) W8 = X11*X11 IF ( MAX(-TI*X5,-X6*W6,-X7*W7,-X8*W8) .LE. BIGGST ) THEN W1 = EXP(-TI*X5) W2 = EXP(-X6*W6) W3 = EXP(-X7*W7) W4 = EXP(-X8*W8) ELSE RET = NOFG GOTO 90000 ENDIF RI = X1*W1 + X2*W2 + X3*W3 + X4*W4 - OSB2Y(I) IF ( .NOT. GONLY ) THEN F = F + RI*RI ENDIF IF ( .NOT. FONLY ) THEN W1 = RI*W1 W2 = RI*W2 W3 = RI*W3 W4 = RI*W4 G1 = G1 + W1 G2 = G2 + W2 G3 = G3 + W3 G4 = G4 + W4 G5 = G5 + W1 * TI G6 = G6 + W2 * W6 G7 = G7 + W3 * W7 G8 = G8 + W4 * W8 G9 = G9 + W2 * X9 G10 = G10 + W3 * X10 G11 = G11 + W4 * X11 ENDIF 4910 CONTINUE IF ( .NOT. FONLY ) THEN G(1) = TWO * G1 G(2) = TWO * G2 G(3) = TWO * G3 G(4) = TWO * G4 G(5) = - TWO * X1 * G5 G(6) = - TWO * X2 * G6 G(7) = - TWO * X3 * G7 G(8) = - TWO * X4 * G8 G(9) = FOUR * X2 * X6 * G9 G(10) = FOUR * X3 * X7 * G10 G(11) = FOUR * X4 * X8 * G11 ENDIF GOTO 90000 C--------- WATSON 5200 ERROR = N .LT. 2 .OR. N .GT. 31 IF ( .NOT. GONLY .OR. ERROR ) THEN F = ZERO ENDIF IF ( .NOT. FONLY .OR. ERROR ) THEN DO 5210 I = 1, N G(I) = ZERO 5210 CONTINUE ENDIF IF ( .NOT. ERROR ) THEN DO 5280 I = 1, 29 W1 = RD29 * RD(I) W2 = ZERO W3 = ONE DO 5230 J = 2, N W2 = W2 + W3 * X(J) * RD( J - 1 ) W3 = W3 * W1 5230 CONTINUE W4 = ZERO W3 = ONE DO 5240 J = 1, N W4 = W4 + W3 * X(J) W3 = W3 * W1 5240 CONTINUE W5 = W2 - W4 * W4 - ONE IF ( .NOT. GONLY ) THEN F = F + W5 * W5 ENDIF IF ( .NOT. FONLY ) THEN W6 = TWO * W1 * W4 W3 = TWO / W1 DO 5250 J = 1, N G(J) = G(J) + W3 * W5 * (REAL( J - 1) - W6 ) W3 = W3 * W1 5250 CONTINUE ENDIF 5280 CONTINUE W1 = X(1) W2 = X(2) W3 = W2 - W1 * W1 - ONE IF ( .NOT. GONLY ) THEN F = F + W1 * W1 + W3 * W3 ENDIF IF ( .NOT. FONLY ) THEN G(1) = G(1) + W1 * ( TWO - FOUR * W3 ) G(2) = G(2) + TWO * W3 ENDIF ENDIF GO TO 90000 C--------- MINTEST FUNCTION PENAL3 ( N, X, F, G, IFG, C FARG(1), WORK, SIZE ) C--------- FARG(1) IS A 5300 RF1 = FARG ( 1 ) IF ( SIZE .LT. 2 * N ) THEN F = ZERO DO 5310 K = 1, N G(K) = ZERO 5310 CONTINUE GO TO 90000 ENDIF I1 = 0 I2 = N W1 = RD(N) NOVER2 = N / 2 W2 = X(N) W3 = X(N-1) IF ( MAX(W2,W3) .LE. BIGGST ) THEN W4 = EXP(W2) W5 = EXP(W3) ELSE RET = NOFG GOTO 90000 ENDIF R = ZERO S = ZERO T = ( W2*W2 ) + ( W3*W3 ) - ( TWO*W1 ) IF ( .NOT. GONLY ) THEN U = ZERO ENDIF DO 5320 K = (N - 2), 1, -1 XK = X(K) RK = XK + TWO*W3 + TEN*W2 - ONE SK = TWO*XK + W3 - THREE R = R + RK*RK S = S + SK*SK T = T + XK*XK - W1 IF ( .NOT. FONLY ) THEN WORK(I1+K) = RK WORK(I2+K) = SK ENDIF IF ( .NOT. GONLY .AND. K .LE. NOVER2 ) THEN RK = XK - ONE U = U + RK*RK ENDIF W2 = W3 W3 = XK 5320 CONTINUE IF ( .NOT. GONLY ) THEN F = RF1 * ( ONE + W4*R + W5*S + R*S ) + T*T + U ENDIF IF ( .NOT. FONLY ) THEN W2 = TWO * ( W4 + S ) W1 = TWO * ( W5 + R ) W3 = FOUR*T W6 = WORK(I1+1) W7 = WORK(I1+2) W8 = WORK(I2+2) XK = X(1) G(1) = RF1 * ( W2 * ( W6 ) - + W1 * ( TWO*WORK(I2+1) ) ) - + W3*XK + TWO*(XK - ONE) XK = X(2) G(2) = RF1 * ( W2 * ( W7 + TWO*W6 ) - + W1 * ( TWO*W8 + WORK(I2+1) ) ) - + W3*XK + TWO*(XK - ONE) DO 5330 K = 3, (N - 2) RK = WORK(I1+K) SK = WORK(I2+K) XK = X(K) W9 = RF1 * ( W2 * ( RK + TWO*W7 + TEN*W6 ) - + W1 * ( TWO*SK + W8 ) ) - + W3*XK IF ( K .LE. NOVER2 ) THEN W9 = W9 + TWO * ( XK - ONE ) ENDIF G(K) = W9 W6 = W7 W7 = RK W8 = SK 5330 CONTINUE C ---NOTE THAT BELOW W7 = RK(N-2), W6 = RK(N-3) C ---AND W8 = SK(N-2). G(N-1) = RF1 * ( W2 * ( TWO*W7 + TEN*W6 ) - + W1 * ( W8 ) - + S * W5 ) - + W3*X(N-1) G(N) = RF1 * ( W2 * ( TEN*W7 ) - + R * W4 ) - + W3*X(N) ENDIF GOTO 90000 C--------- MINTEST FUNCTION VAROSB ( N, X, F, G, IFG, FARG(1) ) C--------- FARG(1) IS LAMBDA 5400 W2 = ONE / ( RD(N) + ONE ) W5 = TWO / W2 W2 = TWO * FARG(1) * W2 W6 = ZERO W9 = ONE W1 = ZERO TI = ZERO DO 5410 I = 1,N W7 = X(I) IF ( W7 .LE. BIGGST ) THEN W8 = EXP(W7) ELSE RET = NOFG GOTO 90000 ENDIF W3 = W7 - W6 IF ( .NOT. GONLY ) THEN W1 = W1 + W7*W7 - W6*W7 IF ( W3 .NE. ZERO ) THEN TI = TI + (W8 - W9)/ W3 ELSE TI = TI + W8 ENDIF ENDIF IF ( .NOT. FONLY ) THEN IF ( W3 .NE. ZERO ) THEN W4 = ( W9 + W8 * ( W3 - ONE ) ) / ( W3*W3 ) ELSE W4 = W9 / TWO ENDIF G(I) = W5 * W3 + W2 * W4 IF ( I .GT. 1 ) THEN IF ( W3 .NE. ZERO ) THEN W4 = (W8 - W9*(ONE + W3))/(W3*W3) ELSE W4 = W8 / TWO ENDIF G(I-1) = G(I-1) - W5 * W3 + W2 * W4 ENDIF ENDIF W6 = W7 W9 = W8 5410 CONTINUE IF ( .NOT. FONLY ) THEN IF ( W7 .NE. ZERO ) THEN W4 = ( ONE + ( W7 - ONE ) * W8 ) / ( W7*W7) ELSE W4 = W8 / TWO ENDIF G(N) = G(N) + W5 * W7 + W2 * W4 ENDIF IF ( .NOT. GONLY ) THEN IF ( W6 .NE. ZERO ) THEN W3 = ( W9 - ONE ) / W6 ELSE W3 = W9 ENDIF F = W5 * W1 + W2 * ( TI + W3 ) ENDIF GOTO 90000 C--------- VARDIM 5500 W1 = ZERO W2 = ZERO DO 5510 J = 1, N W3 = X(J) - ONE W1 = W1 + RD(J)*W3 W2 = W2 + W3*W3 5510 CONTINUE W4 = W1*W1 IF ( .NOT. GONLY ) THEN F = W2 + W4 * (ONE + W4) ENDIF IF ( .NOT. FONLY ) THEN W3 = W1 * (ONE + TWO * W4) DO 5520 J = 1, N G(J) = TWO * (X(J) - ONE + RD(J) * W3) 5520 CONTINUE ENDIF GOTO 90000 C--------- RECIPE 5600 CONTINUE W2 = (X(2) - X(1))**2 W3 = (X(2) - X(1))**3 IF ( .NOT. GONLY ) THEN F = (X(1)-FIVE)**2 + X(2)**2 + X(3)**2/W2 ENDIF IF ( .NOT. FONLY ) THEN G(1) = TWO*(X(1) - FIVE) + TWO*X(3)**2/W3 G(2) = TWO*X(2) - TWO*X(3)**2/W3 G(3) = TWO*X(3)/W2 ENDIF GOTO 90000 C--------- CLIFF 5700 CONTINUE W1 = (X(1) - THREE)/R100 W2 = EXP(R20*(X(1)-X(2))) IF ( .NOT. GONLY ) THEN F = W1**2 - X(1) + X(2) + W2 ENDIF IF ( .NOT. FONLY ) THEN G(1) = W1/R50 - ONE + R20*W2 G(2) = ONE - R20*W2 ENDIF GOTO 90000 C--------- CHEBYQ ( N, X, F, G, IFG, WORK, SIZE ) 5800 IF ( SIZE .LT. N ) THEN F = ZERO DO 5810 I = 1, N G(I) = ZERO 5810 CONTINUE ELSE DO 5820 I = 1, N WORK(I) = ZERO 5820 CONTINUE DO 5830 J = 1, N W1 = ONE W2 = TWO * X(J) - ONE W3 = TWO * W2 DO 5840 I = 1, N WORK(I) = WORK(I) + W2 W4 = W3 * W2 - W1 W1 = W2 W2 = W4 5840 CONTINUE 5830 CONTINUE IF ( .NOT. GONLY ) THEN F = ZERO ENDIF W7 = ONE / RD(N) EVEN = .FALSE. DO 5850 I = 1, N W2 = W7 * WORK(I) IF ( EVEN ) THEN W2 = W2 + ONE / ( RD(I)**2 - ONE ) ENDIF EVEN = .NOT. EVEN IF ( .NOT. GONLY ) THEN F = F + W2 * W2 ENDIF IF ( .NOT. FONLY ) THEN WORK(I) = W2 ENDIF 5850 CONTINUE IF ( .NOT. FONLY ) THEN DO 5860 J = 1, N G(J) = ZERO W1 = ONE W2 = TWO * X(J) - ONE W3 = TWO * W2 W4 = ZERO W5 = TWO DO 5870 I = 1, N G(J) = G(J) + WORK(I) * W5 W6 = FOUR * W2 + W3 * W5 - W4 W4 = W5 W5 = W6 W6 = W3 * W2 - W1 W1 = W2 W2 = W6 5870 CONTINUE 5860 CONTINUE W7 = W7 * TWO CALL ZZSCAL ( N, W7, G, 1 ) ENDIF ENDIF GOTO 90000 C--------- MINTEST FUNCTION HIMM32 5900 IF ( .NOT. GONLY ) THEN F = ZERO ENDIF IF ( .NOT. FONLY ) THEN G1 = ZERO G2 = ZERO G3 = ZERO G4 = ZERO ENDIF X1 = X(1) X2 = X(2) X3 = X(3) X4 = X(4) W1 = X1*X1 W2 = X2*X2 W3 = X3*X3 W4 = X4*X4 DO 5910 I = 1,7 W8 = HIM32A(I) W9 = HIM32B(I) W5 = W1 + W2*W8 + W3*W8*W8 W6 = W9*(ONE + W4*W8) RI = W5/W6 - ONE IF ( .NOT. GONLY ) THEN F = F + RI*RI ENDIF IF ( .NOT. FONLY ) THEN W7 = RI/W6 G1 = G1 + W7 W7 = W7*W8 G2 = G2 + W7 G3 = G3 + W7*W8 G4 = G4 + W7*W5*W9/W6 ENDIF 5910 CONTINUE IF ( .NOT. GONLY ) THEN F = F*R10000 ENDIF IF ( .NOT. FONLY ) THEN G(1) = R40000*X1*G1 G(2) = R40000*X2*G2 G(3) = R40000*X3*G3 G(4) = -R40000*X4*G4 ENDIF GOTO 90000 C--------- MINTEST FUNCTION HIMM27 6000 X1 = X(1) X2 = X(2) W1 = X1*X2 W2 = ONE - X1 W3 = W2*W2*W2*W2 W4 = ONE - X2 - X1*W2*W3 W5 = W1*W2*W4 IF ( .NOT. GONLY ) THEN F = W5*W5 ENDIF IF ( .NOT. FONLY ) THEN W5 = TWO*W5 G(1) = W5 * ( X2*W2*W4 - W1*W4 + W1*W2*W3*( SIX*X1 - ONE ) ) G(2) = W5*W2 * ( X1*W4 - W1 ) ENDIF GOTO 90000 C--------- BRYTRI 6100 IF ( .NOT. GONLY ) THEN F = ZERO ENDIF KAP1 = FARG(1) KAP2 = FARG(2) W1 = X(1) W2 = ZERO W3 = ZERO DO 6110 I = 1,N IF ( I .LT. N ) THEN W4 = X(I+1) ELSE W4 = ZERO ENDIF RI = (THREE - KAP1*W1)*W1 - W2 - TWO*W4 + KAP2 IF ( .NOT. GONLY ) THEN F = F + RI*RI ENDIF IF ( .NOT. FONLY ) THEN IF ( I .GT. 1 ) THEN G(I-1) = TWO*(W5 - RI) ENDIF W5 = -TWO*W3 + RI*(THREE - TWO*KAP1*W1) W3 = RI ENDIF W2 = W1 W1 = W4 6110 CONTINUE G(N) = TWO*W5 GOTO 90000 C--------- BRWNAL 6200 S = ZERO T = ONE W1 = ZERO DO 6210 I = 1,N XI = X(I) S = S + XI T = T * XI 6210 CONTINUE W2 = T - ONE IF ( .NOT. GONLY ) THEN F = W2 * W2 ENDIF W2 = W2*T W3 = RD(N+1) DO 6220 I = 1,N-1 XI = X(I) RI = XI + S - W3 IF ( .NOT. GONLY ) THEN F = F + RI*RI ENDIF IF ( .NOT. FONLY ) THEN G(I) = RI + W2/XI W1 = W1 + RI ENDIF 6220 CONTINUE DO 6230 I = 1,N-1 G(I) = TWO * (W1 + G(I)) 6230 CONTINUE G(N) = TWO * (W1 + W2/X(N)) GOTO 90000 C## E X I T 90000 STATUS(7) = RET 91000 GFIRST = .FALSE. RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZFNS3. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> fns4sg.f SUBROUTINE ZZFNS4 ( N, X, F, G, WORK, SIZE, FONLY, GONLY, - FIRST, FARG, FUNCNO, STATUS ) C## A R G U M E N T S: INTEGER N, SIZE, FUNCNO, STATUS(7) LOGICAL FIRST, FONLY, GONLY REAL F, X(N), G(N), WORK(SIZE), FARG(*) C!!!! DOUBLE PRECISION F, X(N), G(N), WORK(SIZE), FARG(*) C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: FNS4.F,V 1.2 91/12/31 14:38:18 BUCKLEY EXP $ C>RCS $LOG: FNS4.F,V $ C>RCSREVISION 1.2 91/12/31 14:38:18 BUCKLEY C>RCSFINAL SUBMISSION TO TOMS C>RCS C>RCSREVISION 1.1 91/11/20 10:52:53 BUCKLEY C>RCSFINAL SUBMISSION TO TOMS C>RCS C>RCSREVISION 1.0 90/07/31 13:01:57 BUCKLEY C>RCSINITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS SUBROUTINE EVALUATES ONE OF THE STANDARD TEST FUNCTIONS. C THE TEST FUNCTIONS ARE DIVIDED AMOUNG FOUR ROUTINES BECAUSE A C SINGLE ROUTINE WOULD BE TOO LARGE FOR SOME COMPILERS. C THE ARGUMENTS IN THE CALLING SEQUENCE HAVE PRECISELY THE SAME C MEANING AS IN THE ROUTINE ZZEVAL. C C THE VALUE OF THE INTEGER PARAMETER FUNCNO SPECIFIES C WHICH OF THE TEST FUNCTIONS IS TO BE USED; THE FUNCTION C IS CHOSEN USING A COMPUTED GOTO. C C THE PARAMETERS FONLY AND GONLY SPECIFY FUNCTION AND C GRADIENT EVALUATIONS. THE PARAMETER FIRST SPECIFIES CODE TO BE C EVALUATED ONLY ON THE FIRST CALL TO A PARTICULAR FUNCTION. C THE PARAMETER STATUS STORES THE RETURN CODES. C C## E N T R Y P O I N T S: ZZFNS4 THE NATURAL ENTRY POINT. C C## S U B R O U T I N E S: C C PREDEFINED FUNCTIONS : SIN, COS, TAN, ACOS, ATAN, ABS, MAX, NINT C EXP, LOG, MIN, MOD, SIGN, SQRT, REAL(DBLE) C C STATEMENT FUNCTION: RD C C## P A R A M E T E R S: REAL ZERO, ONE, TWO, THREE C!!!! DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) REAL FOUR, FIVE, SIX, SEVEN C!!!! DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) REAL EIGHT, NINE, TEN C!!!! DOUBLE PRECISION EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 9D0, TEN = 10D0 ) REAL TENTH, FIFTH, HALF C!!!! DOUBLE PRECISION TENTH, FIFTH, HALF PARAMETER ( TENTH = .1D0, FIFTH = .2D0, HALF = .5D0 ) REAL RPT9, RPT8, RD29 C!!!! DOUBLE PRECISION RPT9, RPT8, RD29 PARAMETER ( RPT9 = .9D0, RPT8 = .8D0, RD29 = 1D0/29D0 ) REAL R11, R12, R13, R14 C!!!! DOUBLE PRECISION R11, R12, R13, R14 PARAMETER ( R11 = 11D0, R12 = 12D0, R13 = 13D0,R14 = 14D0) REAL R15, R16, R17, R18 C!!!! DOUBLE PRECISION R15, R16, R17, R18 PARAMETER ( R15 = 15D0, R16 = 16D0, R17 = 17D0,R18 = 18D0) REAL R19, R20, R25, R29 C!!!! DOUBLE PRECISION R19, R20, R25, R29 PARAMETER ( R19 = 19D0, R20 = 20D0, R25 = 25D0,R29 = 29D0) REAL R32, R36, R40, R42 C!!!! DOUBLE PRECISION R32, R36, R40, R42 PARAMETER ( R32 = 32D0, R36 = 36D0, R40 = 40D0,R42 = 42D0) REAL R45, R49 C!!!! DOUBLE PRECISION R45, R49 PARAMETER ( R45 = 45D0, R49 = 49D0 ) REAL R50, R56, R84, R90 C!!!! DOUBLE PRECISION R50, R56, R84, R90 PARAMETER ( R50 = 50D0, R56 = 56D0, R84 = 84D0,R90 = 90D0) REAL R100, R180, R200 C!!!! DOUBLE PRECISION R100, R180, R200 PARAMETER ( R100 = 100D0, R180 = 180D0, R200 = 200D0 ) REAL R256, R360, R400 C!!!! DOUBLE PRECISION R256, R360, R400 PARAMETER ( R256 = 256D0, R360 = 360D0, R400 = 400D0 ) REAL R600, R681, R991 C!!!! DOUBLE PRECISION R600, R681, R991 PARAMETER ( R600 = 600D0, R681 = 681D0, R991 = 991D0 ) REAL R1162, R2324 C!!!! DOUBLE PRECISION R1162, R2324 PARAMETER ( R1162 = 1162D0, R2324 = 2324D0 ) REAL R10000, R40000 C!!!! DOUBLE PRECISION R10000, R40000 PARAMETER ( R10000 = 10000D0, R40000 = 40000D0 ) REAL R1PD6, R2PDM6 C!!!! DOUBLE PRECISION R1PD6, R2PDM6 PARAMETER ( R1PD6 = 1D6, R2PDM6 = 2D-6 ) REAL RP04, RP01, R1PZ1 C!!!! DOUBLE PRECISION RP04, RP01, R1PZ1 PARAMETER ( RP04 = 4D-2, RP01 = .01D0, R1PZ1 = 1.0001D0 ) REAL R1P2, R7P5, RP1136 C!!!! DOUBLE PRECISION R1P2, R7P5, RP1136 PARAMETER ( R1P2 = 1.2D0, R7P5 = 7.5D0, RP1136 = 0.1136D0 ) REAL R1P5, R2P5, R2P625 C!!!! DOUBLE PRECISION R1P5, R2P5, R2P625 PARAMETER ( R1P5 = 1.5D0, R2P5 = 2.5D0, R2P625 = 2.625D0 ) REAL R10P1, R19P8, R20P2 C!!!! DOUBLE PRECISION R10P1, R19P8, R20P2 PARAMETER ( R10P1 = 10.1D0,R19P8 = 19.8D0,R20P2 = 20.2D0 ) REAL R2D3, R4D3, R7D3 C!!!! DOUBLE PRECISION R2D3, R4D3, R7D3 PARAMETER ( R2D3 = 2D0/3D0,R4D3 = 4D0/3D0,R7D3 = 7D0/3D0 ) REAL R2P25 C!!!! DOUBLE PRECISION R2P25 PARAMETER ( R2P25 = 2.25D0 ) C## L O C A L D E C L: INTEGER OK, ABORT, LIMIT, NOF, NOG, NOFG INTEGER F1, I, J, K, J0, J1, J2, J3, JLO, JHI INTEGER IR, I3, IL, N1, RET, P, M, L, IDUMMY INTEGER RHO1, RHO2, K1, K2, K3, K4, I1, I2 LOGICAL GFIRST, DONE, PROB13 REAL ZZMPAR, HUGE C!!!! DOUBLE PRECISION ZZMPAR, HUGE C--------- VARIABLES FOR THE TEST FUNCTIONS. REAL X1, X2, X3, X4, S1 C!!!! DOUBLE PRECISION X1, X2, X3, X4, S1 REAL W1, W2, W3, W4, W5, W6 C!!!! DOUBLE PRECISION W1, W2, W3, W4, W5, W6 REAL W7, W8, W9, W10 C!!!! DOUBLE PRECISION W7, W8, W9, W10 REAL R, S, T, R1, BIGGST, SMLLST C!!!! DOUBLE PRECISION R, S, T, R1, BIGGST, SMLLST REAL R2, R3, RI, TI C!!!! DOUBLE PRECISION R2, R3, RI, TI REAL XI, YI, PI C!!!! DOUBLE PRECISION XI, YI, PI REAL XP1, XM1, R2P, RD, TPI, TPIS C!!!! DOUBLE PRECISION XP1, XM1, R2P, RD, TPI, TPIS REAL KAP1, KAP2, KAP3, H, TK, ALPHA C!!!! DOUBLE PRECISION KAP1, KAP2, KAP3, H, TK, ALPHA C## S A V E: SAVE GFIRST, PI, TPI, TPIS, R2P, BIGGST, SMLLST SAVE HUGE, PROB13, DONE, M SAVE OK, ABORT, LIMIT, NOF, NOG, NOFG C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA GFIRST/.TRUE./ C## E X E C U T I O N C## E X E C U T I O N C--------- FUNCTION DEFINITION RD (IDUMMY) = REAL (IDUMMY) C!!!! RD (IDUMMY) = DBLE (IDUMMY) C--------- SOME ONE TIME ONLY CONSTANTS. IF ( GFIRST ) THEN PI = ACOS(-ONE) TPI = TWO * PI TPIS = TPI * PI R2P = ONE / TPI HUGE = ZZMPAR(3)/TEN SMLLST = LOG(ZZMPAR(2)*TEN) BIGGST = LOG(HUGE) OK = STATUS(1) ABORT = STATUS(2) LIMIT = STATUS(3) NOF = STATUS(4) NOG = STATUS(5) NOFG = STATUS(6) ENDIF C--------- SET LOGICAL FLAGS AND SELECT FUNCTION. RET = OK GOTO( - 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, - 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, - 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, - 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, - 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, 1000, - 1000, 1000, 6300, 6400, 6500, 6600, 6700, 6800, 6900, 7000, - 7100, 7200, 7300, 7400, 7500, 7600, 7700, 7800, 7900, 8000, - 8100, 8200, 8300, 7700, 1000, 1000, 1000, 1000, 1000, 1000 - ) FUNCNO 1000 STATUS(7) = ABORT GOTO 91000 C---- ARGQDN ( N, X, F, G, IFG, NINT(FARG(1))) C---- NINT(FARG(1)) IS M 6300 F1 = NINT ( FARG ( 1 ) ) IF ( .NOT. GONLY ) THEN F = ZERO ENDIF S = ZERO W4 = ZERO IF ( F1 .GE. N ) THEN DO 6310 I = 1,N S = S + X(I) 6310 CONTINUE W2 = -TWO*S/FARG(1) - ONE DO 6320 I = 1,N RI = X(I) + W2 IF ( .NOT. GONLY ) THEN F = F + RI**2 ENDIF IF ( .NOT. FONLY ) THEN W4 = W4 + RI G(I) = TWO * RI ENDIF 6320 CONTINUE W1 = RD( F1 - N ) IF ( .NOT. GONLY ) THEN F = F + W1*W2**2 ENDIF IF ( .NOT. FONLY ) THEN W4 = FOUR * ( W4 + W1*W2 ) / FARG(1) DO 6330 I = 1,N G(I) = G(I) - W4 6330 CONTINUE ENDIF ELSE IF ( .NOT. FONLY ) THEN DO 6340 I = 1,N G(I) = ZERO 6340 CONTINUE ENDIF GOTO 90000 C--------- MINTEST FUNCTION ARGQDO ( N, X, F, G, IFG, NINT(FARG(1))) C--------- NINT(FARG(1)) IS M 6400 F1 = NINT( FARG(1) ) IF ( .NOT. GONLY ) THEN F = ZERO ENDIF S = ZERO W1 = ZERO IF ( F1 .GE. N ) THEN DO 6410 I = 1,N S = S + RD(I)*X(I) 6410 CONTINUE DO 6420 I = 1,F1 W2 = RD(I) RI = W2*S - ONE IF ( .NOT. GONLY ) THEN F = F + RI*RI ENDIF IF ( .NOT. FONLY ) THEN W1 = W1 + RI*W2 ENDIF 6420 CONTINUE ENDIF IF ( .NOT. FONLY ) THEN W1 = TWO * W1 DO 6430 I = 1,N G(I) = RD(I) * W1 6430 CONTINUE ENDIF GOTO 90000 C--------- MINTEST FUNCTION ARGQDZ ( N, X, F, G, IFG, NINT(FARG(1))) C--------- NINT(FARG(1)) IS M 6500 F1 = NINT( FARG(1) ) IF ( .NOT. GONLY ) THEN F = TWO ENDIF S = ZERO W1 = ZERO IF ( F1 .GE. N ) THEN DO 6510 I = 2,N-1 S = S + RD(I)*X(I) 6510 CONTINUE DO 6520 I = 2,F1-1 W2 = RD(I-1) RI = W2 * S - ONE IF ( .NOT. GONLY ) THEN F = F + RI*RI ENDIF IF ( .NOT. FONLY ) THEN W1 = W1 + RI*W2 ENDIF 6520 CONTINUE ENDIF IF ( .NOT. FONLY ) THEN W1 = TWO * W1 G(1) = ZERO DO 6530 I = 2,N-1 G(I) = RD(I) * W1 6530 CONTINUE G(N) = ZERO ENDIF GOTO 90000 C--------- MINTEST FUNCTION MOREBV 6600 IF ( .NOT. GONLY ) THEN F = ZERO ENDIF W1 = ONE/(RD(N)+ONE) W2 = W1*W1 / TWO W3 = THREE*W2 XI = X(1) W4 = XI W8 = ZERO DO 6610 I = 1,N TI = RD(I)*W1 IF ( I .LT. N ) THEN W10 = X(I+1) ELSE W10 = ZERO ENDIF W6 = W10 - XI W7 = XI + TI + ONE RI = W4 - W6 + W2*W7*W7*W7 IF ( .NOT. GONLY ) THEN F = F + RI*RI ENDIF IF ( .NOT. FONLY ) THEN IF ( I .NE. 1 ) THEN G(I-1) = TWO*(-W5 - RI + W8*W9) ENDIF W9 = TWO + W3 * W7*W7 W5 = W8 W8 = RI ENDIF XI = W10 W4 = W6 6610 CONTINUE IF ( .NOT. FONLY ) THEN G(N) = TWO*(-W5 + RI*W9) ENDIF GOTO 90000 C--- BROY7D 6700 IF ( .NOT. GONLY ) THEN F = ZERO ENDIF XM1 = ZERO XI = X(1) W4 = ZERO DO 6710 I = 1,60 IF (I .LT. 60) THEN XP1 = X(I+1) ELSE XP1 = ZERO ENDIF YI = XM1 - (THREE-XI/TWO)*XI + TWO*XP1 - ONE IF ( .NOT. GONLY ) THEN F = F + (ABS(YI))**R7D3 ENDIF IF (I .LE. 30) THEN W2 = XI + X(I+30) IF ( .NOT. GONLY ) THEN F = F + (ABS(W2))**R7D3 ENDIF ELSE W2 = X(I-30) + XI ENDIF IF ( .NOT. FONLY ) THEN TI = (ABS(YI))**R4D3 TI = SIGN(TI,YI) IF ( I .GT. 1 ) THEN G(I-1) = R7D3*(W1 + TI) ENDIF W3 = (ABS(W2))**R4D3 W3 = SIGN(W3,W2) W1 = TWO*W4 + TI*(XI - THREE) + W3 W4 = TI ENDIF XM1 = XI XI = XP1 6710 CONTINUE IF ( .NOT. FONLY ) THEN G(60) = R7D3 * W1 ENDIF GOTO 90000 C--------- MINTEST FUNCTION BRKMCC 6800 X1 = X(1) X2 = X(2) W1 = X1 - TWO W2 = X2 - ONE W3 = X1 - TWO*X2 + ONE W4 = -X1*X1/FOUR - X2*X2 + ONE IF ( .NOT. GONLY ) THEN F = W1*W1 + W2*W2 + RP04/W4 + FIVE*W3*W3 ENDIF IF ( .NOT. FONLY ) THEN W4 = W4*W4 G(1) = TWO*W1 + X1/(R50*W4) + TEN*W3 G(2) = TWO*W2 + TWO*X2/(R25*W4) - R20*W3 ENDIF GOTO 90000 C--------- MINTEST FUNCTION HIMM29 6900 X1 = X(1) X2 = X(2) W3 = X1*X1 W1 = W3 + R12*X2 - ONE W2 = R49*W3 + R49*X2*X2 + R84*X1 + R2324*X2 - R681 IF ( .NOT. GONLY ) THEN F = W1*W1 + W2*W2 ENDIF IF ( .NOT. FONLY ) THEN G(1) = FOUR * ( X1*W1 + ( R49*X1 + R42 ) * W2 ) G(2) = FOUR * ( SIX*W1 + ( R49*X2 + R1162 ) * W2 ) ENDIF GOTO 90000 C--------- MINTEST FUNCTION HIMM33 7000 X1 = X(1) X2 = X(2) ALPHA = FARG(1) IF ( -(X1+X2) .LE. BIGGST ) THEN W1 = EXP(-(X1+X2)) ELSE RET = NOFG GOTO 90000 ENDIF W2 = TWO*X1**2 + THREE*X2**2 IF ( .NOT. GONLY ) THEN F = ALPHA*W1*W2 ENDIF IF ( .NOT. FONLY ) THEN G(1) = ALPHA * W1 * (FOUR*X1 - W2) G(2) = ALPHA * W1 * (SIX*X2 - W2) ENDIF IF ( ABS(F) .LE. 100. ) THEN WRITE(6,*) 'F = ', F WRITE(6,*) 'G(1) = ', G(1), ' G(2) = ', G(2) C WRITE(6,*) 'G(2) = ', G(2) WRITE(6,*) 'X1 = ', X1, ' X2 = ', X2 C WRITE(6,*) 'X2 = ', X2 WRITE(6,*) ' ' END IF GOTO 90000 C--------- HIMM30 7100 X1 = X(1) X2 = X(2) X3 = X(3) W1 = X1 + X2 R1 = X3 - W1*W1/FOUR R2 = ONE - X1 R3 = ONE - X2 W2 = R100*R1 IF ( .NOT. GONLY ) THEN F = W2*R1 + R2*R2 + R3*R3 ENDIF IF ( .NOT. FONLY ) THEN G(1) = -W2*W1 - TWO*R2 G(2) = -W2*W1 - TWO*R3 G(3) = W2*TWO ENDIF GOTO 90000 C---- GOTTFR 7200 CONTINUE W1 = X(1) - RP1136*(X(1)+THREE*X(2))*(ONE-X(1)) W2 = X(2) + R7P5* (TWO*X(1)-X(2)) *(ONE-X(2)) IF ( .NOT. GONLY ) THEN F = W1**2 + W2**2 ENDIF IF ( .NOT. FONLY ) THEN G(1) = TWO*( W1*(ONE-RP1136*(-TWO*X(1)+1-THREE*X(2))) - +W2*(R15*(ONE-X(2)))) G(2) = TWO*( W1*(-RP1136*THREE*(ONE-X(1))) - +W2*(ONE+R7P5*(TWO*X(2)-ONE-TWO*X(1)))) ENDIF GOTO 90000 C--------- BRYBND ( N, X, F, G, IFG, WORK, SIZE ) 7300 IF ( SIZE .LT. N ) THEN F = ZERO DO 7308 I = 1, N G(I) = ZERO 7308 CONTINUE ELSE KAP1 = FARG(1) KAP2 = FARG(2) KAP3 = FARG(3) RHO1 = NINT(FARG(4)) RHO2 = NINT(FARG(5)) DO 7309 I = 1, N WORK(I) = ZERO IF ( .NOT. FONLY ) THEN G(I) = ZERO ENDIF 7309 CONTINUE DO 7313 I = 1, N W1 = X(I) * ( KAP1 + KAP2 * X(I)**2 ) JLO = MAX (I-RHO1, 1) JHI = MIN (I+RHO2, N) DO 7311 J = JLO, I-1 WORK(I) = WORK(I) + X(J) + X(J)**2 7311 CONTINUE DO 7312 J = I+1, JHI WORK(I) = WORK(I) + X(J) + X(J)**2 7312 CONTINUE WORK(I) = W1 + ONE - KAP3*WORK(I) 7313 CONTINUE IF ( .NOT. GONLY ) THEN F = ZERO ENDIF DO 7320 I = 1, N IF ( .NOT. GONLY ) THEN F = F + WORK(I) **2 ENDIF IF ( .NOT. FONLY ) THEN W2 = TWO * KAP3 *( ONE + TWO * X(I) ) W1 = TWO * WORK(I) * ( KAP1 + THREE*KAP2* X(I)**2 ) JLO = MAX (I-RHO2, 1) JHI = MIN (I+RHO1, N) DO 7314 J = JLO, I-1 G(I) = G(I) + WORK(J) 7314 CONTINUE DO 7316 J = I+1, JHI G(I) = G(I) + WORK(J) 7316 CONTINUE G(I) = W1 - W2 * G(I) ENDIF 7320 CONTINUE ENDIF GO TO 90000 C----- CLUSTR 7400 CONTINUE W1 = SIN(X(1)) W2 = SIN(X(2)) W3 = COS(X(1)) W4 = COS(X(2)) R1 = (X(1)-X(2)**2)*(X(1)-W2) R2 = (W4-X(1))*(X(2)-W3) IF ( .NOT. GONLY ) THEN F = R1**2 + R2**2 ENDIF IF ( .NOT. FONLY ) THEN G(1) = TWO*(R1*(TWO*X(1)-W2-X(2)**2) - + R2*(-X(2)+W3+(W4-X(1))*W1)) G(2) = TWO*(R1*(-TWO*X(2)*(X(1)-W2)-W4*(X(1)-X(2)**2)) - + R2*(-X(1)+W4+(W3-X(2))*W2)) ENDIF GOTO 90000 C------ ARTRIG(N,X,F,G,IFG,WORK) 7500 IF ( .NOT. GONLY ) THEN F = ZERO ENDIF IF ( .NOT. FONLY ) THEN DO 7505 I = 1,N G(I) = ZERO W3 = ZERO 7505 CONTINUE ENDIF IF ( SIZE .LT. 2*N ) THEN RET = NOFG GOTO 90000 ELSE W1 = ZERO DO 7507 I = 1,N WORK(I) = SIN(X(I)) WORK(N+I) = COS(X(I)) W1 = W1 + WORK(N+I) 7507 CONTINUE ENDIF DO 7580 I = 1,N W2 = N - W1 + I*(ONE-WORK(N+I)) - WORK(I) IF ( .NOT. GONLY ) THEN F = F + W2**2 ENDIF IF ( .NOT. FONLY ) THEN G(I) = G(I) + W2 * ( (ONE+I) * WORK(I) - WORK(N+I) ) W3 = W3 + W2 WORK(N+I) = W2 ENDIF 7580 CONTINUE IF ( .NOT. FONLY ) THEN DO 7590 I = 1, N G(I) = G(I) + WORK(I) * ( W3 - WORK(N+I) ) 7590 CONTINUE CALL ZZSCAL ( N, TWO, G, 1 ) ENDIF GOTO 90000 C------------------ FUNCTION SQRTMX(N,X,F,G,IFG,FARG(1)) C FARG(1) MUST BE SET TO A NON-ZERO VALUE FOR C THE LIU-NOCEDAL PROBLEM #13 (=0 OR 1) OR #15 (=2). 7600 CONTINUE IF ( FIRST .AND. FARG(1) .NE. 2 ) THEN PROB13 = FARG(1) .NE. ZERO M = NINT( SQRT(RD(N)) ) FIRST = .FALSE. IF ( SIZE .GE. N ) THEN DO 7610 I = 1,N L = MOD(I-1,M) K = (I-1)/M W1 = ZERO DO 7605 J = 1,M P = M*L + J IF ( PROB13 .AND. P .EQ. 2*M+1) THEN W2 = ZERO ELSE W2 = SIN(RD(P**2)) ENDIF P = M*(J-1) + K + 1 IF ( PROB13 .AND. P .EQ. 2*M+1) THEN W3 = ZERO ELSE W3 = SIN(RD(P**2)) ENDIF W1 = W1 + W2*W3 7605 CONTINUE WORK(I) = W1 7610 CONTINUE DONE = .FALSE. ELSE DONE = .FALSE. ENDIF ENDIF IF ( .NOT. GONLY ) THEN F = ZERO ENDIF IF ( .NOT. FONLY ) THEN DO 7620 I = 1,N G(I) = ZERO 7620 CONTINUE ENDIF IF ( FARG(1) .NE. 2 ) THEN DO 7640 I = 1,N L = MOD(I-1,M) K = (I-1)/M W1 = ZERO DO 7625 J = 1,M W1 = W1 + X(M*L+J) * X(M*(J-1)+K+1) 7625 CONTINUE IF ( DONE ) THEN W4 = WORK(I) ELSE W4 = ZERO DO 7630 J = 1,M P = M*L + J IF ( PROB13 .AND. P .EQ. 2*M+1) THEN W2 = ZERO ELSE W2 = SIN(RD(P**2)) ENDIF P = M*(J-1)+K+1 IF ( PROB13 .AND. P .EQ. 2*M+1) THEN W3 = ZERO ELSE W3 = SIN(RD(P**2)) ENDIF W4 = W4 + W2*W3 7630 CONTINUE ENDIF IF ( .NOT. GONLY ) THEN F = F + (W4 - W1)**2 ENDIF IF ( .NOT. FONLY ) THEN DO 7635 J = 1,M I1 = M*L + J I2 = M*(J-1) + K + 1 G(I1) = G(I1) + (W4-W1) * X(I2) G(I2) = G(I2) + (W4-W1) * X(I1) 7635 CONTINUE ENDIF 7640 CONTINUE IF ( .NOT. FONLY ) THEN CALL ZZSCAL ( N, -TWO, G, 1 ) ENDIF ELSE C---- SPARSE SQUARE ROOT MATRIX CONTINUE M = (N+2)/3 K1 = 5*M-6 I = 1 J = 0 DO 7690 K=1,K1 C COMPUTE (I,J) FOR A GIVEN K J = J+1 IF ( K .EQ. 4 .OR. K .EQ. 8 .OR. K .EQ. 13) THEN I = I+1 J = 1 ENDIF 7660 IF (J .EQ. 1) THEN J1 = I-3 K3 = J1 IF (J1 .LE. 0) J1 = 0 J = J+J1 ENDIF IF ( J-K3 .EQ. 6 .OR. J .EQ. M+1) THEN I = I+1 J = 1 GO TO 7660 ENDIF IL = 3*(I-1) I2 = IL IR = I*3-1 IF (IR .GT. N) IR = N J2 = 3*(J-1)-1 J3 = J2 J0 = 3*J IF (J0 .GT. N) J0 = N I3 = I-2 J1 = J-2 IF (I .EQ. 1) THEN IL = 1 I2 = IL IR = 2 I3 = 0 ENDIF IF (J .EQ. 1) THEN J2 = 1 J3 = J2 J0 = 3 J1 = 0 ENDIF IF (I3 .LE. J1) THEN N1 = J1-I3 IL = IL+N1 S = ZERO DO 7665 K2 = IL,IR S = S + X(K2)*X(J2) - SIN(RD(K2**2))*SIN(RD(J2**2)) J2 = J2+2 IF (J2 .GT. J0) GO TO 7670 7665 CONTINUE 7670 S1 = S IF ( .NOT. FONLY ) THEN DO 7675 K2=IL,IR G(K2) = G(K2) + TWO*S*X(J3) G(J3) = G(J3) + TWO*S*X(K2) J3 = J3 + 2 IF (J3.GT.J0) GO TO 7690 7675 CONTINUE ENDIF ELSE N1 = I3-J1 J2 = J2 + 2*N1 S = ZERO DO 7680 K2 = J2,J0,2 S = S + X(K2)*X(IL)- SIN(RD(K2**2))*SIN(RD(IL**2)) IL = IL+1 7680 CONTINUE S1 = S IF ( .NOT. FONLY ) THEN DO 7685 K2=J2,J0,2 G(K2) = G(K2) + TWO*S*X(I2) G(I2) = G(I2) + TWO*S*X(K2) I2 = I2 + 1 7685 CONTINUE ENDIF ENDIF IF ( .NOT. GONLY ) THEN F = F+ S1**2 ENDIF 7690 CONTINUE ENDIF GO TO 90000 C------------------ FUNCTIONS MNSRF1 AND MNSRF2(N,X,F,G,IFG,WORK,FARG(1)) C TOINT'S MINIMUM SURFACE FUNCTIONS: C MNSRF1: LINEAR AND NON-LINEAR CASES (TOI83B #11 AND #12). C SET FARG(1) = 0. C MNSRF2: SHIFTED LINEAR AND SHIFTED NON-LINEAR CASES (TOI83B #13 AND #14). C SET FARG(1) = 1. 7700 CONTINUE F1 = NINT ( FARG ( 1 ) ) T = SQRT(RD(N)) M = NINT(T) I1 = (M-1)**2 W1 = RD(I1) IF ( .NOT. GONLY ) THEN F = ZERO ENDIF IF ( .NOT. FONLY ) THEN DO 7720 I=1,N G(I)= ZERO 7720 CONTINUE ENDIF DO 7770 I=1,I1 S = RD(I)/(T-ONE) I2 = INT(S)*M + MOD(I,M-1) IF ( MOD(I,M-1) .EQ. 0 ) I2 = I2 - 1 W3 = (X(I2)-X(I2+M+1))**2+(X(I2+1)-X(I2+M))**2 W4 = X(I2)**2 / W1 W5 = X(I2+M+1)**2 / W1 IF ( .NOT. GONLY ) THEN F = F + SQRT( ONE + W1*W3/TWO ) IF ( F1 .EQ. 1 ) THEN IF ( (I .GE. 1 .AND. I .LE. M-1) .OR. - (MOD(I,M-1) .EQ. 1) ) THEN F = F - W4 ELSE IF ( (I .GE. I1-M+1 .AND. I .LE. I1) .OR. - (MOD(I,M-1) .EQ. 0) ) THEN F = F + W5 ELSE F = F - W4 + W5 ENDIF ENDIF ENDIF IF ( .NOT. FONLY ) THEN K= I2+M+1 R= TWO*SQRT(ONE+W1*W3/TWO) G(I2) = G(I2) + W1*(X(I2)-X(K)) /R G(K) = G(K) - W1*(X(I2)-X(K)) /R G(K-1) = G(K-1) - W1*(X(I2+1)-X(K-1))/R G(I2+1) = G(I2+1) + W1*(X(I2+1)-X(K-1))/R IF ( F1 .EQ. 1 ) THEN IF ( (I .GE. 1 .AND. I .LE. M-1) .OR. - (MOD(I,M-1) .EQ. 1) ) THEN G(I2)= G(I2) - TWO*X(I2)/W1 ELSE IF ( (I .GE. I1-M+1 .AND. I .LE. I1) .OR. - (MOD(I,M-1) .EQ. 0) ) THEN G(K) = G(K) + TWO*X(K )/W1 ELSE G(I2)= G(I2) - TWO*X(I2)/W1 G(K) = G(K) + TWO*X(K )/W1 ENDIF ENDIF ENDIF 7770 CONTINUE IF ( .NOT. FONLY ) THEN DO 7790 I=1,M G(I) = ZERO G((I-1)*M+1) = ZERO G(I+M*(M-1)) = ZERO G(I*M) = ZERO 7790 CONTINUE ENDIF GOTO 90000 C---- HYPCIR 7800 CONTINUE W1 = X(1)*X(2) - ONE W2 = X(1)**2 + X(2)**2 - FOUR IF ( .NOT. GONLY ) THEN F = W1**2 + W2**2 ENDIF IF ( .NOT. FONLY ) THEN G(1) = TWO*(W1*X(2) + TWO*W2*X(1)) G(2) = TWO*(W1*X(1) + TWO*W2*X(2)) ENDIF GOTO 90000 C---- SISSER 7900 CONTINUE IF ( .NOT. GONLY ) THEN F = THREE*X(1)**4 - TWO*X(1)**2*X(2)**2 + THREE*X(2)**4 ENDIF IF ( .NOT. FONLY ) THEN G(1) = R12*X(1)**3 - FOUR*X(1)*X(2)**2 G(2) = -FOUR*X(1)**2*X(2) + R12*X(2)**3 ENDIF GOTO 90000 C---- DIXON 7 DIAGONAL DIX7DG 8000 CONTINUE M = N/3 IF (3*M .NE. N) THEN RET = NOFG GOTO 90000 ENDIF IF ( .NOT. GONLY ) THEN F = ONE ENDIF W1 = FARG(1) W2 = FARG(2) W3 = FARG(3) W4 = FARG(4) K1 = NINT(FARG(5)) K2 = NINT(FARG(6)) K3 = NINT(FARG(7)) K4 = NINT(FARG(8)) DO 8090 I = 1,N I1 = I + M I2 = I1 + M X1 = W1*(RD(I)/RD(N))**K1 X2 = W2*(RD(I)/RD(N))**K2 X3 = W3*(RD(I)/RD(N))**K3 X4 = W4*(RD(I)/RD(N))**K4 IF ( .NOT. GONLY ) THEN F = F + HALF*X1*X(I)**2 IF ( I .NE. N ) THEN F = F + X2*X(I)**2 * (X(I+1)+X(I+1)**2)**2 ENDIF IF ( I1 .LE. N ) THEN F = F + X3*X(I)**2 * X(I1)**4 ENDIF IF ( I2 .LE. N ) THEN F = F + X4*X(I) * X(I2) ENDIF ENDIF IF ( .NOT. FONLY ) THEN G(I) = X1*X(I) IF ( I .NE. N ) THEN G(I) = G(I) + TWO*X2*X(I) * (X(I+1)+X(I+1)**2)**2 ENDIF IF ( I .NE. 1 ) THEN X2 = W2*(RD(I-1)/RD(N))**K2 G(I) = G(I) + TWO*X2*X(I-1)**2 * (X(I)+X(I)**2)* - (ONE+TWO*X(I)) ENDIF IF ( I .LE. 2*M ) THEN G(I) = G(I) + TWO*X3*X(I) * X(I1)**4 ENDIF IF ( I .GT. M ) THEN X3 = W3*(RD(I-M)/RD(N))**K3 G(I) = G(I) + FOUR*X3*X(I-M)**2 * X(I)**3 ENDIF IF ( I .LE. M ) THEN G(I) = G(I) + X4*X(I2) ENDIF IF ( I .GT. 2*M ) THEN X4 = W4*(RD(I-2*M)/RD(N))**K4 G(I) = G(I) + X4*X(I-2*M) ENDIF ENDIF 8090 CONTINUE GOTO 90000 C---- MORCIN MORCIN, MORE COSNARD INTEGRAL PROBLEM 8100 CONTINUE IF ( SIZE .LT. N ) THEN RET = NOFG GOTO 90000 ENDIF H = ONE/RD(N+1) IF ( .NOT. GONLY ) THEN F = ZERO ENDIF W1 = ZERO DO 8120 K = 1,N TK = RD(K)*H W1 = W1 + (ONE-TK)*(X(K)+TK+ONE)**3 8120 CONTINUE W3 = ZERO W5 = ZERO W6 = ZERO DO 8140 K = 1,N TK = RD(K)*H W2 = X(K) + TK + ONE W3 = W3 + TK*W2**3 W6 = W6 + (ONE-TK)*W2**3 W4 = X(K) + H*( (ONE-TK)*W3 + TK*(W1-W6) ) /TWO W5 = W5 + W4*(ONE-TK) WORK(K) = W4 IF ( .NOT. GONLY ) THEN F = F + W4**2 ENDIF IF ( .NOT. FONLY ) THEN G(K) = TWO*W4 ENDIF 8140 CONTINUE IF ( .NOT. FONLY ) THEN W1 = ZERO W2 = ZERO DO 8160 K = 1,N TK = RD(K)*H G(K) = G(K) + - H*THREE*(X(K)+TK+ONE)**2*(TK*(W5-W2) + (ONE-TK)*W1) W1 = W1 + WORK(K)*TK W2 = W2 + WORK(K)*(ONE-TK) 8160 CONTINUE ENDIF GOTO 90000 C---- BOOTH'S QUADRATIC 8200 CONTINUE W1 = X(1) + TWO*X(2) - SEVEN W2 = TWO*X(1) + X(2) - FIVE IF ( .NOT. GONLY ) THEN F = W1**2 + W2**2 ENDIF IF ( .NOT. GONLY ) THEN G(1) = TWO*W1 + FOUR*W2 G(2) = FOUR*W1 + TWO*W2 ENDIF GOTO 90000 C---- FROM POWELL 8300 CONTINUE W1 = X(1) + TENTH W2 = (TEN * X(1) / W1) + TWO * X(2)**2 IF ( .NOT. GONLY ) THEN F = X(1)**2 + W2**2 ENDIF IF ( .NOT. FONLY ) THEN G(1) = TWO * X(1) + TWO*W2 / W1**2 G(2) = EIGHT * X(2) * W2 ENDIF GOTO 90000 C## E X I T 90000 STATUS(7) = RET 91000 GFIRST = .FALSE. RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZFNS4. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> getgsg.f SUBROUTINE ZZGETG ( UNIT, NUM, NAM, SIZE, MEMBS, - NAMES, GROUPS, ERRFLG, * ) C## A R G U M E N T S: INTEGER UNIT, NUM, SIZE, ERRFLG INTEGER MEMBS( * ), GROUPS( * ) CHARACTER * ( * ) NAM, NAMES C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: GETG.F,V 1.10 91/11/20 10:52:55 BUCKLEY EXP $ C>RCS $LOG: GETG.F,V $ C>RCS REVISION 1.10 91/11/20 10:52:55 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.9 89/06/30 13:38:16 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 16:42:49 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 12:20:38 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:47:52 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:50:10 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS SUBROUTINE READS GROUP INFORMATION FROM THE C GIVEN FILE USING THE ARRAYS 'NAMES' AND 'GROUPS'. C C PARAMETER DESCRIPTION: C C ON ENTRY: C UNIT - INPUT UNIT NUMBER OF DAUF C NUM - GROUP NUMBER C NAM - GROUP NAME C C ON EXIT: C SIZE - THE SIZE OF THE GROUP C MEMBS - THE MEMBERS OF THE GROUP C NAMES - AN STRING OF CHARACTERS THAT CONTAINS THE C LIST OF GROUP NAMES C GROUPS - AN ARRAY CONTAINING THE POSITION OF THE C GROUP INFORMATION IN THE DAUF FILE C ERRFLG - AN ERROR RETURN. IT IS SET TO C 0 IF NO ERROR OCCURRED C 1 IF THE GROUP NUMBER IS OUT OF RANGE C 2 IF THE GROUP IS UNDEFINED C C## E N T R Y P O I N T S: C C ZZGETG - THE NATURAL ENTRY POINT C ZZDEFG - DEFINES THE SIZE OF RECORDS IN THE DAUF FILE C AND SOME OTHER CONSTANTS C C## S U B R O U T I N E S: C C RD ... STATEMENT FUNCTION TO CONVERT REALS TO INTEGERS C DBLE(REAL)... INTRINSIC C ZZRDIN ... READS INTEGERS FROM DAUF FILE C ZZSRCH ... SEARCHES A DICTIONARY C ZZERRM ... OUTPUTS ERROR MESSAGES C C## P A R A M E T E R S: LOGICAL T, F PARAMETER ( T = .TRUE., F = .FALSE. ) CHARACTER*(*) TRUE, QT, FALSE, QF PARAMETER ( TRUE = 'TRUE', QT = 'T', FALSE = 'FALSE', QF = 'F' ) INTEGER ITRUE, IFALSE PARAMETER ( ITRUE = 1, IFALSE = 0 ) REAL RTRUE, RFALSE C!!!! DOUBLE PRECISION RTRUE, RFALSE PARAMETER ( RTRUE = 1.D0, RFALSE = 0.D0 ) CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) CHARACTER*(*) PERIOD, COMMA, SEMICN PARAMETER ( PERIOD = '.', COMMA = ',', SEMICN = ';' ) CHARACTER*(*) COLON, DASH, EQUALS PARAMETER ( COLON = ':', DASH = '-', EQUALS = '=' ) CHARACTER*(*) OBRACE, CBRACE, UNDERS PARAMETER ( OBRACE = '{', CBRACE = '}', UNDERS = '_' ) CHARACTER*(*) PLUS, MINUS, EXCLAM PARAMETER ( PLUS = '+', MINUS = '-', EXCLAM = '!' ) CHARACTER*(*) GTHAN, LTHAN, QUESMK PARAMETER ( GTHAN = '>', LTHAN = '<', QUESMK = '?' ) CHARACTER*(*) SLASH, BSLASH, PERCNT PARAMETER ( SLASH = '/', BSLASH = '\\',PERCNT = '%' ) CHARACTER*(*) CARAT, ATSIGN, TILDE PARAMETER ( CARAT = '^', ATSIGN = '@', TILDE = '~' ) C## L O C A L D E C L: C---- STATEMENT FUNCTION REAL RD C!!!! DOUBLE PRECISION RD C---- NUMBER OF ELEMENTS PER LINE OF UNIT INTEGER IPERLN, SIPRLN C---- GROUP NAME LENGTH INTEGER PNAMLN, FNAMLN, GNAMLN PARAMETER ( PNAMLN = 8, FNAMLN = PNAMLN, GNAMLN = PNAMLN ) INTEGER TITLEN, PDESCL PARAMETER ( TITLEN = 72, PDESCL = 72 ) C---- MAXIMUM NUMBER OF GROUPS INTEGER NOFNS, DFPRBS, MXGRPS, MXGSZ PARAMETER ( NOFNS = 80, DFPRBS = 450, MXGRPS = 50, MXGSZ = 200 ) C---- MISCELLANEOUS VARIABLES INTEGER RECNO, I C## S A V E: SAVE IPERLN C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NONE ARE SET. C## E X E C U T I O N C## E X E C U T I O N C---- DEFINE STATEMENT FUNCTION RD(I) = REAL(I) C!!!! RD(I) = DBLE(I) C---- SET THE DEFAULT SIZE AND SEARCH START LOCATION. SIZE = 0 ERRFLG = 0 C---- CHECK NAME AND NUMBER IF ( NUM .LT. 1 .OR. NUM .GT. MXGRPS ) THEN C FIND GROUP NAME NUM = 0 IF ( NAM .NE. BLANK ) THEN CALL ZZSRCH( NAM, GNAMLN, NAMES, MXGRPS,GNAMLN,NUM,F,T) IF ( NUM .EQ. 0 ) THEN ERRFLG = 2 CALL ZZERRM ( RD(NUM), *91000, 'NS NO GROUP NAMED' - //NAM(1:GNAMLN) ) GOTO 90000 ENDIF ELSE ERRFLG = 1 CALL ZZERRM (RD(NUM),*91000,'NS GROUP NUMBER OUT OF RANGE') GOTO 90000 ENDIF ELSE IF ( GROUPS(NUM) .EQ. -1 ) THEN ERRFLG = 2 CALL ZZERRM( RD(NUM), *91000, 'IS NO GROUP #' ) GOTO 90000 ENDIF C---- GET THE STARTING RECORD NUMBER. RECNO = GROUPS( NUM ) C---- READ THE SIZE. CALL ZZRDIN( UNIT, SIZE, 1, IPERLN, RECNO ) C---- READ MEMBS ARRAYS. CALL ZZRDIN( UNIT, MEMBS(1), SIZE, IPERLN, RECNO ) GOTO 90000 C## E N T R Y ZZFPAR: ENTRY ZZDEFG ( SIPRLN ) IPERLN = SIPRLN RETURN C## E X I T 90000 RETURN 91000 RETURN1 C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZGETG. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> getpsg.f SUBROUTINE ZZGETP ( UNIT, PNUM, FNUM, PNAME, FNAME, DESC, - SOLNS, INTS, ORDER, LOOPX, LOOPC, X0, - NAMES, PRECNO, ERRFLG, * ) C## A R G U M E N T S: INTEGER UNIT, PNUM, FNUM, ERRFLG INTEGER INTS( * ), PRECNO( 3,* ), ORDER( * ), LOOPX( * ) REAL LOOPC( * ), X0( * ), SOLNS(*) C!!!! DOUBLE PRECISION LOOPC( * ), X0( * ), SOLNS(*) CHARACTER * ( * ) PNAME, FNAME, DESC, NAMES C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: GETP.F,V 1.10 91/11/20 10:52:56 BUCKLEY EXP $ C>RCS $LOG: GETP.F,V $ C>RCS REVISION 1.10 91/11/20 10:52:56 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.9 89/06/30 13:38:17 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 16:42:50 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 12:20:39 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:47:57 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:50:10 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS SUBROUTINE READS INFORMATION CONCERNING PROBLEM PNUM FROM C THE GIVEN FILE AND FROM THE ARRAYS 'NAMES' AND 'PRECNO'. C C PARAMETER DESCRIPTION: C C ON ENTRY: C UNIT - INPUT UNIT NUMBER FOR DAUF C PNUM - PROBLEM NUMBER--SET ON INPUT TO SELECT PROBLEM C NAMES - AN ARRAY OF CHARACTERS THAT CONTAINS THE PROBLEM NAME C AND THE FUNCTION NAME FOR EACH PROBLEM C PRECNO - AN INTEGER ARRAY THAT CONTAINS MINIMUM DIMENSION, C THE FUNCTION NUMBER, AND THE RECORD NUMBER C ( OF THE DAUF FILE ) FOR EACH PROBLEM C C ON EXIT: C FNUM - FUNCTION NUMBER C PNAME - PROBLEM NAME C FNAME - FUNCTION NAME C DESC - STRING TO BE FILLED WITH THE PROBLEM DESCRIPTION C INTS - ARRAY TO BE FILLED WITH THE INTEGERS RELATED TO C THE PROBLEM C ORDER, LOOPX, LOOPC - ARRAYS TO BE FILLED WITH THE INNER C LOOP DATA C X0 - AN ARRAY TO BE FILLED WITH THE STARTING POINT C C ERRFLG - AN ERROR RETURN. IT IS SET TO C 0 IF NO ERRORS OCCURRED C 1 IF THE PROBLEM NUMBER IS OUT OF RANGE C 2 IF NO SUCH PROBLEM NUMBER IS CURRENTLY C DEFINED. C C## E N T R Y P O I N T S: C C ZZGETP - THE NATURAL ENTRY POINT C ZZGDEF - DEFINES THE SIZE OF RECORDS IN THE DAUF FILE C AND SOME OTHER CONSTANTS C C## S U B R O U T I N E S: C C DBLE(REAL) ... INTRINSIC C RDCH ... TO READ CHARACTERS FROM DIRECT ACCESS UNF. FILE C RDIN ... TO READ INTEGERS FROM DIRECT ACCESS UNF. FILE C RDRL ... TO READ REALS FROM DIRECT ACCESS UNF. FILE C ZZERRM ... OUTPUTS ERROR MESSAGES C RD ... STATEMENT FUNCTION TO CONVERT INTEGERS TO REALS C C## P A R A M E T E R S: INTEGER CTOUPP, CTOLOW, CTOCAP PARAMETER ( CTOUPP = 1, CTOLOW = 2, CTOCAP = 3 ) CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) CHARACTER*(*) PERIOD, COMMA, SEMICN PARAMETER ( PERIOD = '.', COMMA = ',', SEMICN = ';' ) CHARACTER*(*) COLON, DASH, EQUALS PARAMETER ( COLON = ':', DASH = '-', EQUALS = '=' ) CHARACTER*(*) OBRACE, CBRACE, UNDERS PARAMETER ( OBRACE = '{', CBRACE = '}', UNDERS = '_' ) CHARACTER*(*) PLUS, MINUS, EXCLAM PARAMETER ( PLUS = '+', MINUS = '-', EXCLAM = '!' ) CHARACTER*(*) GTHAN, LTHAN, QUESMK PARAMETER ( GTHAN = '>', LTHAN = '<', QUESMK = '?' ) CHARACTER*(*) SLASH, BSLASH, PERCNT PARAMETER ( SLASH = '/', BSLASH = '\\',PERCNT = '%' ) CHARACTER*(*) CARAT, ATSIGN, TILDE PARAMETER ( CARAT = '^', ATSIGN = '@', TILDE = '~' ) LOGICAL T, F PARAMETER ( T = .TRUE., F = .FALSE. ) CHARACTER*(*) TRUE, QT, FALSE, QF PARAMETER ( TRUE = 'TRUE', QT = 'T', FALSE = 'FALSE', QF = 'F' ) INTEGER ITRUE, IFALSE PARAMETER ( ITRUE = 1, IFALSE = 0 ) REAL RTRUE, RFALSE C!!!! DOUBLE PRECISION RTRUE, RFALSE PARAMETER ( RTRUE = 1.D0, RFALSE = 0.D0 ) C---- POSITION FLAGS FOR ENTRIES IN PRECNO ARRAY C DEFINITIONS OF THE ROWS IN THE ARRAY PRECNO. ( PRECNO HOLDS THE C RECORD NUMBER IN THE DAUF FILE, THE MINIMUM DIMENSION, AND THE C FUNCTION NUMBER OF EACH PROBLEM. ) INTEGER RECN, DIMN, FNO1 PARAMETER ( RECN = 1, DIMN = 2, FNO1 = 3 ) C---- POSITION FLAGS FOR ENTRIES IN INTS ARRAY INTEGER PPTMAX, PPTIX0, PPTDES PARAMETER ( PPTMAX = 1, PPTIX0 = 2, PPTDES = 3 ) INTEGER PPTORD, PPTLPX, PPTLPC, PPTSOL PARAMETER ( PPTORD = 4, PPTLPX = 5, PPTLPC = 6, PPTSOL = 7 ) INTEGER NPNTS PARAMETER ( NPNTS = 7 ) C## L O C A L D E C L: C---- STATEMENT FUNCTION REAL RD C!!!! DOUBLE PRECISION RD C---- DECLARE THE NUMBER OF ELEMENTS PER LINE OF UNIT INTEGER CPERLN, IPERLN, RPERLN INTEGER SCPRLN, SIPRLN, SRPRLN C---- PROBLEM AND FUNCTION NAME LENGTHS INTEGER PNAMLN, FNAMLN, GNAMLN PARAMETER ( PNAMLN = 8, FNAMLN = PNAMLN, GNAMLN = PNAMLN ) INTEGER TITLEN, PDESCL PARAMETER ( TITLEN = 72, PDESCL = 72 ) C---- MAXIMUM NUMBER OF PROBLEMS INTEGER NOFNS, DFPRBS, MXGRPS, MXGSZ PARAMETER ( NOFNS = 80, DFPRBS = 450, MXGRPS = 50, MXGSZ = 200 ) C---- MISC VARIABLES INTEGER I, J, K, RECNO C## S A V E: SAVE CPERLN, IPERLN, RPERLN C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NONE ARE SET. C## E X E C U T I O N C## E X E C U T I O N C---- DEFINE STATEMENT FUNCTION RD(I) = REAL(I) C!!!! RD(I) = DBLE(I) C---- CHECK PROBLEM NUMBER ERRFLG = 0 IF ( PNUM .LE. 0 .AND. PNAME .EQ. BLANK ) THEN PNUM = 0 ELSE IF ( PNUM .LE. 0 ) THEN CALL ZZCASE(PNAME,CTOUPP) PNUM = 0 CALL ZZSRCH(PNAME,PNAMLN,NAMES,DFPRBS,PNAMLN+FNAMLN,PNUM,F,T) ENDIF IF ( PNUM .LT. 1 .OR. PNUM .GT. DFPRBS ) THEN ERRFLG = 1 CALL ZZERRM( RD(PNUM), *91000, 'IT ILLEGAL PROBLEM NUMBER, #' ) GOTO 90000 ENDIF C---- GET INFO FROM THE PRECNO ARRAY. FNUM = PRECNO( FNO1, PNUM ) RECNO = PRECNO( RECN, PNUM ) IF ( RECNO .EQ. -1 ) THEN ERRFLG = 2 CALL ZZERRM( RD(PNUM), *91000,'IT HAVE NOT DEFINED PROBLEM #' ) GOTO 90000 ENDIF C---- GET THE NAMES FROM THE NAME ARRAY. I = ( PNUM-1 ) * ( FNAMLN+PNAMLN ) + 1 J = I + PNAMLN - 1 K = J + FNAMLN PNAME = NAMES( I : J ) FNAME = NAMES( J+1 : K ) C---- READ INTS ARRAY. CALL ZZRDIN( UNIT, INTS, NPNTS, IPERLN, RECNO ) C---- READ DESCRIPTION CALL ZZRDCH( UNIT, DESC, INTS(PPTDES), CPERLN, RECNO ) C---- READ INTEGER ARRAYS CALL ZZRDIN( UNIT, ORDER, INTS(PPTORD), IPERLN, RECNO ) CALL ZZRDIN( UNIT, LOOPX, INTS(PPTLPX), IPERLN, RECNO ) C---- READ REAL ARRAY(S) CALL ZZRDRL( UNIT, LOOPC, INTS(PPTLPC), RPERLN, RECNO ) IF ( INTS(PPTIX0) .GT. 0 ) THEN CALL ZZRDRL( UNIT, X0, INTS(PPTIX0), RPERLN, RECNO ) ENDIF IF ( INTS(PPTSOL) .GT. 0 ) THEN CALL ZZRDRL( UNIT, SOLNS, INTS(PPTSOL), RPERLN, RECNO ) ENDIF GOTO 90000 C## E N T R Y ZZGDEF: ENTRY ZZGDEF ( SCPRLN, SIPRLN, SRPRLN ) CPERLN = SCPRLN IPERLN = SIPRLN RPERLN = SRPRLN RETURN C## E X I T 90000 RETURN 91000 RETURN1 C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZGETP. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> ladvsg.f SUBROUTINE ZZLADV ( LOOPC, LOOPX, N, OVER ) C## A R G U M E N T S: INTEGER LOOPX(*), N LOGICAL OVER REAL LOOPC(*) C!!!! DOUBLE PRECISION LOOPC(*) C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C>RCS $HEADER: LADV.F,V 1.10 91/11/20 10:52:57 BUCKLEY EXP $ C>RCS $LOG: LADV.F,V $ C>RCS REVISION 1.10 91/11/20 10:52:57 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.9 89/06/30 13:38:18 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 16:42:51 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 12:20:40 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:47:58 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:50:10 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE ADVANCES THE LOOPING CONTROL. C C C THE LOOP CONTROL IS STRUCTURED AS FOLLOWS: C C THE REAL ARRAY LOOPC CONTAINS THE LOOP INFORMATION FOR EITHER A LOOP C OR A LIST. THE ARRAY LOOPX FUNCTIONS LIKE AN AUTOMOBILE ODOMETER C WHERE EACH "POSITION" OF THE ODOMETER MAY BE A LIST OR A LOOP. IT C SPECIFIES WHERE THE INFORMATION FOR EACH "POSITION" MAY BE FOUND, C I.E. IT IS AN INDEX INTO LOOPC. THE TOTAL NUMBER OF "POSITIONS" C OF THE ODOMETER IS N. C C CONSIDER FOR EXAMPLE N = 2 WITH C C LOOPX = (6,1) C LOOPC = (0.0,3.0,1.0,7.0,2.0,4.0,2.0,6.1,7.3,2.6,1.8) C C THE "RIGHTMOST" COLUMN TO THE ODOMETER (I.E. THE ONE THAT C INCREMENTS MOST RAPIDLY) IS IN LOOPX(2), WHICH POINTS TO C LOOPC(1). SINCE LOOPC(1) IS ZERO, THIS DEFINES A LOOP. THE C LAST LOOP VALUE PROCESSED WAS 3.0 AND THE LOOP IS DEFINED C FROM 1.0 TO 7.0 IN ADDITIVE STEPS OF 2.0. C C IF LOOPC(1) WERE -1, IT WOULD ALSO DEFINE A LOOP, BUT C IT WOULD BE MULTIPLICATIVE, AND HENCE IT WOULD DEFINE A C GEOMETRIC PROGRESSION, RATHER THAN AN ARITHMETIC ONE. C NOTE THAT THE MULTIPLYING FACTOR CAN BE GREATER OR LESS THAN C ONE IN MAGNITUDE. IT CAN ALSO BE NEGATIVE, BUT THE TEST FOR C TERMINATION IS BASED SOLELY ON ABSOLUTE VALUES OF THE GIVEN C QUANTITIES. C C WHEN LOOPC(1) IS -2, IT DEFINES THE SAME TYPE OF PROGRESSION C AS WHEN IT IS 0, EXCEPT THAT IT IS ASSUMED THAT THE SEQUENCE IS C INTENDED TO CONTAIN ONLY INTEGRAL VALUES AND HENCE ALL VALUES C GENERATED AND USED IN COMPARISONS FOR TERMINATION ARE FORCED TO C BE INTEGRAL. THE SAME APPLIES WHEN IT IS -3, EXCEPT THAT IT IS C COMPARABLE TO THE -1 CASE. NOTE THAT IT IS THE RESPONSIBILITY OF C THE USER TO ENSURE THAT ROUNDING TO INTEGRAL VALUES IS SENSIBLE. C C THE NEXT COLUMN OF THE ODOMETER TO ADVANCE IS LOOPX(1), WHICH C POINTS AT LOOPC(6). SINCE THE VALUE THERE IS 4.0, THIS EXPLICITLY C DEFINES A LIST OF 4 ELEMENTS. THE LAST ONE PROCESSED WAS THE 2ND C I.E. 7.3. THE ELEMENTS IN THE LIST ARE 6.1, 7.3, 2.6 AND 1.8. C C WHEN ONE POSITION OF THE ODOMETER GOES PAST ITS LAST VALUE, IT IS C RESET TO ITS FIRST VALUE AND THE POSITION TO ITS IMMEDIATE LEFT IS C ADVANCED. C C THE FLAG 'OVER' IS SET TO TRUE IF THE ODOMETER 'TURNS OVER', C I.E. IF ALL COLUMNS HAVE REACHED THEIR MAXIMUM VALUE AND ADVANCING C IT CAUSES THEM ALL TO BE RESET TO THEIR INITIAL VALUES. IF NOT, THEN C OVER IS SET FALSE. C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZLADV C## S U B R O U T I N E S: NINT, ABS, DBLE(REAL) ... INTRINSICS C RD ... INTEGER TO REAL (DBLE). C C## P A R A M E T E R S: REAL ZERO, ONE, TWO, THREE C!!!! DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) REAL FOUR, FIVE, SIX, SEVEN C!!!! DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) REAL EIGHT, NINE, TEN C!!!! DOUBLE PRECISION EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 9D0, TEN = 10D0 ) C## L O C A L D E C L: INTEGER I, J, COUNT, K, I3, I4, IC REAL CURR, RD, FACTOR C!!!! DOUBLE PRECISION CURR, RD, FACTOR C## S A V E: NONE SELECTED. C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NONE ARE SET. C## E X E C U T I O N C## E X E C U T I O N C------ DEFINE A FUNCTION STATEMENT. RD(I) = REAL(I) C!!!! RD(I) = DBLE(I) OVER = .FALSE. DO 2000 I = N, 1, -1 J = LOOPX(I) COUNT = NINT( LOOPC(J) ) IF ( COUNT .EQ. 0 ) THEN C REAL ARITHMETIC PROGRESSION CURR = LOOPC(J+1) + LOOPC(J+4) IF (( LOOPC(J+4) .GT. ZERO .AND. CURR .LE. LOOPC(J+3)) .OR. - ( LOOPC(J+4) .LE. ZERO .AND. CURR .GE. LOOPC(J+3) )) THEN LOOPC(J+1) = CURR GOTO 90000 ELSE LOOPC(J+1) = LOOPC(J+2) ENDIF ELSE IF ( COUNT .EQ. -1 ) THEN C REAL GEOMETRIC PROGRESSION CURR = LOOPC(J+1) * LOOPC(J+4) IF ( ( ABS(LOOPC(J+4)) .GT. ONE - .AND. ABS(CURR) .LE. ABS(LOOPC(J+3)) ) - .OR. - ( ABS(LOOPC(J+4)) .LE. ONE - .AND. ABS(CURR) .GE. ABS(LOOPC(J+3)) ) ) THEN LOOPC(J+1) = CURR GOTO 90000 ELSE LOOPC(J+1) = LOOPC(J+2) ENDIF ELSE IF ( COUNT .EQ. -2 ) THEN C INTEGRAL ARITHMETIC PROGRESSION IC = NINT(LOOPC(J+1)) + NINT(LOOPC(J+4)) I4 = NINT(LOOPC(J+4)) I3 = NINT(LOOPC(J+3)) IF ( ( I4 .GT. 0 .AND. IC .LE. I3 ) .OR. - ( I4 .LE. 0 .AND. IC .GE. I3 ) ) THEN LOOPC(J+1) = RD(IC) GOTO 90000 ELSE LOOPC(J+1) = LOOPC(J+2) ENDIF ELSE IF ( COUNT .EQ. -3 ) THEN C INTEGRAL GEOMETRIC PROGRESSION FACTOR = LOOPC(J+4) I4 = NINT(FACTOR) IF ( FACTOR .GT. ONE ) THEN IC = NINT(LOOPC(J+1)) * I4 ELSE IC = NINT(LOOPC(J+1)) / NINT(ONE/LOOPC(J+4)) ENDIF I3 = NINT(LOOPC(J+3)) IF (( ABS(FACTOR) .GT. 1 .AND. ABS(IC) .LE. ABS(I3) ) .OR. - ( ABS(FACTOR) .LE. 1 .AND. ABS(IC) .GE. ABS(I3) )) THEN LOOPC(J+1) = RD(IC) GOTO 90000 ELSE LOOPC(J+1) = LOOPC(J+2) ENDIF ELSE C LIST SPECIFICATION K = NINT( LOOPC(J+1) ) IF ( K .LT. COUNT ) THEN LOOPC(J+1) = K+1 GOTO 90000 ELSE LOOPC(J+1) = 1 ENDIF ENDIF C NOTE THAT THE LOOP WILL BE REPEATED WHENEVER ONE POSITION C "TURNS OVER", AND HENCE TRIGGERS THE NEXT POSITION. IF C IT DID NOT TURN OVER, THE LOOP WILL HAVE BEEN EXITED. 2000 CONTINUE C IF ALL POSITIONS "TURNED OVER" SO THAT THE ODOMETER IS BACK C TO ITS ORIGINAL POSITION, SET THE FLAG OVER. OVER = .TRUE. C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZLADV. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> lmodsg.f SUBROUTINE ZZLMOD (LOOPC, MXSIZE, LOOPX, ORDER, N, NEW, NEWX,LC,*) C## A R G U M E N T S: INTEGER MXSIZE, N INTEGER LOOPX(N+1), ORDER(N), NEWX, LC REAL LOOPC(MXSIZE), NEW(*) C!!!! DOUBLE PRECISION LOOPC(MXSIZE), NEW(*) C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: LMOD.F,V 2.1 91/11/20 10:52:59 BUCKLEY EXP $ C>RCS $LOG: LMOD.F,V $ C>RCS REVISION 2.1 91/11/20 10:52:59 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 2.0 90/07/31 11:31:58 BUCKLEY C>RCS MINOR CHANGES TO ARGUMENT DECLARATIONS. C>RCS C>RCS REVISION 1.9.1.1 89/06/30 17:13:33 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.9 89/06/30 13:38:19 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 16:42:52 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 12:20:42 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:48:01 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:50:11 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE MODIFIES THE ODOMETER FOR REVISED DATA. C C C THE ARRAYS LOOPC AND LOOPX ARE DEFINED IN THE ROUTINE ZZLADV. C MXSIZE IS THE DEFINED SIZE OF LOOPC. IT IS ASSUMED THAT LOOPX(N+1) C POINTS AT THE FIRST FREE LOCATION IN LOOPC. THE NUMBER OF POSITIONS C CURRENTLY IN THE ODOMETER IS N. THE DEFINITION OF ORDER IS DESCRIBED C IN ZZLPCK. C C THE ARRAY NEW HAS THE SAME FORMAT AS LOOPC. THE INFORMATION C IN NEW IS INSERTED INTO LOOPC. NOTE THAT THE NUMBER OF POSITIONS IN C THE ODOMETER DOES NOT CHANGE. AN ELEMENT WHICH DOES NOT LOOP, I.E. C FOR WHICH THERE IS NO SET OF VALUES DEFINED, IS SIMPLY ENTERED AS C A LIST WITH ONE ELEMENT. C C NEWX FUNCTIONS LIKE THE POINTER PT IN ZZLPCK. IT SPECIFIES C THE POSITION IN THE ODOMETER WHERE THE NEW INFORMATION IS TO BE C PLACED. C C IF THERE IS INSUFFICIENT ROOM TO MAKE THE UPDATE, THEN NO C CHANGE IS MADE TO THE ODOMETER AND THE ALTERNATE RETURN IS TAKEN C TO THE CALLING ROUTINE. C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZLMOD C## S U B R O U T I N E S: NINT ... INTRINSIC C## P A R A M E T E R S: REAL ZERO, ONE, TWO, THREE C!!!! DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) REAL FOUR, FIVE, SIX, SEVEN C!!!! DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) REAL EIGHT, NINE, TEN C!!!! DOUBLE PRECISION EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 9D0, TEN = 10D0 ) INTEGER LLIST, LARITH, LGEOMT PARAMETER ( LLIST = 1, LARITH = 2, LGEOMT = 3 ) DOUBLE PRECISION DEFADD, DEFMUL PARAMETER ( DEFADD = 1.0D0, DEFMUL = 10.0D0 ) C ANY FORM OF LOOP REQUIRES 5 ENTRIES IN LOOPC, WHEREAS A LIST C REQUIRES 2, PLUS THE NUMBER OF LIST ELEMENTS, ENTRIES. INTEGER LOOPSP, LISTSP PARAMETER ( LOOPSP = 5, LISTSP = 2 ) LOGICAL T, F PARAMETER ( T = .TRUE., F = .FALSE. ) CHARACTER*(*) TRUE, QT, FALSE, QF PARAMETER ( TRUE = 'TRUE', QT = 'T', FALSE = 'FALSE', QF = 'F' ) INTEGER ITRUE, IFALSE PARAMETER ( ITRUE = 1, IFALSE = 0 ) REAL RTRUE, RFALSE C!!!! DOUBLE PRECISION RTRUE, RFALSE PARAMETER ( RTRUE = 1.D0, RFALSE = 0.D0 ) C## L O C A L D E C L: INTEGER I, J, SPACE, K, FREE, NEWSZ C## S A V E: NONE SELECTED. C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NONE ARE SET. C## E X E C U T I O N C## E X E C U T I O N K = ORDER (NEWX) J = LOOPX ( K ) C DETERMINE THE SPACE TO BE FREED BY REMOVING CURRENT DATA. SPACE = NINT ( LOOPC(J) ) IF ( SPACE .LE. 0 ) THEN SPACE = LOOPSP ELSE SPACE = SPACE + LISTSP ENDIF C DETERMINE THE SPACE REQUIRED FOR THE NEW DATA. NEWSZ = NINT( NEW(1) ) IF ( NEWSZ .LE. 0 ) THEN NEWSZ = LOOPSP ELSE NEWSZ = NEWSZ + LISTSP ENDIF C DETERMINE THE TOTAL SPACE REQUIRED AFTER UPDATING. FREE = LOOPX(N+1) + NEWSZ - SPACE IF ( FREE .GT. MXSIZE + 1 ) THEN GOTO 91000 ELSE C CHECK IF MISSING THIRD LOOP CONTROL ARGUMENT. FILL IN DEFAULT. C 1 FOR ADDITIVE, 10 FOR MULTIPLICATIVE IF ( LC .NE. LLIST ) THEN IF ( LC .EQ. LARITH .AND. NEW(LOOPSP) .EQ. ZERO ) THEN NEW(LOOPSP) = DEFADD ELSE IF ( LC .EQ. LGEOMT .AND. NEW(LOOPSP) .EQ. ZERO ) THEN NEW(LOOPSP) = DEFMUL ENDIF ENDIF C MOVE THE ELEMENTS IN LOOPC LEFT OVER BLOCK BEING REMOVED. DO 300 I = J, LOOPX(N+1) - SPACE - 1 LOOPC(I) = LOOPC(I + SPACE) 300 CONTINUE C MOVE THE POINTERS IN LOOPX. ONLY MOVE THOSE WHICH CHANGE. DO 700 I = 1, K-1 IF (LOOPX(I) .GT. J) THEN LOOPX(I) = LOOPX(I) - SPACE ENDIF 700 CONTINUE C NOTE: WE REMOVE THE K-TH POINTER. DO 1000 I = K+1, N IF (LOOPX(I) .GT. J) THEN LOOPX(I-1) = LOOPX(I) -SPACE ELSE LOOPX(I-1) = LOOPX(I) ENDIF 1000 CONTINUE C REDEFINE THE N-TH LOCATION LOOPX(N) = FREE - NEWSZ C REDEFINE FIRST FREE LOCATION. LOOPX(N+1) = FREE C NOW USE FREE AS A TEMPORARY POINTER. FREE = LOOPX(N) C AND FILL IN THE NEW ENTRIES IN LOOPC. DO 2000 I = 1, NEWSZ LOOPC(FREE+I-1) = NEW(I) 2000 CONTINUE C REVISE THE PERMUTATION VECTOR IN ORDER TO ACCOUNT FOR MOVEMENT C IN THE INDEX ARRAY LOOPX. DO 3000 I = 1,N IF ( ORDER(I) .GT. K ) THEN ORDER(I) = ORDER(I) - 1 ENDIF 3000 CONTINUE C THE NEW ELEMENT ALWAYS ENTERS AT THE RIGHTMOST POSITION OF THE C ODOMETER. ORDER(NEWX) = N ENDIF GOTO 90000 C## E X I T 90000 RETURN 91000 RETURN 1 C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZLMOD. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> lnksg.f SUBROUTINE ZZLINK ( N, X, F, G, ACC, RELF, RELG, STATUS, SUBR, - TRACUN, TRACES, NTR, PRINTL, MAX, DERVMD, USER, - NU, RWORK, LR, IWORK, LI, IW, RW, DW ) C## A R G U M E N T S: INTEGER N, LR, LI, NU, SUBR, STATUS INTEGER TRACUN, NTR, MAX , PRINTL, DERVMD INTEGER IWORK(LI), IW(*) LOGICAL TRACES(NTR), RELF, RELG REAL F, ACC, X(N), G(N), RWORK(LR), USER(NU) C!!!! DOUBLE PRECISION F, ACC, X(N), G(N), RWORK(LR), USER(NU) REAL RW(*) DOUBLE PRECISION DW(*) C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: LNK.F,V 1.11 91/11/20 10:53:00 BUCKLEY EXP $ C>RCS $LOG: LNK.F,V $ C>RCS REVISION 1.11 91/11/20 10:53:00 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.10 90/08/06 16:25:31 BUCKLEY C>RCS MODIFIED WITH FIX TO BBLNIR TO CHECK ALL ARGUMENTS. C>RCS C>RCS REVISION 1.9 89/06/30 13:39:45 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 16:42:53 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 12:20:45 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:48:04 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:50:11 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE ACTS AS A LINKAGE BETWEEN THE MAIN DRIVER ROUTINE C ZZTP AND THE MINIMIZATION ROUTINE TO BE TESTED. C C THE ACTUAL CODE REQUIRED IS QUITE SIMPLE, BUT IT MUST BE PROVIDED C BY THE PERSON WHO HAS A ROUTINE TO BE TESTED. THE STANDARD C DECLARATIONS MARKED BELOW SHOULD NOT BE CHANGED, BUT OTHERS WHICH C ARE PARTICULAR TO THE ALGORITHM BEING TESTED MAY BE APPROPRIATE C AND MAY BE ADDED. C C THIS PARTICULAR SAMPLE IS SET UP TO TEST ONE OF TWO DIFFERENT C ALGORITHMS; THESE ARE DOCUMENTED BELOW. EITHER OF THESE ILLUS- C TRATES WHAT IS REQUIRED TO IMPLEMENT AN ALGORITHM FOR TESTING. C C ESSENTIALLY, THIS ROUTINE IS USED TO DO TWO THINGS: C C 1. IT DECLARES AND INITIALIZES ANY VALUES WHICH C WILL BE NEEDED BY THE TESTER'S ALGORITHM. C C 2. IT BREAKS UP THE WORKING STORAGE PROVIDED IN RWORK AND C IWORK, AND SETS UP THE APPROPRIATE CALL TO THE SUBROUTINE. C C IN ADDITION, THIS ROUTINE TAKES CARE OF A COUPLE OF MINOR TASKS. C IT MAY CHECK THAT SUFFICIENT STORAGE HAS BEEN PROVIDED. C THIS IS ILLUSTRATED IN THE SAMPLE PROVIDED BELOW. C C MOST ROUTINES WILL REQUIRE VERY LITTLE CODE HERE AND THE CODE C WILL BE SHORT AND SIMPLE. C C-----THE VARIABLES IN THE CALLING SEQUENCE HAVE THE FOLLOWING MEANINGS. C C N THE DIMENSION OF THE PROBLEM. C X NORMALLY, THE INITIAL GUESS AT THE SOLUTION (ON ENTRY) AND C THE SOLUTION FOUND (ON EXIT). ALSO SEE THE COMMENTS C BELOW ON REVERSE COMMUNICATION. C F THE FUNCTION VALUE AT THE SOLUTION (ON EXIT, ALSO SEE RC). C G THE GRADIENT VALUE AT THE SOLUTION (ON EXIT, ALSO SEE RC). C ACC THE DESIRED ACCURACY. C C STATUS IT IS NORMALLY 0 ON ENTRY AND IT CONTAINS AN ERROR CODE ON C EXIT. ALSO SEE THE NOTE BELOW ON REVERSE COMMUNICATION. C THE VALUES FOR STATUS REFER TO THE VALUES WHICH WILL BE C SET BY ZZTP AND PASSED INTO ZZLINK, AND TO THE VALUES C WHICH ZZTP EXPECTS TO BE RETURNED BY ZZLINK. IT MAY C BE NECESSARY TO USE ALTERED VALUES TO COMMUNICATE WITH C THE TEST ALGORITHM. SEE FOR EXAMPLE THE VALUE OF STATUS C RETURNED FROM BBLNIR. THE STATUS CODES ARE DEFINED BELOW. C C SUBR THE NUMBER IDENTIFYING THE SUBROUTINE TO BE USED. C C TRACES, NTR C THESE ARE FOR PROVIDING TRACES. NTR IS THE NUMBER OF TRACE C FLAGS CONTAINED IN THE ARRAY TRACES. SEE ZZTP FOR MORE C INFORMATION. C C PRINTL SEE ZZPRNT - SET BY "PRINT = _" C MAX SEE ZZEVAL - MAX NUMBER OF FUNCTION EVALUATIONS, SET C BY "MAX = _" IN PROBLEM DEFINITION. C DERVMD SEE ZZEVAL - SET BY "DERIVATIVE = _" C C USER(NU) SEE ZZTP AND THE DESCRIPTION OF THE USER NAME FEATURE. C THIS IS THE ARRAY OF GENERIC USER PARAMETERS. C C RWORK) A REAL (OR DOUBLE PRECISION) WORK ARRAY. LR IS C LR ) THE DIMENSION OF RWORK. THIS MEANS THAT LWORK ELEMENTS OF C EXTRA) RWORK MAY BE TAKEN FOR THE USER'S TEST ROUTINE. THE REAL C LENGTH OF RWORK IS LWORK + EXTRA, AND IT IS ASSUMED IN C ZZEVAL WHERE THE TEST FUNCTIONS ARE EVALUATED THAT THE C THE REMAINING EXTRA LOCATIONS CAN BE USED IF NECESSARY IN C EVALUATING THE FUNCTIONS. C C IWORK AN INTEGER WORK ARRAY. C LI THE DIMENSION OF IWORK. C C-----STATUS CODES. C C STATUS IS 'NORMAL' ON ENTRY UNLESS REVERSE COMMUNICATION C IS BEING USED. STATUS SHOULD BE 'NORMAL' ON RETURN UNLESS THERE C IS AN ERROR OR REVERSE COMMUNICATION IS USED. C C ON ENTRY, THE FOLLOWING VALUES ARE USED: C C NORMAL START NORMAL RUN C NORMFG JUST LIKE NORMAL, BUT F AND G COMPUTED AT X ALREADY. C RCSTRT START REVERSE COMMUNICATION C RCRPT REVERSE COMMUNICATION REENTRY C C ON RETURN TO ZZTP, THE FOLLOWING VALUES ARE EXPECTED BY ZZTP. C C NORMAL COMPLETION OF A TEST WITH NO ERRORS. C RCRPT REPEAT REVERSE COMMUNICATION C RCF,RCFG,RCG RESERVED FOR REVERSE COMMUNICATION. C XSFUNC TERMINATION OCCURRED BECAUSE TOO MANY FUNCTION C EVALUATIONS WERE DONE. C NOSTOR EXECUTION OF THE TEST NEVER BEGAN BECAUSE TOO LITTLE C STORAGE WAS AVAILABLE. C IPMIN TERMINATION OCCURRED BECAUSE THE INITIAL POINT WAS C FOUND TO BE A MINIMUM. C NOF0 THE FUNCTION OR GRADIENT WAS UNDEFINED AT X0. C RABORT AN ABORT WAS REQUESTED BY THE EVALUATION ROUTINE. C C-----REVERSE COMMUNICATION. C C THE MEANING AND USE OF THIS FEATURE IS DESCRIBED IN THE C EXTERNAL DOCUMENTATION. HERE WE JUST DESCRIBE ITS USE WITH RESPECT C TO THE VALUE OF STATUS. C C NORMALLY, STATUS IS SET TO 0 BEFORE CALLING ZZLINK. IF C FUNCTION VALUES ARE TO BE OBTAINED THROUGH REVERSE COMMUNICATION, C THEN STATUS SHOULD BE SET TO 1 BEFORE CALLING ZZLINK. IN THIS C CASE, BOTH THE FUNCTION VALUE F AND (IF REQUIRED) THE GRADIENT C VALUE G AT THE INITIAL POINT X MUST BE DEFINED ON ENTRY. THESE C VALUES CAN THEN BE PASSED BY ZZLINK TO THE TEST ALGORITHM. C C WHEN THE TEST ALGORITHM REQUIRES A FUNCTION AND/OR C GRADIENT VALUE, IT SHOULD RETURN TO ZZLINK. THE POINT AT WHICH C THE FUNCTION AND/OR GRADIENT VALUE IS TO BE EVALUATED MUST BE IN C X. AS ILLUSTRATED WITH BBLNIR, A RETURN TO ZZLINK SHOULD BE MADE C WITH X DEFINED AS JUST STATED. BEFORE RETURNING FROM ZZLINK TO C ZZTP, STATUS SHOULD BE SET AS FOLLOWS : C C STATUS = RCF IF ONLY F(X) IS REQUIRED. C = RCFG IF BOTH F(X) AND G(X) ARE REQUIRED. C = RCG IF ONLY G(X) IS REQUIRED. C C IT IS UP TO ZZTP TO DETERMINE F(X) AND G(X). ZZTP WILL THEN CALL C ZZLINK WITH STATUS = RCRPT. WHEN STATUS = RCRPT ON ENTRY TO C ZZLINK, CONTROL SHOULD BE PASSED DIRECTLY TO THE TEST ALGORITHM, C AS IS DONE FOR BBLNIR. NOTE THAT I1,I2,... ARE DECLARED AS SAVE C SO THAT THEIR VALUES ARE RETAINED. C C NOTE THAT WE HAVE MADE NO STATEMENTS ABOUT ARGUMENTS C PASSED TO OR FROM THE TEST ALGORITHM. HERE WE ARE ONLY CONCERNED C WITH THE VALUES PASSED BETWEEN ZZTP AND ZZLINK. C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZLINK C## S U B R O U T I N E S: C C THE ONLY CALLS ARE TO THE MINIMIZATION ROUTINES C C BBLNIR CONMIN C C (WHICH INCLUDES CALLS TO THE ENTRY BBLSET IN BBLNIR) C C NINT... INTRINSIC TO GET NEAREST INTEGER C C## P A R A M E T E R S: REAL ZERO, ONE, TWO, THREE C!!!! DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) REAL FOUR, FIVE, SIX, SEVEN C!!!! DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) REAL EIGHT, NINE, TEN C!!!! DOUBLE PRECISION EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 9D0, TEN = 10D0 ) C----- DEFINITION OF STATUS CODES. C--ON ENTRY: INTEGER CNORML, CRCSTR, CRCRPT, CRCNFG PARAMETER ( CNORML = 0, CRCSTR = 1, CRCRPT = 2, CRCNFG = 3 ) INTEGER CNRMFG, CPSTHR PARAMETER ( CNRMFG = -1, CPSTHR = -2 ) C--ON EXIT: INTEGER CDONE, CRCF, CRCFG, CRCG PARAMETER ( CDONE = 0, CRCF = 1, CRCFG = 2, CRCG = 3 ) INTEGER CNSTOR, CIPMIN, CIPUNF, CBDMTH PARAMETER ( CNSTOR = -1, CIPMIN = -2, CIPUNF = -3, CBDMTH = -4 ) INTEGER CLSFAL, CNODSC, CXSFNC, CPSBCK PARAMETER ( CLSFAL = -5, CNODSC = -6, CXSFNC = -7, CPSBCK = -8 ) INTEGER CRABRT, CUSERV PARAMETER ( CRABRT = -9, CUSERV = -10 ) C## L O C A L D E C L: C-----STANDARD DECLARATIONS. EXTERNAL ZZFNS, ZZINNR INTEGER I1, I2, I3, I4, I5 DOUBLE PRECISION ZZINNR C-----STATUS CODES INTEGER SNRMFG, SNORML, SRCSTR, SRCRPT, SRCNFG, SPSTHR INTEGER NORMFG, NORMAL, RCSTRT, RCRPT, RCNOFG, PSTHRU INTEGER SDONE, SRCF, SRCFG, SRCG, SNSTOR, SIPMIN, SPSBCK INTEGER DONE, RCF, RCFG, RCG, NOSTOR, IPMIN, PSBACK INTEGER SIPUNF, SBDMTH, SLSFAL, SNODSC, SXSFNC, SRABRT, SUSERV INTEGER IPUNDF, BDMETH, LSFAIL, NODESC, XSFUNC, RABORT, USERV C-----DECLARATIONS FOR BBLNIR. REAL DECRF C!!!! DOUBLE PRECISION DECRF C## S A V E: SAVE I1, I2, I3, I4, I5 SAVE NORMFG, NORMAL, RCSTRT, RCRPT, RCNOFG, PSTHRU SAVE DONE, RCF, RCFG, RCG, NOSTOR, IPMIN, IPUNDF, BDMETH SAVE LSFAIL, NODESC, RABORT, XSFUNC, USERV, PSBACK C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NONE ARE SET. DATA NORMFG/CNRMFG/, NORMAL/CNORML/, RCSTRT/CRCSTR/, - RCRPT /CRCRPT/, RCNOFG/CRCNFG/, PSTHRU/CPSTHR/ DATA DONE /CDONE/, RCF /CRCF/, RCFG /CRCFG/, RCG/CRCG/ - NOSTOR/CNSTOR/, IPMIN /CIPMIN/, IPUNDF/CIPUNF/, - BDMETH/CBDMTH/, LSFAIL/CLSFAL/, NODESC/CNODSC/, - RABORT/CRABRT/, XSFUNC/CXSFNC/, USERV /CUSERV/, - PSBACK/CPSBCK/ C## E X E C U T I O N C## E X E C U T I O N GOTO ( 1000, 2000 ) SUBR C----- CALL BUCKLEY-LENIR ROUTINE BBLNIR. 1000 CONTINUE IF ( STATUS .NE. RCRPT .AND. STATUS .NE. RCNOFG ) THEN C INITIALIZE, EXCEPT FOR A REVERSE COMMUNICATION RE-ENTRANCE. I1 = 1 I2 = I1 + N I3 = I2 + N I4 = I3 + N I5 = LR - 3*N IF ( I5 .LT. 0 ) THEN STATUS = NOSTOR GOTO 90000 ENDIF CALL BBLSET ( NINT(USER(1)), NINT(USER(2)), NINT(USER(3)), - NINT(USER(13)), NINT(USER(4)), NINT(USER(5)), - NINT(USER(14)), - USER(6), USER(7), - USER(8) .NE. ZERO , USER(9) .NE. ZERO , - USER(10) .NE. ZERO , USER(11) .NE. ZERO , - USER(12) .NE. ZERO , - RELF, RELG, - TRACUN, TRACES ) ENDIF CALL BBLNIR ( ZZFNS, N, X, F, USER(15), G, ACC, STATUS, ZZINNR, - RWORK(I1), RWORK(I2), RWORK(I3), RWORK(I4), I5, IW, RW, DW ) IF ( STATUS .EQ. USERV ) THEN STATUS = USERV - NINT(RWORK(I2)) ENDIF GOTO 90000 C----- CALL SHANNO'S CG ALGORITHM CONMIN. 2000 CONTINUE CALL CONMIN(ZZFNS,N,X,F,G,ACC,STATUS,RWORK,LR,NINT(USER(19)), - TRACES, TRACUN, NTR ) C REVISE STATUS CODES TO MATCH THOSE FOR MINTEST IF ( STATUS .EQ. 0 ) THEN STATUS = DONE ELSE IF ( STATUS .EQ. 1 ) THEN STATUS = XSFUNC ELSE IF ( STATUS .EQ. 2 ) THEN STATUS = LSFAIL ELSE IF ( STATUS .EQ. 3 ) THEN STATUS = NODESC ENDIF GOTO 90000 C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZLINK. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> lpcksg.f SUBROUTINE ZZLPCK ( LOOPC, LOOPX, ORDER, PT, VALUE ) C## A R G U M E N T S: INTEGER LOOPX(*), ORDER(*), PT REAL LOOPC(*), VALUE C!!!! DOUBLE PRECISION LOOPC(*), VALUE C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: LPCK.F,V 1.10 91/11/20 10:53:02 BUCKLEY EXP $ C>RCS $LOG: LPCK.F,V $ C>RCS REVISION 1.10 91/11/20 10:53:02 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.9 89/06/30 13:39:46 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 16:42:54 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 12:20:46 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:48:05 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:50:11 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE PICKS A VALUE FROM THE LOOP CONTROL ARRAY. C C C THE DESCRIPTION OF THE LOOP CONTROL STRUCTURE IS GIVEN IN ZZLADV. C IN ZZLADV, THE ARRAY LOOPX GIVES THE INDICES IN LOOPC FOR THE VARIOUS C POSITIONS OF THE ODOMETER. THE ENTRIES ARE TAKEN AS IN A REGULAR C ODOMETER IN THE ORDER FROM RIGHT TO LEFT, NAMELY FROM ENTRIES N, C N-1, ... ,1 OF LOOPX. C C HERE WE HAVE A SECOND INDEX ARRAY ORDER AND A POINTER PT. IN THE C MAIN PROGRAM THERE ARE A FIXED NUMBER OF QUANTITIES FOR WHICH LISTS C OR LOOPS MAY BE SPECIFIED. THEY ARE IN A FIXED ORDER, SAY Q1, Q2, C ... , QN. THE ARRAY ORDER SPECIFIES WHICH POSITION IN THE ODOMETER C EACH OF THESE CORRESPONDS TO. THUS IF ORDER(1) = 4, THEN THE CURRENT C VALUE OF Q1 IS OBTAINED FROM THE 4TH POSITION IN THE ODOMETER. PT C SPECIFIES WHICH QUANTITY WE WANT TO SAMPLE FROM THE ODOMETER. C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZLPCK C## S U B R O U T I N E S: NINT ... INTRINSIC C## P A R A M E T E R S: NONE ARE DEFINED. C## L O C A L D E C L: INTEGER J C## S A V E: NONE SELECTED. C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NONE ARE SET. C## E X E C U T I O N C## E X E C U T I O N J = LOOPX( ORDER(PT) ) IF ( NINT ( LOOPC(J) ) .LE. 0 ) THEN VALUE = LOOPC(J+1) ELSE VALUE = LOOPC ( J + NINT(LOOPC(J+1)) + 1 ) ENDIF GOTO 90000 C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZLPCK. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> putgsg.f SUBROUTINE ZZPUTG ( UNIT, NUM, NAM, SIZE, MEMBS, - NAMES, GROUPS, RECNO, ERRFLG, * ) C## A R G U M E N T S: INTEGER UNIT, NUM, SIZE, RECNO, ERRFLG INTEGER MEMBS( * ), GROUPS( * ) CHARACTER * ( * ) NAM, NAMES C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NOT REQUIRED. C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: PUTG.F,V 1.10 91/11/20 10:53:03 BUCKLEY EXP $ C>RCS $LOG: PUTG.F,V $ C>RCS REVISION 1.10 91/11/20 10:53:03 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.9 89/06/30 13:39:47 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 16:42:54 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 12:20:47 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:48:08 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:50:12 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS SUBROUTINE WRITES GROUP INFORMATION TO THE GIVEN FILE C AND TO THE ARRAYS 'NAMES' AND 'GROUPS'. C C PARAMETER DESCRIPTION: C C ON ENTRY: C UNIT - OUTPUT UNIT NUMBER OF DAUF C NUM - GROUP NUMBER C NAM - GROUP NAME C SIZE - THE SIZE OF THE GROUP C MEMBS - THE MEMBERS OF THE GROUP C NAMES - AN ARRAY OF CHARACTERS THAT CONTAINS THE C LIST OF GROUP NAMES C GROUPS - AN ARRAY CONTAINING THE POSITION OF THE C GROUP INFORMATION IN THE DAUF FILE C RECNO - THE NEXT FREE RECORD IN DAUF C C ON EXIT: C ERRFLG - AN ERROR RETURN. IT IS SET TO C 0 IF NO ERRORS OCCURRED C 1 IF ILLEGAL NAME OR NUMBER IS GIVEN C 2 IF GROUP SET IS FULL C 3 IF THERE IS A BAD PROBLEM IN THE GROUP C 4 IF THE GROUP IS EMPTY C C## E N T R Y P O I N T S: C C ZZPUTG - THE NATURAL ENTRY POINT C ZZDEFP - DEFINES THE SIZE OF RECORDS IN THE DAUF FILE C AND SOME OTHER CONSTANTS C C## S U B R O U T I N E S: C C DBLE(REAL)... INTRINSIC C C ZZWRIN ... WRITES INTEGER TO DAUF FILE C ZZERRM ... PRINTS ERROR MESSAGES C ZZSRCH ... SEARCHES A DICTIONARY C C RD ... STATEMENT FUNCTION C C## P A R A M E T E R S: LOGICAL T, F PARAMETER ( T = .TRUE., F = .FALSE. ) CHARACTER*(*) TRUE, QT, FALSE, QF PARAMETER ( TRUE = 'TRUE', QT = 'T', FALSE = 'FALSE', QF = 'F' ) INTEGER ITRUE, IFALSE PARAMETER ( ITRUE = 1, IFALSE = 0 ) REAL RTRUE, RFALSE C!!!! DOUBLE PRECISION RTRUE, RFALSE PARAMETER ( RTRUE = 1.D0, RFALSE = 0.D0 ) CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) CHARACTER*(*) PERIOD, COMMA, SEMICN PARAMETER ( PERIOD = '.', COMMA = ',', SEMICN = ';' ) CHARACTER*(*) COLON, DASH, EQUALS PARAMETER ( COLON = ':', DASH = '-', EQUALS = '=' ) CHARACTER*(*) OBRACE, CBRACE, UNDERS PARAMETER ( OBRACE = '{', CBRACE = '}', UNDERS = '_' ) CHARACTER*(*) PLUS, MINUS, EXCLAM PARAMETER ( PLUS = '+', MINUS = '-', EXCLAM = '!' ) CHARACTER*(*) GTHAN, LTHAN, QUESMK PARAMETER ( GTHAN = '>', LTHAN = '<', QUESMK = '?' ) CHARACTER*(*) SLASH, BSLASH, PERCNT PARAMETER ( SLASH = '/', BSLASH = '\\',PERCNT = '%' ) CHARACTER*(*) CARAT, ATSIGN, TILDE PARAMETER ( CARAT = '^', ATSIGN = '@', TILDE = '~' ) C---- ERROR MESSAGES CHARACTER *(*) ERR1, ERR2, ERR3, ERR4, ERR5, ERR6 PARAMETER ( ERR1 = 'GROUP NAME USED IN GROUP #', - ERR2 = 'GROUP SET FULL', - ERR3 = 'GROUP NUMBER TOO LARGE', - ERR4 = 'ALREADY USED GROUP #', - ERR5 = 'BAD PROBLEM IN GROUP POSITION #', - ERR6 = 'EMPTY GROUP' ) C## L O C A L D E C L: C---- INTEGER TO REAL FUNCTION REAL RD C!!!! DOUBLE PRECISION RD C---- NUMBER OF ELEMENTS PER LINE OF UNIT INTEGER IPERLN INTEGER SIPRLN C---- GROUP NAME LENGTH INTEGER PNAMLN, FNAMLN, GNAMLN PARAMETER ( PNAMLN = 8, FNAMLN = PNAMLN, GNAMLN = PNAMLN ) INTEGER TITLEN, PDESCL PARAMETER ( TITLEN = 72, PDESCL = 72 ) C---- MAXIMUM NUMBER OF GROUPS AND PROBLEMS INTEGER NOFNS, DFPRBS, MXGRPS, MXGSZ PARAMETER ( NOFNS = 80, DFPRBS = 450, MXGRPS = 50, MXGSZ = 200 ) C---- MISCELLANEOUS VARIABLES INTEGER I, J C## S A V E: SAVE IPERLN C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NONE ARE SET. C## E X E C U T I O N C## E X E C U T I O N C---- DEFINE FUNCTION STATEMENT RD(I) = REAL(I) C!!!! RD(I) = DBLE(I) C---- ERRFLG = 0 C---- CHECK THE NAME AND NUMBER IF ( NAM .NE. BLANK ) THEN C SEE IF NAME HAS BEEN USED CALL ZZSRCH(NAM,GNAMLN,NAMES,MXGRPS,GNAMLN,I,F,T) IF ( I .NE. 0 ) THEN ERRFLG = 1 CALL ZZERRM( RD(I), *91000, 'IS'//ERR1 ) GOTO 90000 ENDIF ENDIF IF ( NUM .LE. 0 ) THEN C FIND FIRST UNUSED GROUP NUMBER DO 100 I = 1, MXGRPS IF ( GROUPS(I) .EQ. -1 ) THEN NUM = I GOTO 200 ENDIF 100 CONTINUE ERRFLG = 2 CALL ZZERRM ( RD(I), *91000, 'NS'//ERR2 ) GOTO 90000 ELSE IF ( NUM .GE. MXGRPS ) THEN ERRFLG = 1 CALL ZZERRM ( RD(NUM), *91000, 'NS'//ERR3 ) GOTO 90000 ELSE IF ( GROUPS(NUM) .NE. -1 ) THEN ERRFLG = 1 CALL ZZERRM ( RD(NUM), *91000, 'IS'//ERR4 ) GOTO 90000 ENDIF 200 CONTINUE C---- CHECK THE PROBLEM NUMBERS J = 0 DO 300 I = 1, SIZE IF ( MEMBS(I) .LE. 0 .OR. MEMBS(I) .GT. DFPRBS ) THEN ERRFLG = 3 CALL ZZERRM ( RD(I), *91000, 'NS'//ERR5 ) MEMBS(I) = -1 J = J+1 ENDIF 300 CONTINUE IF ( SIZE-J .EQ. 0 ) THEN ERRFLG = 4 CALL ZZERRM( RD(J), *91000, 'NS'//ERR6 ) GOTO 90000 ENDIF C---- UPDATE THE GROUPS ARRAY GROUPS( NUM ) = RECNO C---- UPDATE NAME ARRAY I = ( NUM-1 ) * GNAMLN + 1 J = I + GNAMLN - 1 NAMES( I : J ) = NAM C---- WRITE THE SIZE CALL ZZWRIN( UNIT, SIZE, 1, IPERLN, RECNO ) C---- WRITE MEMBS ARRAY CALL ZZWRIN( UNIT, MEMBS(1), SIZE, IPERLN, RECNO ) GOTO 90000 C## E N T R Y ZZGDEF: ENTRY ZZDEFP ( SIPRLN ) IPERLN = SIPRLN RETURN C## E X I T 90000 RETURN 91000 RETURN1 C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZPUTG. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> putpsg.f SUBROUTINE ZZPUTP ( UNIT, PNUM, FNUM, PNAME, FNAME, DESC, - SOLNS, INTS, ORDER, LOOPX, LOOPC, X0, - NAMES, PRECNO, RECNO, ERRFLG, * ) C## A R G U M E N T S: INTEGER UNIT, PNUM, FNUM, RECNO, ERRFLG INTEGER INTS( * ), PRECNO( 3,* ), ORDER( * ), LOOPX( * ) REAL LOOPC( * ), X0( * ), SOLNS(*) C!!!! DOUBLE PRECISION LOOPC( * ), X0( * ), SOLNS(*) CHARACTER * ( * ) PNAME, FNAME, DESC, NAMES C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: PUTP.F,V 1.10 91/11/20 10:53:04 BUCKLEY EXP $ C>RCS $LOG: PUTP.F,V $ C>RCS REVISION 1.10 91/11/20 10:53:04 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.9 89/06/30 13:39:48 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 16:42:55 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 17:08:26 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS C>RCS REVISION 1.2 89/05/15 14:48:10 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:50:12 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS SUBROUTINE WRITES PROBLEM INFORMATION TO THE GIVEN FILE C AND TO THE ARRAYS 'NAMES' AND 'PRECNO'. C C PARAMETER DESCRIPTION: C C ON ENTRY: C UNIT - OUTPUT UNIT NUMBER FOR DAUF C PNAME - PROBLEM NAME C FNAME - FUNCTION NAME C PCHRS - STRING CONTAINING CHARACTERS TO BE WRITTEN C TO UNIT C INTS - ARRAY CONTAINING THE INTEGERS TO BE WRITTEN C TO UNIT C RELS - ARRAY CONTAINING THE DOUBLE PRECISION OR REAL C ( AS THE CASE MAY BE ) NUMBERS TO BE WRITTEN C TO UNIT C NAMES - AN ARRAY OF CHARACTERS THAT CONTAINS THE C PROBLEM NAME AND THE FUNCTION NAME FOR EACH C PROBLEM C PRECNO - AN INTEGER ARRAY THAT CONTAINS THE DIMENSION, C THE FUNCTION NUMBER, AND THE RECORD NUMBER C ( IN THE DAUF FILE ) FOR EACH ROBLEM C RECNO - THE NEXT FREE RECORD IN UNIT DAUF C C ON EXIT: C ERRFLG - AN ERROR RETURN. IT IS SET TO C 0 IF NO ERRORS OCCURRED C 1 IF ILLEGAL NAME OR NUMBER IS GIVEN C 2 IF PROBLEM SET IS FULL C 3 IF NO FUNCTION IS GIVEN C 4 IF AN ILLEGAL DIMENSION IS GIVEN C C## E N T R Y P O I N T S: C C ZZPUTP - THE NATURAL ENTRY POINT C ZZPDEF - DEFINES THE SIZE OF RECORDS IN THE DAUF FILE C AND SOME OTHER CONSTANTS C C## S U B R O U T I N E S: C C NINT, DBLE(REAL) ... INTRINSICS C ZZERRM PRINTS ERROR MESSAGES C ZZLPCK OBTAINS LOOP DATA C ZZSRCH SEARCHES A DICTIONARY C ZZWRCH WRITES CHARACTERS TO THE DAUF FILE C ZZWRIN WRITES INTEGERS TO THE DAUF FILE C ZZWRRL WRITES REALS TO THE DAUF FILE C RD ... A STATEMENT FUNCTION C C## P A R A M E T E R S: LOGICAL T, F PARAMETER ( T = .TRUE., F = .FALSE. ) CHARACTER*(*) TRUE, QT, FALSE, QF PARAMETER ( TRUE = 'TRUE', QT = 'T', FALSE = 'FALSE', QF = 'F' ) INTEGER ITRUE, IFALSE PARAMETER ( ITRUE = 1, IFALSE = 0 ) REAL RTRUE, RFALSE C!!!! DOUBLE PRECISION RTRUE, RFALSE PARAMETER ( RTRUE = 1.D0, RFALSE = 0.D0 ) CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) CHARACTER*(*) PERIOD, COMMA, SEMICN PARAMETER ( PERIOD = '.', COMMA = ',', SEMICN = ';' ) CHARACTER*(*) COLON, DASH, EQUALS PARAMETER ( COLON = ':', DASH = '-', EQUALS = '=' ) CHARACTER*(*) OBRACE, CBRACE, UNDERS PARAMETER ( OBRACE = '{', CBRACE = '}', UNDERS = '_' ) CHARACTER*(*) PLUS, MINUS, EXCLAM PARAMETER ( PLUS = '+', MINUS = '-', EXCLAM = '!' ) CHARACTER*(*) GTHAN, LTHAN, QUESMK PARAMETER ( GTHAN = '>', LTHAN = '<', QUESMK = '?' ) CHARACTER*(*) SLASH, BSLASH, PERCNT PARAMETER ( SLASH = '/', BSLASH = '\\',PERCNT = '%' ) CHARACTER*(*) CARAT, ATSIGN, TILDE PARAMETER ( CARAT = '^', ATSIGN = '@', TILDE = '~' ) CHARACTER *(*) UNDEFN PARAMETER ( UNDEFN = 'UNDEFN' ) C---- POSITION FLAGS FOR ENTRIES IN THE PRECNO ARRAY C DEFINITIONS OF THE ROWS IN THE ARRAY PRECNO. ( PRECNO HOLDS THE C RECORD NUMBER IN THE DAUF FILE, THE MINIMUM DIMENSION, AND THE C FUNCTION NUMBER OF EACH PROBLEM. ) INTEGER RECN, DIMN, FNO1 PARAMETER ( RECN = 1, DIMN = 2, FNO1 = 3 ) C---- POSITION FLAGS FOR ENTRIES IN THE INTS ARRAY INTEGER PPTMAX, PPTIX0, PPTDES PARAMETER ( PPTMAX = 1, PPTIX0 = 2, PPTDES = 3 ) INTEGER PPTORD, PPTLPX, PPTLPC, PPTSOL PARAMETER ( PPTORD = 4, PPTLPX = 5, PPTLPC = 6, PPTSOL = 7 ) INTEGER NPNTS PARAMETER ( NPNTS = 7 ) C---- INFORMATIVE MESSAGES. CHARACTER *(*) ERR1, ERR2, ERR3, ERR4, ERR5, ERR6, MESS PARAMETER ( ERR1 = 'PROBLEM NUMBER TOO LARGE, #', - ERR2 = 'PROBLEM SET FULL', - ERR3 = 'PROBLEM NAME USED IN PROBLEM #', - ERR4 = 'ALREADY DEFINED PROBLEM #' , - ERR5 = 'NO FUNCTION SPECIFIED IN PROBLEM DEFINITION', - ERR6 = 'ILLEGAL DIMENSION', - MESS = 'PROBLEM ASSIGNED PROBLEM #' ) C## L O C A L D E C L: C---- INTEGER TO REAL FUNCTION REAL RD C!!!! DOUBLE PRECISION RD C---- DECLARE THE NUMBER OF ELEMENTS PER LINE OF UNIT INTEGER CPERLN, IPERLN, RPERLN INTEGER SCPRLN, SIPRLN, SRPRLN C---- DECLARE THE PROBLEM AND FUNCTION NAME LENGTHS INTEGER PNAMLN, FNAMLN, GNAMLN PARAMETER ( PNAMLN = 8, FNAMLN = PNAMLN, GNAMLN = PNAMLN ) INTEGER TITLEN, PDESCL PARAMETER ( TITLEN = 72, PDESCL = 72 ) C---- DECLARE MAXIMUM NUMBER OF PROBLEMS INTEGER NOFNS, DFPRBS, MXGRPS, MXGSZ PARAMETER ( NOFNS = 80, DFPRBS = 450, MXGRPS = 50, MXGSZ = 200 ) C---- POINTER TO DIMENSION DATA INTEGER PTNDIM, SPTDIM C---- MISC VARIABLES INTEGER DIM, I, J, K LOGICAL INFORM REAL VAL C!!!! DOUBLE PRECISION VAL C## S A V E: SAVE CPERLN, IPERLN, RPERLN, PTNDIM C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA INFORM /F/ C## E X E C U T I O N C## E X E C U T I O N C----- DEFINE FUNCTION STATEMENT. RD(I) = REAL(I) C!!!! RD(I) = DBLE(I) ERRFLG = 0 C---- CHECK PROBLEM NAME AND NUMBER IF ( PNUM .GT. DFPRBS ) THEN ERRFLG = 1 CALL ZZERRM ( RD(PNUM), *91000, 'IS'//ERR1 ) GOTO 90000 ELSE IF ( PNUM .EQ. -1 ) THEN C FIND NEXT FREE PROBLEM NUMBER DO 100 I = 1, DFPRBS IF ( PRECNO( RECN, I ) .EQ. -1 ) THEN PNUM = I INFORM = T GOTO 200 ENDIF 100 CONTINUE ERRFLG = 2 CALL ZZERRM ( RD(I), *91000, 'NS'//ERR2 ) GOTO 90000 ENDIF 200 CONTINUE IF ( PNAME .NE. UNDEFN ) THEN K = 1 CALL ZZSRCH ( PNAME, PNAMLN, NAMES, DFPRBS, - PNAMLN+FNAMLN, K, F ,T ) IF ( K .NE. 0 ) THEN ERRFLG = 1 CALL ZZERRM( RD(K), *91000, 'IS'//ERR3 ) ENDIF ENDIF IF ( PRECNO(RECN,PNUM) .NE. -1 ) THEN ERRFLG = 1 CALL ZZERRM ( RD(PNUM), *91000, 'IS'//ERR4 ) GOTO 90000 ENDIF C---- CHECK THE FUNCTION NAME AND NUMBER IF ( FNUM .EQ. -1 .AND. FNAME .EQ. BLANK ) THEN ERRFLG = 3 CALL ZZERRM ( RD(I), *91000, 'NS'//ERR5 ) GOTO 90000 ENDIF C---- FIND THE FIRST DIMENSION CALL ZZLPCK( LOOPC, LOOPX, ORDER, PTNDIM, VAL ) DIM = NINT(VAL) IF ( DIM .LT. 2 ) THEN ERRFLG = 4 CALL ZZERRM ( RD(DIM), *91000, 'NT'//ERR6 ) GOTO 90000 ENDIF C---- UPDATE THE PRECNO ARRAY PRECNO( FNO1, PNUM ) = FNUM PRECNO( RECN, PNUM ) = RECNO PRECNO( DIMN, PNUM ) = DIM C---- UPDATE NAME ARRAY I = ( PNUM-1 ) * ( 2*PNAMLN ) + 1 J = I + PNAMLN - 1 K = J + PNAMLN NAMES( I : J ) = PNAME NAMES( J+1 : K ) = FNAME C---- WRITE INTS ARRAY CALL ZZWRIN( UNIT, INTS, NPNTS, IPERLN, RECNO ) C---- WRITE CHARACTERS CALL ZZWRCH( UNIT, DESC, INTS(PPTDES), CPERLN, RECNO ) C---- WRITE INTEGER ARRAYS CALL ZZWRIN( UNIT, ORDER, INTS(PPTORD), IPERLN, RECNO ) CALL ZZWRIN( UNIT, LOOPX, INTS(PPTLPX), IPERLN, RECNO ) C---- WRITE REAL ARRAY(S) CALL ZZWRRL( UNIT, LOOPC, INTS(PPTLPC), RPERLN, RECNO ) IF ( INTS(PPTIX0) .GT. 0 ) THEN CALL ZZWRRL( UNIT, X0, INTS(PPTIX0), RPERLN, RECNO ) ENDIF IF ( INTS(PPTSOL) .GT. 0 ) THEN CALL ZZWRRL( UNIT, SOLNS, INTS(PPTSOL), RPERLN, RECNO ) ENDIF C---- INFORM USER THAT DEFAULT PROBLEM NUMBER WAS USED IF ( INFORM ) THEN CALL ZZERRM( RD(PNUM), *91000, 'IT'//MESS ) ENDIF C---- GOTO THE EXIT POINT GOTO 90000 C## E N T R Y ZZPDEF: ENTRY ZZPDEF ( SCPRLN, SIPRLN, SRPRLN, SPTDIM ) CPERLN = SCPRLN IPERLN = SIPRLN RPERLN = SRPRLN PTNDIM = SPTDIM RETURN C## E X I T 90000 RETURN 91000 RETURN1 C## F O R M A T S: NONE ARE DEFINED. C C THERE ARE NO FORMATS USED. C C## E N D OF STATEMENT.. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> smrysg.f SUBROUTINE ZZSMRY ( WISH, X0, SYSCC, SUMM, WRITFL, NMWRIT, - COPY, LL, MXCRIT, NL, RPSOUT, - TESTCH, NBASIC, SEELEV, LONGF, KEY, MAP, * ) C## A R G U M E N T S: LOGICAL SUMM, WRITFL, LONGF, WISH(*), COPY INTEGER SYSCC, NBASIC, SEELEV, RPSOUT, - MAP(*), MXCRIT, NL REAL X0(*) C!!!! DOUBLE PRECISION X0(*) CHARACTER * 1 TESTCH CHARACTER *(*) KEY, NMWRIT, LL(MXCRIT) C## S T A T U S: C IGNORE LINES BEGINNING WITH "C!!!!" . C C SYSTEM DEPENDENCE: NONE. C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C>RCS $HEADER: SMRY.F,V 2.3 91/11/20 10:53:05 BUCKLEY EXP $ C>RCS $LOG: SMRY.F,V $ C>RCS REVISION 2.3 91/11/20 10:53:05 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 2.2 90/08/08 17:22:30 BUCKLEY C>RCS MINOR FIX TO END OF FILE. C>RCS C>RCS REVISION 2.1 90/08/02 16:18:19 BUCKLEY C>RCS FIXED DUPLICATES IN RESULT FILE. C>RCS C>RCS REVISION 2.0 90/07/31 11:33:08 BUCKLEY C>RCS MINOR FIX TO OUTPUT. C>RCS C>RCS REVISION 1.9 89/06/30 13:39:49 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 16:42:56 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 12:20:49 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:48:11 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:50:12 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE IS CALLED TO OUTPUT THE SUMMARY AND TO CREATE THE C FORMATTED OUTPUT FILE AFTER THE EXECUTION OF A SET OF PROBLEMS. C IT TAKES INPUT FROM TEMPUN AND PRODUCES OUTPUT ON WRITUN AND/OR C TRMOUT. SUMMUN IS ALSO USED AS A TEMPORARY FILE. C C PARAMETER DESCRIPTION: THE PARAMETERS IN THE CALLING SEQUENCE C HAVE THE SAME NAMES IN ZZTEST AND ARE DESCRIBED THERE. C C CONTROL: TEMPUN FILE WITH DATA C SUMMUN TEMPORARY FILE TO CONSTRUCT SUMMARY C WRITUN FILE FOR MAJOR OUTPUT C TRMOUT TERMINAL OUTPUT C C SEELEV LEVEL OF TERMINAL OUTPUT C WRITFL GENERATE OUTPUT OF TEST INTO WRITE UNIT. C SUMM COPY SUMMARY TO WRITUN AFTER DOING MAIN OUTPUT. C C ORGANIZATION C C-----THE FOLLOWING INFORMATION IS ASSUMED TO BE ON THE FILE TEMPUN. C C NOTE THAT THERE IS NO WORRY ABOUT FORMATS, BECAUSE C LIST-DIRECTED (I.E. FREE) FORMATTING IS USED. C C THE DATA IS IN VARIOUS BLOCKS. THESE BLOCKS MAY HAVE USER C WRITTEN DATA INTERSPERSED, AND THERE IS NO CONTROL OVER THIS. C C THUS, IN ORDER THAT THESE LINES MAY BE EASILY LOCATED, C THEY ARE PRECEDED BY THE SYSTEM "TEST CHARACTER", C WHICH IS CURRENTLY SET IN ZZTEST AS ">". C C.... ON TEMPUN: C C>>BLOCK I: INFORMATION APPLYING TO ENTIRE PROBLEM SET, NAMELY, C C NP, NORM, TYPE, DERV, MEMORY, SUBR, SUBNAM, C CNORM, CTYPE, CDERV AND TITLE C C>>BLOCK II: THEN THE FOLLOWING INFORMATION, II(A) TO II(G) IS C REPEATED FOR EACH PROBLEM SOLVED (OR ATTEMPTED!) C C BLOCK II(A): PRNAME, PROB, FNAME, FUNC, ACC, FACTOR, USER, C N, SCALE, FARG C C C BLOCK II(B): THE STARTING POINT C C X0(I), I=1,N (THIS MAY TAKE SEVERAL LINES) C C BLOCK II(C): AT THIS POINT THE ROUTINE ZZBFOR IS CALLED. OUTPUT C APPEARING AT THIS POINT IN TEMPUN WILL HAVE BEEN PRODUCED C BY CODE IN ZZBFOR, AS PLACED THERE BY THE USER, AND WILL C HAVE TO BE PROCESSED BY PUTTING CODE IN THIS ROUTINE AT C THE POINT BELOW MARKED AS BLOCK II(C). C C C BLOCK II(D): THEN THE OUTPUT FROM THE USER'S ALGORITHM (INCLUDING C THAT ISSUED THROUGH ZZPRNT) APPEARS IN THE FILE TEMPUN. IT C IS ECHOED TO WRITUN, AS IS, UNTIL A LINE BEGINNING WITH ">". C NOTE THAT, IF NO ACTION IS TAKEN BY THE USER FOR BLOCK C II(C) THEN IT WILL JUST BE ECHOED AS PART OF THIS OUTPUT. C THIS ALSO MEANS THE SOLUTION IS READ AND PRINTED ON WRITUN. C C C BLOCK II(E): NOW THE SUMMARY DATA FOR THE PROBLEM. C C ITCT, FUNCCT, GRADCT, F, GSQ, TMIN, TFUN, TPRINT, ERFLAG C C BLOCK II(F): NOW YOU GET STATS ON DERIVATIVE TESTING. C C THIS INFORMATION APPEARS ONLY IF THE RUN WAS DONE USING C DERVMD = CTEST OR CFIRST: C C MXERR, INDEX, GCNT, DIGS C C BLOCK II(G): FINALLY, ANY ADDITIONAL OUTPUT GENERATED THROUGH THE C CALL TO ZZAFTR APPEARS. IT MUST BE PROCESSED AS EXPLAINED C FOR BLOCK II(C). C C..... SUMMUN: C C THE FOLLOWING DATA IS WRITTEN ONTO THE FILE SUMMUN AS A C TEMPORARY MEASURE; IT IS USED TO CREATE THE FINAL SUMMARY. C THIS DATA IS REPEATED FOR EACH PROBLEM. C C PRNAME, PROB, FUNC, N C ITCT, FUNCCT, GRADCT, F, GSQ, TMIN, TFUN, TPRINT, ERFLAG C C PLUS ANY USER OUTPUT GENERATED AT II(C) OR II(G). C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZSMRY. C C## S U B R O U T I N E S: C ZZCNTR CENTER A STRING C ZZDTTM DATE AND TIME C ZZOPEN TO OPEN A FILE. C ABS, LEN, MIN, REAL(DBLE) ...INTRINSIC C RD ...A STATEMENT FUNCTION. C C## P A R A M E T E R S: REAL ZERO, ONE, TWO, THREE C!!!! DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) REAL FOUR, FIVE, SIX, SEVEN C!!!! DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) REAL EIGHT, NINE, TEN C!!!! DOUBLE PRECISION EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 9D0, TEN = 10D0 ) CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) CHARACTER*(*) PERIOD, COMMA, SEMICN PARAMETER ( PERIOD = '.', COMMA = ',', SEMICN = ';' ) CHARACTER*(*) COLON, DASH, EQUALS PARAMETER ( COLON = ':', DASH = '-', EQUALS = '=' ) CHARACTER*(*) OBRACE, CBRACE, UNDERS PARAMETER ( OBRACE = '{', CBRACE = '}', UNDERS = '_' ) CHARACTER*(*) PLUS, MINUS, EXCLAM PARAMETER ( PLUS = '+', MINUS = '-', EXCLAM = '!' ) CHARACTER*(*) GTHAN, LTHAN, QUESMK PARAMETER ( GTHAN = '>', LTHAN = '<', QUESMK = '?' ) CHARACTER*(*) SLASH, BSLASH, PERCNT PARAMETER ( SLASH = '/', BSLASH = '\\',PERCNT = '%' ) CHARACTER*(*) CARAT, ATSIGN, TILDE PARAMETER ( CARAT = '^', ATSIGN = '@', TILDE = '~' ) INTEGER FNO PARAMETER ( FNO = 10 ) INTEGER NU PARAMETER ( NU = 21 ) INTEGER RECL PARAMETER ( RECL = 0 ) CHARACTER*(*) DATFIX PARAMETER ( DATFIX = 'TEST BEING EXECUTED AT ' ) C DEFINITIONS OF STRING LENGTHS INTEGER PNAMLN, FNAMLN, GNAMLN PARAMETER ( PNAMLN = 8, FNAMLN = PNAMLN, GNAMLN = PNAMLN ) INTEGER TITLEN, PDESCL PARAMETER ( TITLEN = 72, PDESCL = 72 ) C DEFINITIONS OF THE I/O UNITS INTEGER PREPRC, DAUF, INPTUN PARAMETER ( PREPRC = 1, DAUF = 2, INPTUN = 3 ) INTEGER TEMPUN, STDIN, TRMOUT PARAMETER ( TEMPUN = 4, STDIN = 5, TRMOUT = 6 ) INTEGER WRITUN, TRACUN, SUMMUN PARAMETER ( WRITUN = 7, TRACUN = 8, SUMMUN = 9 ) INTEGER COPYUN, TEXUN PARAMETER ( COPYUN =10, TEXUN =11 ) C TERMINATION CODES INTEGER NL1, NL2, NLINF PARAMETER ( NL1 = 1, NL2 = 2, NLINF = 3 ) INTEGER NQUITS PARAMETER ( NQUITS = 4 ) INTEGER PGRAD, PSTEP, PSHXG, PFUNC PARAMETER ( PGRAD = 1, PSTEP = 2, PSHXG = 3, PFUNC = 4 ) C DERIVATIVE MODE CODES INTEGER CANAL, CDIFF, CTEST, CFIRST PARAMETER ( CANAL = 1, CDIFF = 2, CTEST = 3, CFIRST = 4 ) C SORT CODES. INTEGER SPRNAM, SPRNUM, SASIS, SRECNO PARAMETER ( SPRNAM = 1, SPRNUM = 2, SASIS = 3, SRECNO = 4 ) INTEGER SFNNAM, SFNNUM, SDIMN, SPROLG PARAMETER ( SFNNAM = 5, SFNNUM = 6, SDIMN = 7, SPROLG = 8 ) C CHECK CODES. INTEGER CHOFF, CHON, CHNAM, CHNUM PARAMETER ( CHOFF = 1, CHON = 2, CHNAM = 3, CHNUM = 4 ) C WISH CODES. INTEGER CCOLD, CDOFLE, CDOTRM, NWISHS PARAMETER ( CCOLD = 1, CDOFLE = 2, CDOTRM = 3, NWISHS = 3 ) C TERMINAL CHARACTERISTICS AND SUMMARY LEVELS INTEGER CEOFAC, CEOFIG PARAMETER ( CEOFAC = 1, CEOFIG=2 ) INTEGER CCPRSN, CCMISS PARAMETER ( CCPRSN = 1, CCMISS = 2 ) INTEGER CNONE, CMIN, CMED, CFULL PARAMETER ( CNONE = 1, CMIN = 2, CMED = 3, CFULL = 4 ) C## L O C A L D E C L: C-----REMOTE BLOCKS. INTEGER REMOT1, REMOT2, REMOT3 INTEGER RETRN1, RETRN2, RETRN3 C-----OTHER DECLARATIONS. INTEGER NORM, MEMORY, SUBR, CUMITS, CUMFNS, CUMGRS, WCHG INTEGER NP, PROB, FUNC, SCALE, ERRCNT, BDPROB, SOLNF, BLOCK INTEGER N, DERV, LEND, LENF, FUNCCT, GRADCT, GINDX INTEGER I, ERFLAG, ITCT, JE, JS, FORCES, J, CRITNO INTEGER UNIT, PRCT, FINDX, TINDX, INDEX, GCNT, SOLNX INTEGER EXPENS, TRMCPY LOGICAL KEEPSM, FIRST, TRMSUM, RELF, RELG, ONFILE, ONTERM CHARACTER *(NQUITS) QUITS CHARACTER *(78) CHARS CHARACTER *(TITLEN) TITLE, DATLIN, CENTIT, CENDAT CHARACTER *(PNAMLN) PRNAME, SUBNAM CHARACTER *(FNAMLN) FNAME CHARACTER * 2 EXCL, BPLUS CHARACTER * 1 CH REAL CUMERR, AVDIGS, DF, DX C!!!! DOUBLE PRECISION CUMERR, AVDIGS, DF, DX REAL ACC, FACTOR, CUMMTM, CUMFTM, CUMPTM, RD C!!!! DOUBLE PRECISION ACC, FACTOR, CUMMTM, CUMFTM, CUMPTM, RD REAL USER(NU), FARG(FNO), MING, MAXG C!!!! DOUBLE PRECISION USER(NU), FARG(FNO), MING, MAXG REAL F, GSQ, TMIN, TFUN, TPRINT, RATIO, MXERR, DIGS C!!!! DOUBLE PRECISION F, GSQ, TMIN, TFUN, TPRINT, RATIO, MXERR, DIGS CHARACTER*10 CNORM(3), CTYPE(5), CDERV(4) CHARACTER*10 VCHEC(4), VCC (2), VSEE (4), VSORT(7) C----- USER DECLARATIONS. INTEGER NUPS, CNTRST C## S A V E: SAVE FIRST, REMOT1, REMOT2, REMOT3, LEND, LENF SAVE EXCL, BPLUS, PRCT, SUBNAM, TITLE SAVE NP, NORM, QUITS, RELF, RELG,DERV, MEMORY, SUBR C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA FIRST / .TRUE. /, EXCL/ ' !' /, BPLUS/' +'/ DATA CNTRST/0/, NUPS/0/, FORCES/0/ DATA CNORM(NL1) /'ABS SUM '/, CTYPE(PGRAD)/'GRADIENT '/ DATA CNORM(NL2) /'EUCLIDEAN '/, CTYPE(PSTEP)/'STEPSIZE '/ DATA CNORM(NLINF)/'MAXIMUM '/, CTYPE(PSHXG)/'SHANNOXG '/ DATA CTYPE(PFUNC)/'FUNCTION '/ DATA CDERV(CANAL)/'ANALYTIC '/, VSORT(SPRNAM)/'PROB NAME '/ DATA CDERV(CDIFF)/'DIFFERENCE'/, VSORT(SPRNUM)/'PROB NUMB '/ DATA CDERV(CTEST)/'TESTMODE '/, VSORT(SASIS )/'AS IS '/ DATA CDERV(CFIRST)/'FIRSTSTEP'/, VSORT(SRECNO)/'RECORD NO.'/ DATA VSORT(SFNNAM)/'FUNC NAME '/ DATA VSORT(SFNNUM)/'FUNC NUMB '/ DATA VSORT(SDIMN )/'DIMENSION '/ DATA VCC (CCPRSN)/'PRESENT '/ VCC (CCMISS)/'MISSING '/ DATA VCHEC(CHOFF)/'OFF '/, VSEE (CNONE )/'NONE '/ DATA VCHEC(CHON )/'ON '/, VSEE (CMIN )/'MINIMAL '/ DATA VCHEC(CHNAM)/'NAMES '/, VSEE (CMED )/'MEDIUM '/ DATA VCHEC(CHNUM)/'NUMBERS '/, VSEE (CFULL )/'FULL '/ C## E X E C U T I O N C## E X E C U T I O N C----- DEFINE A FUNCTION STATEMENT. RD(I) = REAL(I) C!!!! RD(I) = DBLE(I) C----- NOW EXECUTE. TRMSUM = SEELEV .EQ. CFULL .OR. SEELEV .EQ. CMED - .OR. SEELEV .EQ. CMIN KEEPSM = TRMSUM .OR. SUMM ONFILE = SUMM .AND. ( WISH(CCOLD) .OR. WISH(CDOFLE)) ONTERM = TRMSUM .AND. ( WISH(CCOLD) .OR. WISH(CDOTRM)) IF ( SYSCC .EQ. CCMISS ) THEN TINDX = 2 ELSE TINDX = 1 ENDIF IF ( FIRST ) THEN ASSIGN 81000 TO REMOT1 ASSIGN 82000 TO REMOT2 ASSIGN 83000 TO REMOT3 LEND = LEN(DATLIN) LENF = LEN(DATFIX) + 1 C OPEN APPROPRIATE FILES. CALL ZZOPEN ( WRITUN,WRITFL .OR. SUMM,NMWRIT,*91000,RECL ) CALL ZZOPEN ( SUMMUN,KEEPSM, BLANK,*91000,RECL ) FIRST = .FALSE. ENDIF C----- SET UP DATE. DATLIN = DATFIX CALL ZZDTTM ( DATLIN(LENF:LEND) ) CENDAT = DATLIN CALL ZZCNTR ( CENDAT ) C----- REWIND FILES OF TEMPORARY DATA. REWIND TEMPUN REWIND SUMMUN C ==> BLOCK I PROCESSING. C----- READ DATA COMMON TO SET OF PROBLEMS 1000 CONTINUE READ ( TEMPUN, 99996, END = 90000 ) CH IF ( CH .NE. TESTCH ) THEN GOTO 1000 ENDIF READ ( TEMPUN, * ) NP, NORM, CRITNO, RELF, RELG,DERV, MEMORY, SUBR READ ( TEMPUN, '(A)' ) QUITS READ ( TEMPUN, '( A, A )' ) SUBNAM, TITLE IF ( NP .EQ. 0 ) THEN IF ( WRITFL .OR. SUMM ) THEN WRITE ( WRITUN, '(A)' ) ' NO PROBLEMS SPECIFIED.' ENDIF WRITE ( RPSOUT, '(A)' ) ' NO PROBLEMS SPECIFIED.' IF ( COPY ) THEN WRITE ( COPYUN, '(A)' ) ' NO PROBLEMS SPECIFIED.' ENDIF ELSE CENTIT = TITLE CALL ZZCNTR ( CENTIT ) ENDIF C===== NOW LOOP FOR EACH OUTER LOOP. IF ( .NOT. WISH(CCOLD) ) THEN GOTO 10000 ENDIF 1200 READ ( TEMPUN, '(3E24.18)', END = 10000 ) ACC, FACTOR, USER WRITE (SUMMUN, '(3E24.18)') ACC, FACTOR, USER WRITE (SUMMUN, * ) ' ' C----- INITIALIZE CUMULATIVE COUNTS. CUMITS = 0 CUMFNS = 0 CUMGRS = 0 ERRCNT = 0 CUMERR = ZERO AVDIGS = ZERO WCHG = 0 GINDX = 0 BDPROB = 0 CUMFTM = ZERO CUMMTM = ZERO CUMPTM = ZERO C===== NOW LOOP FOR EACH PROBLEM. PRCT = 0 C ==> BLOCK II PROCESSING. READ DATA PARTICULAR TO A PROBLEM. C ==> BLOCK II (A) -- BASIC DATA. EOF HERE MEANS LAST PROBLEM DONE. C ----NOT LAST PROBLEM, SO PRINT OUTPUT HEADER. IF ( WRITFL ) THEN C HEADER ON WRITUN UNIT = WRITUN ASSIGN 1500 TO RETRN1 GOTO REMOT1 ENDIF 1500 CONTINUE READ ( TEMPUN, '(A1,A78)', END=1520 ) CH, CHARS IF ( CH .NE. TESTCH ) THEN GOTO 1500 ELSE IF ( CHARS .NE. 'END OF SET' ) THEN PRCT = PRCT + 1 GOTO 1530 ELSE WRITE(SUMMUN,*) CUMITS,CUMFNS,CUMGRS,ERRCNT,CUMERR, - AVDIGS,WCHG, GINDX, BDPROB,CUMFTM, - CUMMTM,CUMPTM GOTO 1200 ENDIF 1520 WRITE(SUMMUN,*) CUMITS,CUMFNS,CUMGRS,ERRCNT,CUMERR, - AVDIGS,WCHG, GINDX, BDPROB,CUMFTM, - CUMMTM,CUMPTM 1530 READ ( TEMPUN, '( A,A )' ) PRNAME, FNAME READ ( TEMPUN, * , END=9000 ) PROB,FUNC,N,SCALE,EXPENS,FARG C ==> BLOCK II (B) READ STARTING POINT. READ ( TEMPUN, * , END=9000 ) ( X0(I), I=1,N ) C ---AND ADD SOME OF IT TO THE HEADER. IF ( WRITFL ) THEN WRITE ( WRITUN, * ) WRITE ( WRITUN, * ) WRITE ( WRITUN, 99901 ) BPLUS WRITE ( WRITUN, 99902 ) EXCL WRITE ( WRITUN, 99927 ) EXCL, PRNAME, PROB WRITE ( WRITUN, 99902 ) EXCL WRITE ( WRITUN, 99921 ) EXCL I = 1 1550 IF ( I+4 .LE. FNO ) THEN WRITE ( WRITUN, 99923 ) EXCL, (FARG(J),J=I,I+4) I=I+5 GOTO 1550 ENDIF IF ( I .LE. FNO ) THEN WRITE ( WRITUN, 99923 ) EXCL, (FARG(J),J=I,FNO) ENDIF WRITE ( WRITUN, 99902 ) EXCL WRITE ( WRITUN, 99922 ) EXCL, SCALE WRITE ( WRITUN, 99920 ) EXCL, FACTOR WRITE ( WRITUN, 99902 ) EXCL WRITE ( WRITUN, 99901 ) BPLUS ENDIF C --- WRITE APPROPRIATE DATA TO SUMMUN. IF ( KEEPSM ) THEN WRITE ( SUMMUN, * ) ' ''',PRNAME,''' ', - PROB, ' ''',FNAME,''' ', FUNC, N ENDIF C ==> BLOCK II (C) ----READ AND PRINT SPECIAL USER DATA ADDED AT START. GOTO ( 3100, 3200 ) SUBR 3100 GOTO 4000 3200 GOTO 4000 C ==> BLOCK II (D) ----READ AND ECHO THE DATA GENERATED DURING THE RUN. 4000 CONTINUE READ ( TEMPUN, '(A1,A78)', END=9000 ) CH, CHARS IF ( CH .NE. TESTCH ) THEN IF ( WRITFL ) THEN WRITE ( WRITUN, '(A1,A78)' ) CH, CHARS ENDIF GOTO 4000 ENDIF C ==> BLOCK II (E) ----READ STATISTICS FOR THIS PROBLEM. READ ( TEMPUN, * , END=9000 ) ITCT, FUNCCT, GRADCT, DF, DX, - SOLNX,SOLNF, F, GSQ, MING, MAXG, TMIN, TFUN, TPRINT, ERFLAG TMIN = TMIN - TPRINT IF ( KEEPSM ) THEN WRITE ( SUMMUN, * ) ITCT, FUNCCT, GRADCT, DF, DX, SOLNX,SOLNF, - F, GSQ, MING, MAXG, TMIN, TFUN, TPRINT, ERFLAG ENDIF C ==> BLOCK II (F) -----READ DERIVATIVE TESTING STATISTICS. IF ( DERV .EQ. CTEST .OR. DERV .EQ. CFIRST ) THEN READ ( TEMPUN, *, END = 9000 ) MXERR, INDEX, GCNT, DIGS IF ( ABS(MXERR) .GT. ABS(CUMERR) ) THEN CUMERR = MXERR AVDIGS = DIGS WCHG = GCNT GINDX = INDEX BDPROB = PROB ENDIF ENDIF C ==> BLOCK II (G) ----READ USER STATISTICS. GOTO ( 6100, 6200 ) SUBR C ---STATS FOR BBLNIR. 6100 READ ( TEMPUN, * , END=9000 ) CNTRST, NUPS, FORCES IF ( KEEPSM ) THEN WRITE ( SUMMUN, * ) CNTRST, NUPS, FORCES ENDIF GOTO 7000 C ---STATS FOR CONMIN. 6200 GOTO 7000 C ----PRINT STATISTICS OF THE RUN, INCLUDING THOSE OF THE USER. 7000 IF ( WRITFL ) THEN WRITE ( WRITUN, 99997 ) WRITE ( WRITUN, 99901 ) BPLUS WRITE ( WRITUN, 99902 ) EXCL IF ( ERFLAG .NE. 0 ) THEN WRITE ( WRITUN, 99931 ) EXCL ELSE WRITE ( WRITUN, 99932 ) EXCL ENDIF WRITE ( WRITUN, 99902 ) EXCL WRITE ( WRITUN, 99901 ) BPLUS WRITE ( WRITUN, 99902 ) EXCL WRITE ( WRITUN, 99933 ) EXCL WRITE ( WRITUN, 99902 ) EXCL WRITE ( WRITUN, 99934 ) EXCL WRITE ( WRITUN, 99935 ) EXCL, - PROB, FUNC, PRNAME, N, ITCT, - FUNCCT, GRADCT, F, GSQ, TMIN, - TFUN, ERFLAG, NUPS, CNTRST, FORCES WRITE ( WRITUN, 99902 ) EXCL WRITE ( WRITUN, 99901 ) BPLUS IF ( DERV .EQ. CTEST .OR. DERV .EQ. CFIRST ) THEN WRITE ( WRITUN, 99902 ) EXCL WRITE ( WRITUN, 99946 ) EXCL WRITE ( WRITUN, 99902 ) EXCL WRITE ( WRITUN, 99947 ) EXCL WRITE ( WRITUN, 99948 ) EXCL,MXERR,DIGS,INDEX,GCNT WRITE ( WRITUN, 99902 ) EXCL WRITE ( WRITUN, 99901 ) BPLUS ENDIF ENDIF C ----UPDATE CUMULATIVES. CUMITS = CUMITS + ITCT CUMFNS = CUMFNS + FUNCCT CUMGRS = CUMGRS + GRADCT CUMMTM = CUMMTM + TMIN CUMFTM = CUMFTM + TFUN CUMPTM = CUMPTM + TPRINT IF ( ERFLAG .NE. 0 ) THEN ERRCNT = ERRCNT + 1 ENDIF GOTO 1500 9000 IF ( WRITFL .OR. SUMM ) THEN WRITE ( WRITUN, 99998 ) ENDIF IF ( TRMSUM ) THEN WRITE ( RPSOUT, 99998 ) IF ( COPY ) THEN WRITE ( COPYUN, 99998 ) ENDIF ENDIF PRCT = PRCT - 1 GOTO 10000 C================END OF PROBLEM LOOP. C-----PUT SUMMARY DATA ON WRITUN AND/OR ON TERMINAL, AS DESIRED. 10000 IF ( .NOT. KEEPSM ) THEN GOTO 90000 ENDIF TRMCPY = RPSOUT 10005 CONTINUE REWIND SUMMUN BLOCK = 0 10010 CONTINUE BLOCK = BLOCK + 1 READ ( SUMMUN, '(3E24.18)', END = 12000 ) ACC, FACTOR, USER 10012 IF ( ONFILE ) THEN C ---HEADER ON WRITUN UNIT = WRITUN ASSIGN 10100 TO RETRN1 GOTO REMOT1 ENDIF C ---SUMMARY HEADER ON TERMINAL IF DESIRED. 10100 IF ( ONTERM .AND. BLOCK .EQ. 1 ) THEN IF ( SEELEV .EQ. CFULL ) THEN UNIT = TRMCPY ASSIGN 10200 TO RETRN1 GOTO REMOT1 ELSE IF ( SEELEV .EQ. CMED ) THEN WRITE ( TRMCPY, 99821 ) TITLE, DATLIN, NORM, CNORM(NORM), - (CTYPE(I),QUITS(I:I),I=1,NQUITS),RELF,RELG, - DERV,CDERV(DERV),MEMORY, SUBR, SUBNAM, ACC, - FACTOR WRITE ( TRMCPY, 99814) DO 10150 JS=1,NU,3 JE = MIN ( NU, JS+2 ) WRITE ( TRMCPY, 99813 ) - (KEY(MAP(NBASIC+I)*8-7:MAP(NBASIC+I)*8),USER(I),I=JS,JE) 10150 CONTINUE ENDIF ENDIF 10200 IF ( ONFILE ) THEN C ---ADD 'SUMMARY OF RUN' AND PROBLEM DESCRIPTION C ---LINE TO SUMMARY HEADER. UNIT = WRITUN ASSIGN 10300 TO RETRN2 GOTO REMOT2 ENDIF C ---DO THE SAME FOR THE TERMINAL. 10300 IF ( ONTERM ) THEN IF ( SEELEV .EQ. CFULL ) THEN UNIT = TRMCPY ASSIGN 10400 TO RETRN2 GOTO REMOT2 ELSE IF ( SEELEV .EQ. CMED ) THEN WRITE ( TRMCPY, 99841 ) ELSE IF ( SEELEV .EQ. CMIN ) THEN IF ( .NOT. LONGF ) THEN WRITE ( TRMCPY, 99741 ) ELSE WRITE ( TRMCPY, 99747 ) ENDIF ENDIF ENDIF 10400 DO 11000 I = 1, PRCT C ---READ DATA FOR EACH PROBLEM. READ ( SUMMUN, * ) PRNAME, PROB, FNAME, FUNC, N, - ITCT, FUNCCT, GRADCT, DF, DX, SOLNX, - SOLNF, F, GSQ, MING , MAXG, - TMIN, TFUN, TPRINT, ERFLAG GOTO ( 10500, 10600 ) SUBR 10500 READ (SUMMUN, * ) CNTRST, NUPS, FORCES GOTO 10700 10600 GOTO 10700 10700 IF ( ONFILE ) THEN C ---WRITE PROBLEM STATISTICS ON WRITUN. WRITE ( WRITUN, 99935 ) EXCL(1:2), - PROB, FUNC, PRNAME, N, ITCT, - FUNCCT, GRADCT, F, GSQ, TMIN, - TFUN, ERFLAG, NUPS, CNTRST,FORCES ENDIF IF ( ONTERM ) THEN IF ( SEELEV .EQ. CFULL ) THEN WRITE ( TRMCPY, 99935 ) EXCL(TINDX:2), - PROB, FUNC, PRNAME, N, ITCT, - FUNCCT, GRADCT, F, GSQ, TMIN, - TFUN, ERFLAG, NUPS, CNTRST,FORCES ELSE IF ( SEELEV .EQ. CMED ) THEN WRITE ( TRMCPY, 99842 ) PROB, FUNC, PRNAME, N, ITCT, - FUNCCT, GRADCT, F, GSQ, TMIN, - TFUN, ERFLAG, NUPS, CNTRST,FORCES ELSE IF ( SEELEV .EQ. CMIN ) THEN IF ( .NOT. LONGF ) THEN WRITE ( TRMCPY, 99742 ) PROB, ITCT, - FUNCCT, GRADCT, F, GSQ, ERFLAG ELSE WRITE ( TRMCPY, 99746 ) PRNAME, ITCT, FUNCCT, F, - GSQ, MING, DX, SOLNX, ERFLAG ENDIF ENDIF ENDIF 11000 CONTINUE READ (SUMMUN,*) CUMITS,CUMFNS,CUMGRS,ERRCNT,CUMERR, - AVDIGS,WCHG, GINDX, BDPROB,CUMFTM, - CUMMTM,CUMPTM IF ( CUMITS .NE. 0 ) THEN RATIO = (RD(CUMFNS)-1) / RD(CUMITS) ELSE RATIO = ZERO ENDIF IF ( ONFILE ) THEN C ---WRITE CUMULATIVE STATISTICS ON WRITUN. UNIT = WRITUN ASSIGN 11200 TO RETRN3 GOTO REMOT3 ENDIF 11200 IF ( ONTERM ) THEN IF ( SEELEV .EQ. CFULL ) THEN UNIT = TRMCPY ASSIGN 11300 TO RETRN3 GOTO REMOT3 ELSE IF ( SEELEV .EQ. CMED ) THEN WRITE ( TRMCPY, 99844 ) CUMITS, CUMFNS, CUMGRS, RATIO, - CUMMTM, CUMFTM IF ( DERV .EQ. CTEST .OR. DERV .EQ. CFIRST ) THEN WRITE ( TRMCPY, 99845 ) CUMERR,AVDIGS,BDPROB,GINDX,WCHG ENDIF WRITE ( TRMCPY, 99843 ) ERRCNT ELSE IF ( SEELEV .EQ. CMIN ) THEN WRITE ( TRMCPY, 99744 ) CUMITS,CUMFNS,CUMGRS,RATIO,PRCT IF ( DERV .EQ. CTEST .OR. DERV .EQ. CFIRST ) THEN WRITE ( TRMCPY, 99745 ) CUMERR,AVDIGS,BDPROB,GINDX,WCHG ENDIF WRITE ( TRMCPY, 99743 ) ERRCNT ENDIF ENDIF 11300 CONTINUE GOTO 10010 12000 IF ( COPY .AND. TRMCPY .EQ. TRMOUT ) THEN TRMCPY = COPYUN ONFILE = .FALSE. GOTO 10005 ENDIF GOTO 90000 C## R E M O T E B L O C K 1: C WRITE COMPLETE DESCRIPTION OF A RUN C IN FULL FORMAT. 81000 IF ( UNIT .EQ. TRMOUT .AND. SYSCC .EQ. CCMISS ) THEN FINDX = 2 WRITE ( UNIT, ' (///)' ) ELSE FINDX = 1 WRITE ( UNIT, ' (''1'')' ) ENDIF WRITE ( UNIT, 99901 ) BPLUS(FINDX:2) WRITE ( UNIT, 99902 ) EXCL(FINDX:2) WRITE ( UNIT, 99903 ) EXCL(FINDX:2), CENTIT WRITE ( UNIT, 99902 ) EXCL(FINDX:2) WRITE ( UNIT, 99903 ) EXCL(FINDX:2), CENDAT WRITE ( UNIT, 99902 ) EXCL(FINDX:2) WRITE ( UNIT, 99901 ) BPLUS(FINDX:2) WRITE ( UNIT, 99902 ) EXCL(FINDX:2) WRITE ( UNIT, 99904 ) EXCL(FINDX:2), NORM, CNORM(NORM) WRITE ( UNIT, 99905 ) EXCL(FINDX:2), CTYPE(1),QUITS(1:1) DO 81100 I = 2,NQUITS WRITE ( UNIT, 99911 ) EXCL(FINDX:2), CTYPE(I),QUITS(I:I) 81100 CONTINUE WRITE ( UNIT, 99912 ) EXCL(FINDX:2), 'F', RELF WRITE ( UNIT, 99912 ) EXCL(FINDX:2), 'G', RELG WRITE ( UNIT, 99906 ) EXCL(FINDX:2), DERV, CDERV(DERV) WRITE ( UNIT, 99907 ) EXCL(FINDX:2), MEMORY WRITE ( UNIT, 99908 ) EXCL(FINDX:2), SUBR, SUBNAM WRITE ( UNIT, 99902 ) EXCL(FINDX:2) WRITE ( UNIT, 99902 ) EXCL(FINDX:2) WRITE ( UNIT, 99909 ) EXCL(FINDX:2), ACC WRITE ( UNIT, 99902 ) EXCL(FINDX:2) WRITE ( UNIT, 99914 ) EXCL(FINDX:2), FACTOR WRITE ( UNIT, 99902 ) EXCL(FINDX:2) C ---WRITE USER PARAMETER ARRAY. WRITE ( UNIT, 99925 ) EXCL(FINDX:2) DO 1600 JS=1,NU,3 JE = MIN ( NU, JS+2 ) WRITE ( UNIT, 99926 ) EXCL(FINDX:2), - ( KEY (MAP(NBASIC+I)*8-7:MAP(NBASIC+I)*8),USER(I),I=JS,JE ) 1600 CONTINUE WRITE ( UNIT, 99902 ) EXCL(FINDX:2) WRITE ( UNIT, 99901 ) BPLUS(FINDX:2) GOTO RETRN1 C## R E M O T E B L O C K 2: C WRITE HEADER FOR ALL PROBLEMS IN RUN C SECTION, TO BE FOLLOWED BY EACH PROBELM, C IN FULL FORMAT. 82000 IF ( UNIT .EQ. TRMOUT .AND. SYSCC .EQ. CCMISS ) THEN FINDX = 2 ELSE FINDX = 1 ENDIF WRITE ( UNIT, 99902 ) EXCL(FINDX:2) WRITE ( UNIT, 99941 ) EXCL(FINDX:2) WRITE ( UNIT, 99902 ) EXCL(FINDX:2) WRITE ( UNIT, 99901 ) BPLUS(FINDX:2) WRITE ( UNIT, 99902 ) EXCL(FINDX:2) WRITE ( UNIT, 99934 ) EXCL(FINDX:2) GOTO RETRN2 C## R E M O T E B L O C K 3: C WRITE CUMULATIVE STATISTICS IN FULL FORMAT. 83000 IF ( UNIT .EQ. TRMOUT .AND. SYSCC .EQ. CCMISS ) THEN FINDX = 2 ELSE FINDX = 1 ENDIF WRITE ( UNIT, 99902 ) EXCL(FINDX:2) WRITE ( UNIT, 99942 ) EXCL(FINDX:2) WRITE ( UNIT, 99945 ) EXCL(FINDX:2), - CUMITS, CUMFNS, CUMGRS, RATIO, CUMMTM, CUMFTM WRITE ( UNIT, 99902 ) EXCL(FINDX:2) IF ( ERRCNT .EQ. 0 ) THEN WRITE ( UNIT, 99943 ) EXCL(FINDX:2) ELSE WRITE ( UNIT, 99944 ) EXCL(FINDX:2), ERRCNT ENDIF WRITE ( UNIT, 99902 ) EXCL(FINDX:2) WRITE ( UNIT, 99901 ) BPLUS(FINDX:2) IF ( DERV .EQ. CTEST .OR. DERV .EQ. CFIRST ) THEN WRITE ( UNIT, 99902 ) EXCL(FINDX:2) WRITE ( UNIT, 99946 ) EXCL(FINDX:2) WRITE ( UNIT, 99902 ) EXCL(FINDX:2) WRITE ( UNIT, 99949 ) EXCL(FINDX:2) WRITE ( UNIT, 99950 ) EXCL(FINDX:2), CUMERR, AVDIGS, - BDPROB, GINDX, WCHG WRITE ( UNIT, 99902 ) EXCL(FINDX:2) WRITE ( UNIT, 99901 ) BPLUS(FINDX:2) ENDIF GOTO RETRN3 C## E X I T 90000 CONTINUE RETURN 91000 RETURN 1 C## F O R M A T S: C-----FORMATS FOR MINIMUM TERMINAL SUMMARY. 99741 FORMAT ( ' PROB #_IT #_FNC #_GRD FUNCTION GRADIENT ER' ) 99742 FORMAT ( I5, 2X, 3I6, 2E10.2, I3 ) 99743 FORMAT ( / I3, ' ERRORS' ) 99744 FORMAT ( ' TOTALS:', I5, 2I6, '; RATIO=', F4.2,'; #PRBS=',I3 ) 99745 FORMAT ( ' GRAD TEST: ', E10.3, F6.3, 3I6 ) 99746 FORMAT ( 1X, A8, 2I4, G24.17, 3G9.2, I3, I3 ) 99747 FORMAT ( ' NAME #IT #FN',6X,'FUNCTION',1X, - ' (GRADIENT->NORM MIN ) DX #X ER') C-----FORMATS FOR MEDIUM TERMINAL SUMMARY. 99813 FORMAT ( 1X, 3 ( A8, ' =', D10.3, 3X ) ) 99814 FORMAT ( ' USER PARAMETER VALUES:' ) 99821 FORMAT ( 1X, A70 / 1X, A70 / - ' NORM= ', I2, 1X,'(', A10,')' / - ' TERMINATION TESTS ON: ',/ - 3X, 4(A10,'->',A1,'; ')/ - ' RELATIVE TEST ON F IS ',L1,'; RELATIVE TEST ON G IS ',L1/ - ' DERV= ', I2, 1X, '(', A10,')' / - ' MEMORY:', I6, ' REAL VALUES;', C!!!!- ' MEMORY:', I6, ' D.P. VALUES;', - ' SUBROUTINE: ',I2,' (',A8,' ); ACCURACY = ',E10.3/ - ' FACTOR: ', G12.5 ) 99841 FORMAT ( / ' RUN SUMMARY' / - ' PR# FN# NAME DIM ITS FNS GRS FVALUE ', - ' GVALUE MSECS FSECS ER NUP RST FRC' ) 99842 FORMAT ( 1X,I3,I3,1X,A8,I3,I4,2I4,E9.2,E9.2,2F7.3,I3, 3I4) 99843 FORMAT ( / 1X, I3, ' PROBLEMS WERE FLAGGED WITH ERRORS.' ) 99844 FORMAT ( ' TOTALS:',4X,3I4,' (RATIO ',F6.2,')',2X,2F7.3 ) 99845 FORMAT ( ' GRADIENT TEST: CUMERR AVDIGS BADPROB CMP INDX' / - 12X, E10.3, F7.3, 2X, I3, 2X, I4, 1X, I4 ) C-----FORMATS FOR THE FULL (FANCY) OUTPUT. 99901 FORMAT ( A, 76('-'), '+' ) 99902 FORMAT ( A , 76 X, '!' ) 99903 FORMAT ( A , A69 , 7X, '!' ) 99904 FORMAT ( A, 18X, 'TERMINATION NORM = ', I2, - ' (',A10, ')', 24X, '!' ) 99905 FORMAT ( A, 30X, 'TESTS: ', A10, '->',A1,26X, '!' ) 99906 FORMAT ( A, 18X, 'DERIVATIVE MODE = ', I2, - ' (',A10, ')', 24X, '!' ) 99907 FORMAT ( A, 18X, 'STORAGE USE IS ', I6, - ' SINGLE PRECISION REALS.', 13X, '!' ) C!!!!- ' DOUBLE PRECISION REALS.', 13X, '!' ) 99908 FORMAT ( A, 18X, 'SUBROUTINE IN USE IS ', I2, - ' (', A8, ')', 24X, '!' ) 99909 FORMAT ( A, 3X, 'ACCURACY REQUIRED IS ', E13.3, 39X, '!' ) 99910 FORMAT ( A, 7 ( A8, 2X ), A8, '!' ) 99911 FORMAT ( A, 37X, A10, '->',A1,26X, '!' ) 99912 FORMAT ( A, 29X, 'RELATIVE TEST ON ',A1,'->',L1,26X,'!' ) 99913 FORMAT ( A, - E9.3, 6 ( E10.3 ), E9.3, '!' ) C!!!!- E9.3, 7 ( D10.3 ), E9.3, '!' ) 99914 FORMAT ( A, 3X, 'EXPENSE FACTOR USED ', E13.3, 39X, '!' ) 99920 FORMAT ( A, 1X,'STARTING POINT FACTOR ', E13.3, 40X, '!' ) 99921 FORMAT ( A,3X,'FUNCTION ARGUMENTS ARE ', 50X,'!') 99922 FORMAT ( A,3X,'FUNCTION SCALING IS NUMBER ',I5, 41X, '!' ) 99923 FORMAT ( A,3X,' ',5E12.3, 2X, '!' ) 99925 FORMAT ( A, 3X, 'USER PARAMETERS :', 56X, '!' ) 99926 FORMAT ( A, 6X, 3 ( A8, ' =', D10.3, 3X ), 1X, '!' ) 99927 FORMAT ( A,3X,'PROBLEM NAME ( NUMBER ) :',A12,'(',I3,' )',30X,'!') 99931 FORMAT ( A, 16X, 'CAUTION: AN ERROR WAS FLAGGED ', - 'DURING THIS RUN', 15X, '!' ) 99932 FORMAT ( A, 16X, 'A CORRECT SOLUTION APPEARS TO ', - 'HAVE BEEN FOUND', 15X, '!' ) 99933 FORMAT ( A, 17X, 'S U M M A R Y O F T H E ', - 'P R O B L E M', 16X, '!' ) 99934 FORMAT (A, 'PR# FN# NAME DIM ITS FNS GRS ', - 'FVALUE GVALUE MSECS FSECS ER NUP RST FRC', '!' ) 99935 FORMAT ( A, I3, I3, 1X, A8, I3, I4, I4, I4, - E9.2, E8.2, F7.3, F7.3, I2, I4, I4 , I4, '!' ) C!!!!- D9.2, D9.2, F7.3, F7.3, I2, I4, I4 , I4, '!' ) 99941 FORMAT ( A, 15X, 'S U M M A R Y O F T H E ', - 'E N T I R E R U N', 12X, '!' ) 99942 FORMAT ( A, 18X, 'ITERS FUNCS GRADS RATIO', 12X, - 'MSECS FSECS', 11X, '!' ) 99943 FORMAT ( A, 16X, 'NONE OF THE PROBLEMS WERE ', - 'FLAGGED WITH ERRORS.', 14X, '!' ) 99944 FORMAT ( A, 17X, 'THERE WERE ', I3, ' PROBLEMS ', - 'FLAGGED WITH ERRORS.', 15X, '!' ) 99945 FORMAT (A, ' TOTALS', 11X, I5, I6, I6, F6.2, 9X, - F8.3, F7.3 , 11X, '!' ) 99946 FORMAT ( A, 23X, 'G R A D I E N T ', - ' T E S T I N G' , 22X, '!' ) 99947 FORMAT ( A, 16X, 'WORST ERROR AVERAGE DIGITS', - ' COMPONENT COUNT', 14X, '!' ) 99948 FORMAT ( A, 16X, E9.2, 5X, F9.2, - 6X, I5, 5X, I5 , 16X, '!' ) 99949 FORMAT ( A, 16X, 'WORST ERROR AVERAGE DIGITS', - ' PROBLEM COMPONENT COUNT', 7X, '!' ) 99950 FORMAT ( A, 16X, E9.2, 5X, F9.2, - 5X, I5, 4X, I5, 4X, I5, 9X, '!' ) C----- FORMATS FOR READING AND PAGE FEEDS. 99996 FORMAT ( A1 ) 99997 FORMAT ( ' ' ) 99998 FORMAT ( ' UNEXPECTED END OF FILE WITHIN PROBLEM.' ) 99999 FORMAT ( ' END OF FILE MARKS END OF PROBLEMS' ) C## E N D OF ZZSMRY. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> solnsg.f SUBROUTINE ZZSOLN ( IX, N, SOLN, X ) C## A R G U M E N T S: INTEGER IX, N REAL X(N), SOLN(*) C!!!! DOUBLE PRECISION X(N), SOLN(*) C## S T A T U S: C IGNORE LINES BEGINNING WITH "C!!!!" . C C SYSTEM DEPENDENCE: NONE. C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C>RCS $HEADER: SOLN.F,V 2.1 91/11/20 10:53:07 BUCKLEY EXP $ C>RCS $LOG: SOLN.F,V $ C>RCS REVISION 2.1 91/11/20 10:53:07 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 2.0 90/07/31 11:34:22 BUCKLEY C>RCS MINOR MOD TO USE BLAS C>RCS C>RCS REVISION 1.9 89/06/30 13:39:51 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 16:42:58 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 12:20:51 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 21:00:03 BUCKLEY C>RCS RECREATING INITIAL DEPOSIT FOR MT RCS. C>RCS C>RCS C## D E S C R I P T I O N: C C COMPUTE STANDARD SOLUTIONS FOR TEST FUNCTIONS AND PUT INTO X. C THE SOLUTION IS DEFINED ACCORDING TO THE CODE IX. C C IF IX = 0, X(I) ARE DEFINED ON ENTRY FOR I=1,...,N. C ( THIS IS EQUIVALENT TO SPECIFYING IX = N. ) C IF IX > 0, A CYCLE IS DEFINED AND MUST BE EXPANDED. C IF IX < 0 ON ENTRY, THEN A SELECTED FORMULA IS USED TO C COMPUTE VALUES FOR THE COMPONENTS OF X. C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZSOLN. C## S U B R O U T I N E S: NONE ARE CALLED. C REAL(DBLE) ... INTRINSIC C ABS ... INTRINSIC C MOD ... INTRINSIC C RD ... A STATEMENT FUNCTION FOR CONVERSION FROM INTEGER C## P A R A M E T E R S: REAL ZERO, ONE, TWO, THREE C!!!! DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) REAL FOUR, FIVE, SIX, SEVEN C!!!! DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) REAL EIGHT, NINE, TEN C!!!! DOUBLE PRECISION EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 9D0, TEN = 10D0 ) REAL TENTH, FIFTH, HALF C!!!! DOUBLE PRECISION TENTH, FIFTH, HALF PARAMETER ( TENTH = .1D0, FIFTH = .2D0, HALF = .5D0 ) REAL RPT9, RPT8, RD29 C!!!! DOUBLE PRECISION RPT9, RPT8, RD29 PARAMETER ( RPT9 = .9D0, RPT8 = .8D0, RD29 = 1D0/29D0 ) C## L O C A L D E C L: INTEGER I, K REAL RD C!!!! DOUBLE PRECISION RD C## S A V E: NONE SELECTED. C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NO DATA VALUES SET. C## E X E C U T I O N C## E X E C U T I O N C------ FUNCTION STATEMENT. RD(I) = REAL(I) C!!!! RD(I) = DBLE(I) C----- NOW EXECUTE. IF ( IX .EQ. 0 ) THEN IX = N ENDIF IF ( IX .LT. 0 ) THEN GOTO ( 100 ) , ABS( IX ) C ---SOLUTION 1 : X = (0, 0, . . ., N+1) 100 DO 150 I = 1, N-1 X(I) = ZERO 150 CONTINUE X(N) = RD(N+1) GOTO 10000 ELSE IF ( IX .GT. 0 ) THEN K = IX CALL ZZCOPY ( IX, SOLN, 1, X, 1 ) DO 5000 I = IX+1, N K = MOD ( K, IX ) + 1 X(I) = SOLN(K) 5000 CONTINUE ENDIF 10000 CONTINUE GOTO 90000 C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZSOLN. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> sortsg.f SUBROUTINE ZZSORT ( SORT, LIST, LISTNO, PRECNO, NAMES, KLEN, ASC ) C## A R G U M E N T S: INTEGER SORT, KLEN INTEGER LIST(*), LISTNO, PRECNO(3,*) LOGICAL ASC CHARACTER*(*) NAMES C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NOT REQUIRED. C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: SORT.F,V 1.10 91/11/20 10:53:08 BUCKLEY EXP $ C>RCS $LOG: SORT.F,V $ C>RCS REVISION 1.10 91/11/20 10:53:08 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.9 89/06/30 13:39:52 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 16:42:59 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 12:20:52 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:48:16 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:50:13 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE SORTS THE LIST OF PROBLEMS, NAMELY LIST, ACCORDING C TO ONE OF SEVERAL POSSIBILITIES. THE METHOD IS BASICALLY THAT C OF QUICK SORT DUE TO HOARE BUT AS MODIFIED BY RICHARD C C. SINGLETON ( REF. ALGORITHM 347, CACM ) . C C THERE IS THEREFORE A LIMIT TO THE MAXIMUM SIZE OF ARRAY WHICH C CAN BE SORTED. SPECIFICALLY, LISTNO IS THE NUMBER OF ELEMENTS C IN THE LIST TO BE SORTED, AND ON ENTRY YOU MUST HAVE C C LISTNO < 2**(SIZE+1). C C IN THE CURRENT VERSION, SIZE = 12, SO UP TO 2**13 - 1= 8095 C ENTRIES MAY BE IN THE LIST TO SORT. THAT SHOULD BE ENOUGH C FOR HERE! SIZE IS A PARAMETER GIVEN BELOW. C C THE ARGUMENTS ARE THE FOLLOWING: C C SORT SORT CODE; SEE BELOW. C C LIST THE ARRAY OF ENTRIES TO BE SORTED. C LISTNO THE NUMBER OF ELEMENTS IN LIST. C C PRECNO AN ARRAY GIVING THE RECORD NUMBER OF EACH PROBLEM IN C THE DIRECT ACCESS FILE. THERE ARE THREE ENTRIES FOR C EACH PROBLEM, ITS RECORD NUMBER, ITS DIMENSION AND C THE FUNCTION NUMBER USED BY THE PROBLEM. C NAMES A CHARACTER STRING GIVING THE NAME OF EACH PROBLEM C AND THE NAME OF THE FUNCTION USED BY THE PROBLEM. C KLEN THE LENGTH OF EACH NAME IN THE STRING NAMES. C ASC THE SORT IS IN ASCENDING ORDER IF THIS FLAG IS TRUE; C OTHERWISE IT IS DESCENDING. C C THE SORT CODES ARE THE FOLLOWING. C C SPRNAM BY PROBLEM NAME. C SPRNUM BY PROBLEM NUMBER. C SRECNO BY RECORD NUMBER OF THE PROBLEM IN THE DAUF FILE C (SAME AS ORDER IN THE PROLOG FILE). C SDIMN BY THE (FIRST) DIMENSION OF THE PROBLEM. C SFNNAM BY THE NAME OF THE FUNCTION USED WITH EACH PROBLEM. C SFNNUM BY THE NUMBER OF THE FUNCTION USED WITH EACH PROBLEM. C SASIS NO SORT; THE ORDER IS LEFT AS IS. C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZSORT. C C## S U B R O U T I N E S: C C LLT ... INTRINSIC C LOC A STATEMENT FUNCTION LOCATION IN NAMES ARRAY. C COMPRA A STATEMENT FUNCTION FOR COMPARISON. C COMPRD A STATEMENT FUNCTION FOR COMPARISON. C COMPAR A STATEMENT FUNCTION FOR COMPARISON. C C## P A R A M E T E R S: C----- TO LIMIT THE SIZE OF SORTS. INTEGER SIZE PARAMETER ( SIZE = 12 ) C----- DEFINE THE POSITIONS IN PRECNO. C DEFINITIONS OF THE ROWS IN THE ARRAY PRECNO. ( PRECNO HOLDS THE C RECORD NUMBER IN THE DAUF FILE, THE MINIMUM DIMENSION, AND THE C FUNCTION NUMBER OF EACH PROBLEM. ) INTEGER RECN, DIMN, FNO1 PARAMETER ( RECN = 1, DIMN = 2, FNO1 = 3 ) C----- DEFINE THE TYPES OF SORTS. INTEGER INDEX, NUMERC, CHARAC PARAMETER ( INDEX = 1, NUMERC = 2, CHARAC = 3 ) C----- DEFINE CODES FOR SORTING INTEGER SPRNAM, SPRNUM, SASIS, SRECNO PARAMETER ( SPRNAM = 1, SPRNUM = 2, SASIS = 3, SRECNO = 4 ) INTEGER SFNNAM, SFNNUM, SDIMN, SPROLG PARAMETER ( SFNNAM = 5, SFNNUM = 6, SDIMN = 7, SPROLG = 8 ) C## L O C A L D E C L: C-----LOCAL VARIABLES. INTEGER I, II, IJ, J, K, L, M, PROBI, PROBJ, PROBK, ROW INTEGER PROBL, PROBT, PROBTT, TEMP, TYPE, K1, LOC, BASE LOGICAL COMPAR, COMPRA, COMPRD C-----THE DIMENSION OF THE FOLLOWING MAY NEED UPPER ADJUSTMENT IF C-----THE NUMBER OF PROBLEMS INCREASES. SEE THE ABOVE DESCRIPTION C-----AND THE PARAMETER SIZE. INTEGER IL(0:SIZE-1), IU(0:SIZE-1) C## S A V E: SAVE ROW, BASE, TYPE, K1 C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NONE ARE SET. C## E X E C U T I O N C## E X E C U T I O N C--------- STATEMENT FUNCTION DEFINITIONS. LOC(I) = BASE + (I-1)*2*KLEN + 1 COMPRA (I,J) = - TYPE .EQ. NUMERC .AND. PRECNO(ROW,I) .LT. PRECNO(ROW,J) - .OR. TYPE .EQ. INDEX .AND. I .LT. J - .OR. TYPE .EQ. CHARAC .AND. LLT( NAMES(LOC(I):LOC(I)+K1), - NAMES(LOC(J):LOC(J)+K1) ) COMPRD (I,J) = - TYPE .EQ. NUMERC .AND. PRECNO(ROW,I) .GT. PRECNO(ROW,J) - .OR. TYPE .EQ. INDEX .AND. I .GT. J - .OR. TYPE .EQ. CHARAC .AND. LGT( NAMES(LOC(I):LOC(I)+K1), - NAMES(LOC(J):LOC(J)+K1) ) COMPAR(I,J)=ASC .AND. COMPRA(I,J) .OR. .NOT. ASC .AND. COMPRD(I,J) C-----IF THE SORT IS AS IS, DO NOTHING. IF ( SORT .EQ. SASIS ) THEN GO TO 90000 ELSE IF ( LISTNO .GE. 2**(SIZE+1) ) THEN STOP 'TOO MANY TO SORT! IN ZZSORT' ENDIF K1 = KLEN - 1 BASE = 0 ROW = 1 IF ( SORT .EQ. SPRNAM ) THEN BASE = 0 TYPE = CHARAC ELSE IF ( SORT .EQ. SFNNAM ) THEN BASE = KLEN TYPE = CHARAC ELSE IF ( SORT .EQ. SPRNUM ) THEN TYPE = INDEX ELSE IF ( SORT .EQ. SRECNO .OR. SORT .EQ. SPROLG ) THEN TYPE = NUMERC ROW = RECN ELSE IF ( SORT .EQ. SFNNUM ) THEN TYPE = NUMERC ROW = FNO1 ELSE IF ( SORT .EQ. SDIMN ) THEN TYPE = NUMERC ROW = DIMN ENDIF ENDIF C-----OTHERWISE, SORT IN THE MANNER DESIRED. M = 0 I = 1 II = 1 J = LISTNO GO TO 400 100 IJ = ( I + J ) / 2 K = I L = J PROBT = LIST(IJ) PROBI = LIST(I ) PROBJ = LIST( J) IF ( COMPAR ( PROBT, PROBI ) ) THEN LIST(IJ) = PROBI LIST(I ) = PROBT TEMP = PROBT PROBT = PROBI PROBI = TEMP ENDIF IF ( COMPAR ( PROBJ, PROBT ) ) THEN LIST(IJ) = PROBJ LIST( J) = PROBT TEMP = PROBT PROBT = PROBJ PROBJ = TEMP IF ( COMPAR ( PROBT, PROBI ) ) THEN LIST(IJ) = PROBI LIST(I ) = PROBT TEMP = PROBT PROBT = PROBI PROBI = TEMP ENDIF ENDIF 200 L = L - 1 PROBL = LIST(L) IF ( COMPAR ( PROBT, PROBL ) ) THEN GO TO 200 ELSE PROBTT = PROBL ENDIF 300 K = K + 1 PROBK = LIST(K) IF ( COMPAR ( PROBK, PROBT ) ) THEN GO TO 300 ELSEIF ( K .LE. L ) THEN LIST(L) = LIST(K) LIST(K) = PROBTT GO TO 200 ELSEIF ( L - I .GT. J - K ) THEN IL(M) = I IU(M) = L I = K ELSE IL(M) = K IU(M) = J J = L ENDIF M = M + 1 400 IF ( J - I .GT. 10 ) THEN GO TO 100 ELSEIF ( I .EQ. II ) THEN IF ( I .LT. J ) THEN GO TO 100 ENDIF ENDIF TEMP = I + 1 DO 420 I = TEMP, J PROBT = LIST(I) K = I - 1 PROBK = LIST(K) IF ( COMPAR ( PROBT, PROBK ) ) THEN 410 LIST(K + 1) = LIST(K) K = K - 1 PROBK = LIST(K) IF ( COMPAR ( PROBT, PROBK ) ) THEN GO TO 410 ELSE LIST(K + 1) = PROBT ENDIF ENDIF 420 CONTINUE M = M - 1 IF ( M .GE. 0 ) THEN I = IL(M) J = IU(M) GO TO 400 ENDIF GO TO 90000 C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZSORT. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> srchsg.f SUBROUTINE ZZSRCH (STRING,ISTRLN,DICT,DICTLN,KEYLEN,NUMBER, - SORTED,UPCASE ) C## A R G U M E N T S: INTEGER DICTLN, NUMBER, ISTRLN, KEYLEN CHARACTER*(*) STRING, DICT LOGICAL SORTED, UPCASE C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NOT REQUIRED. C SYSTEM DEPENDENCE: NONE. C C>RCS $HEADER: SRCH.F,V 1.10 91/11/20 10:53:09 BUCKLEY EXP $ C>RCS $LOG: SRCH.F,V $ C>RCS REVISION 1.10 91/11/20 10:53:09 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 1.9 89/06/30 13:39:53 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 16:43:00 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 12:20:53 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:48:19 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:50:14 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE SEARCHES A DICTIONARY DICT OF KEYWORDS FOR C A SPECIFIC ENTRY GIVEN AS STRING. WE HAVE THE FOLLOWING. C C ON ENTRY: C C STRING THE STRING TO SEARCH FOR. C C ISTRLN ABS(ISTRLN) CHARACTERS OF STRING ARE USED IN THE C COMPARISON. IF ABS(ISTRLN) IS >= LEN(STRING), THE C FULL STRING IS USED. IF THE STRING TO COMPARE IS C LARGER THAN THE ENTRIES IN THE DICTIONARY, EXCESS C CHARACTERS ON THE RIGHT ARE IGNORED. C EACH ENTRY OF THE DICTIONARY MAY CONTAIN C EITHER ONE OR TWO PARTS (REFERRED TO AS HALVES SINCE C THE PARTS MUST BE OF EQUAL LENGTH). IF ISTRLN IS C POSITIVE THE COMPARISON IS MADE WITH THE FIRST (OR C ONLY) PART OF EACH ENTRY. IF ISTRLN IS NEGATIVE THEN C THE SECOND HALF OF EACH DICTIONARY ENTRY IS USED IN C THE COMPARISON. C C DICT THE DICTIONARY. NOTE THAT THE KEYWORDS IN THE C DICTIONARY ARE STORED AS A SINGLE (CONCATENATED) C CHARACTER STRING, WITH NO SEPARATION BETWEEN C KEYWORDS. THEY MUST THEREFORE BE OF A FIXED LENGTH. C NOTE ALSO THAT EACH ENTRY MAY ACTUALLY BE COMPRISED C OF TWO PARTS OF EQUAL LENGTH. C C DICTLN THE NUMBER OF ENTRIES IN THE DICTIONARY DICT. C C NUMBER THE ENTRY IN DICT AT WHICH TO START THE SEARCH. C IF FOR EXAMPLE, NUMBER=3, THEN THE SEARCH IS ON C ENTRIES 3,4,...,DICTLN IN THE DICTIONARY. C C SORTED TRUE IF THE DICT IS SORTED IN ALPHABETICAL ORDER C C UPCASE TRUE IF ALL ENTRIES IN THE STRING ARE ALREADY IN C UPPER CASE. C C ON EXIT: C C UNALTERED STRING, ISTRLN, DICT, DICTLN, SORTED C C NUMBER = 0 IF THE SEARCH FAILED TO FIND THE DESIRED STRING. C = K IF ENTRY K IN THE DICTIONARY IS THE FIRST C DICTIONARY ENTRY FOUND TO MATCH THE STRING, C AS LEAST AS FAR AS THE FIRST ISTRLN CHARAC- C TERS ARE CONCERNED. C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZSRCH C## S U B R O U T I N E S: ABS, MIN, MAX, LEN ...INTRINSIC C## P A R A M E T E R S: INTEGER CTOUPP, CTOLOW, CTOCAP PARAMETER ( CTOUPP = 1, CTOLOW = 2, CTOCAP = 3 ) C## L O C A L D E C L: INTEGER I, IS, LENG, K, J, L, OFFSET CHARACTER CH*1 C## S A V E: NONE SELECTED. C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NONE ARE SET. C## E X E C U T I O N C## E X E C U T I O N IF ( ISTRLN .LT. 0 ) THEN OFFSET = KEYLEN / 2 ELSE OFFSET = 0 ENDIF LENG = MIN ( ABS(ISTRLN), KEYLEN, LEN(STRING) ) IS = MAX ( 1,NUMBER ) NUMBER = 0 J = (IS-1) * KEYLEN + 1 + OFFSET C---- USE SIMPLE SEQUENTIAL SEARCH C - NOT LONG ENOUGH FOR BINARY, AND NEED NOT BE SORTED DO 100 K=IS,DICTLN L = J DO 50 I = 1, LENG CH = STRING(I:I) IF ( .NOT. UPCASE ) THEN CALL ZZCASE(CH,CTOUPP) ENDIF IF ( CH .NE. DICT(L:L) ) GOTO 60 L = L + 1 50 CONTINUE NUMBER = K GOTO 90000 60 IF ( SORTED .AND. LLT(CH,DICT(L:L)) ) THEN GOTO 90000 ELSE J = J + KEYLEN ENDIF 100 CONTINUE GOTO 90000 C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZSRCH. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> stx0sg.f SUBROUTINE ZZSTX0 ( IX0, X0, N, FACTOR, TMP, ARGS ) C## A R G U M E N T S: INTEGER IX0, N REAL X0(N), FACTOR, TMP(N), ARGS(*) C!!!! DOUBLE PRECISION X0(N), FACTOR, TMP(N), ARGS(*) C## S T A T U S: C IGNORE LINES BEGINNING WITH "C!!!!" . C C SYSTEM DEPENDENCE: NONE. C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C>RCS $HEADER: STX0.F,V 2.2 91/11/20 10:53:10 BUCKLEY EXP $ C>RCS $LOG: STX0.F,V $ C>RCS REVISION 2.2 91/11/20 10:53:10 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 2.1 90/07/31 11:55:20 BUCKLEY C>RCS REMOVED UNUSED VAR. C>RCS C>RCS REVISION 2.0 90/07/31 11:35:15 BUCKLEY C>RCS MINOR MOD TO USE BLAS C>RCS C>RCS REVISION 1.9 89/06/30 13:41:36 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.1 89/01/17 16:50:14 BUCKLEY C>RCS INITIAL REVISION C>RCS C## D E S C R I P T I O N: C C COMPUTE STANDARD STARTING POINTS FOR TEST FUNCTIONS AND PUT INTO C X0. THE STARTING POINT IS DEFINED ACCORDING TO THE CODE IX0. C SEE THE ROUTINE ZZVECT. C C IF IX0 = 0, X0(I) ARE DEFINED ON ENTRY FOR I=1,...,N. C ( THIS IS EQUIVALENT TO SPECIFYING IX0 = N. ) C IF IX0 > 0, A CYCLE IS DEFINED AND MUST BE EXPANDED. C IF IX0 < 0 ON ENTRY, THEN A SELECTED FORMULA IS USED TO C COMPUTE VALUES FOR THE COMPONENTS OF X0. C C IN ANY CASE, ONCE THE VALUES FOR X0 ARE ESTABLISHED, ALL C COMPONENTS OF X0 ARE THEN MULTIPLIED BY FACTOR (UNLESS OF C COURSE FACTOR = 1). C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZSTX0. C## S U B R O U T I N E S: ZZVECT. C## P A R A M E T E R S: REAL ZERO, ONE, TWO, THREE C!!!! DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) REAL FOUR, FIVE, SIX, SEVEN C!!!! DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) REAL EIGHT, NINE, TEN C!!!! DOUBLE PRECISION EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 9D0, TEN = 10D0 ) C## L O C A L D E C L: NONE ARE DEFINED. C## S A V E: NONE SELECTED. C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NO DATA VALUES SET. C## E X E C U T I O N C## E X E C U T I O N CALL ZZVECT ( IX0, N, TMP, X0, ARGS ) C-----NOW APPLY FACTOR TO THE STARTING POINT. IF ( FACTOR .NE. ONE ) THEN CALL ZZSCAL ( N, FACTOR, X0, 1 ) ENDIF GOTO 90000 C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZSTX0. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> texsg.f SUBROUTINE ZZTEX (UNIT, NAME, PNO, FVALS, ITERS, FC, DF, FXSTAR, - ACC, GNORM, GMIN, DISTX, CRIT, ERR, FTIME,MTIME) C## A R G U M E N T S: INTEGER UNIT, PNO, FVALS, ITERS, CRIT, ERR,ACC REAL FC, FXSTAR, GNORM, GMIN, DISTX C!!!! DOUBLE PRECISION FC, FXSTAR, GNORM, GMIN, DISTX REAL DF, FTIME, MTIME C!!!! DOUBLE PRECISION DF, FTIME, MTIME CHARACTER *(*) NAME C## S T A T U S: C IGNORE LINES BEGINNING WITH "C!!!!" . C C SYSTEM DEPENDENCE: NONE. C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C>RCS $HEADER: TEX.F,V 2.1 91/11/20 10:53:11 BUCKLEY EXP $ C>RCS $LOG: TEX.F,V $ C>RCS REVISION 2.1 91/11/20 10:53:11 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 2.0 90/07/31 11:37:38 BUCKLEY C>RCS MINOR FORMAT FIX. C>RCS C>RCS REVISION 1.9.1.1 89/07/02 14:36:13 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.9 89/06/30 13:39:54 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 16:43:02 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 12:20:55 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:48:23 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C C## D E S C R I P T I O N: C THIS ROUTINE PRODUCES THE "OUTPUT" FILE OF COMPUTED SOLUTIONS C FOR EACH TEST FUNCTION. C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZTEX. C## S U B R O U T I N E S: NONE ARE CALLED. C## P A R A M E T E R S: NONE ARE DEFINED. LOGICAL T, F PARAMETER ( T = .TRUE., F = .FALSE. ) CHARACTER*(*) TRUE, QT, FALSE, QF PARAMETER ( TRUE = 'TRUE', QT = 'T', FALSE = 'FALSE', QF = 'F' ) INTEGER ITRUE, IFALSE PARAMETER ( ITRUE = 1, IFALSE = 0 ) REAL RTRUE, RFALSE C!!!! DOUBLE PRECISION RTRUE, RFALSE PARAMETER ( RTRUE = 1.D0, RFALSE = 0.D0 ) INTEGER CTOUPP, CTOLOW, CTOCAP PARAMETER ( CTOUPP = 1, CTOLOW = 2, CTOCAP = 3 ) CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) CHARACTER*(*) PERIOD, COMMA, SEMICN PARAMETER ( PERIOD = '.', COMMA = ',', SEMICN = ';' ) CHARACTER*(*) COLON, DASH, EQUALS PARAMETER ( COLON = ':', DASH = '-', EQUALS = '=' ) CHARACTER*(*) OBRACE, CBRACE, UNDERS PARAMETER ( OBRACE = '{', CBRACE = '}', UNDERS = '_' ) CHARACTER*(*) PLUS, MINUS, EXCLAM PARAMETER ( PLUS = '+', MINUS = '-', EXCLAM = '!' ) CHARACTER*(*) GTHAN, LTHAN, QUESMK PARAMETER ( GTHAN = '>', LTHAN = '<', QUESMK = '?' ) CHARACTER*(*) SLASH, BSLASH, PERCNT PARAMETER ( SLASH = '/', BSLASH = '\\',PERCNT = '%' ) CHARACTER*(*) CARAT, ATSIGN, TILDE PARAMETER ( CARAT = '^', ATSIGN = '@', TILDE = '~' ) REAL ZERO, ONE, TWO, THREE C!!!! DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) REAL FOUR, FIVE, SIX, SEVEN C!!!! DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) REAL EIGHT, NINE, TEN C!!!! DOUBLE PRECISION EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 9D0, TEN = 10D0 ) CHARACTER *(*) COMPTD, TEX, FP, NOX, PATH PARAMETER ( COMPTD = BSLASH//'COMPUTED'//PERCNT, - TEX = '.TEX', - NOX = ' ', - PATH = 'COMPUTED/', - FP = BSLASH//'FP' - ) INTEGER LINELN, FNAMLN PARAMETER ( LINELN = 100, FNAMLN = 80 ) C## L O C A L D E C L: CHARACTER *(LINELN) OUT(3) CHARACTER *(FNAMLN) FNAME, LSTNAM INTEGER POS, LASTPR, POS1, POS2 INTEGER ZZLENG, ZZLFTI LOGICAL FIRST C## S A V E: SAVE FIRST, LASTPR, POS1, POS2, LSTNAM C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A DATA FIRST/T/, LASTPR/0/, LSTNAM/BLANK/ C## E X E C U T I O N C## E X E C U T I O N IF ( PNO .NE. LASTPR .AND. LASTPR .NE. 0 ) THEN WRITE ( UNIT, 99999 ) COMPTD WRITE ( UNIT, 99999 ) OUT(1)(1:POS1) WRITE ( UNIT, 99999 ) OUT(2)(1:POS2) LASTPR = 0 ENDIF IF ( NAME .NE. LSTNAM ) THEN IF (.NOT. FIRST ) THEN ENDFILE UNIT CLOSE (UNIT) ENDIF FIRST = F LSTNAM = NAME FNAME = NAME IF ( NAME .NE. BLANK ) THEN CALL ZZCASE(FNAME,CTOUPP) POS = ZZLENG(FNAME) + 1 FNAME(POS:) = TEX OPEN ( UNIT, FILE=PATH//FNAME, STATUS='UNKNOWN', - ACCESS='SEQUENTIAL') REWIND UNIT WRITE(UNIT,*) BLANK ENDIF ENDIF IF ( ERR .EQ. 0 ) THEN OUT(1) = OBRACE POS = 2 POS = POS + ZZLFTI(OUT(1)(POS:),PNO) OUT(1)(POS:POS+1) = CBRACE//OBRACE POS = POS + 2 POS = POS + ZZLFTI(OUT(1)(POS:),ITERS) OUT(1)(POS:POS+1) = CBRACE//OBRACE POS = POS + 2 POS = POS + ZZLFTI(OUT(1)(POS:),FVALS) OUT(1)(POS:POS+1) = CBRACE//OBRACE POS = POS + 2 POS = POS + ZZLFTI(OUT(1)(POS:),ACC) IF ( CRIT .NE. 1 ) THEN OUT(1)(POS:POS+1) = COMMA//BLANK POS = POS + 2 POS = POS + ZZLFTI(OUT(1)(POS:),CRIT) ENDIF OUT(1)(POS:POS+1) = CBRACE//OBRACE WRITE(OUT(1)(POS+2:),99998) - MTIME,BSLASH,BSLASH,BSLASH,BSLASH, - MAX(1,MIN(99,NINT(FTIME*100.0/MTIME))),BSLASH C - MTIME,BSLASH,BSLASH,BSLASH,FTIME*100.0/MTIME,BSLASH POS = ZZLENG(OUT(1)) + 1 OUT(1)(POS:POS) = CBRACE POS1 = POS POS = 1 OUT(2)(POS:) = OBRACE//FP POS = POS + 4 IF ( FXSTAR .NE. ZERO ) THEN WRITE ( OUT(2)(POS:), '(E23.15)') FC ELSE WRITE ( OUT(2)(POS:), '(E10.2)') FC ENDIF POS = ZZLENG(OUT(2)) + 1 OUT(2)(POS:POS+2) = BLANK//CBRACE//OBRACE POS = POS + 3 OUT(2)(POS:) = FP POS = POS + 3 WRITE ( OUT(2)(POS:), '(E10.2)') GNORM POS = ZZLENG(OUT(2)) + 1 OUT(2)(POS:POS+2) = BLANK//CBRACE//OBRACE POS = POS + 3 OUT(2)(POS:) = FP POS = POS + 3 WRITE ( OUT(2)(POS:), '(E10.2)') GMIN POS = ZZLENG(OUT(2)) + 1 OUT(2)(POS:POS+2) = BLANK//CBRACE//OBRACE POS = POS + 3 IF ( DISTX .GE. ZERO ) THEN OUT(2)(POS:) = FP POS = POS + 3 WRITE ( OUT(2)(POS:), '(E10.2)') DISTX ELSE OUT(2)(POS:) = NOX ENDIF POS = ZZLENG(OUT(2)) + 1 OUT(2)(POS:POS+1) = BLANK//CBRACE POS2 = POS + 1 IF ( GNORM .NE. ZERO ) THEN WRITE (99,*) NAME,' #',PNO,' OK AT ACC=',ACC LASTPR = PNO ELSE WRITE (99,*) NAME,' #',PNO,' OK AT ACC=',ACC, - ' GNORM= ',GNORM WRITE (99,*) ' ' ENDIF ELSE IF ( NAME .NE. BLANK ) THEN WRITE (99,*) NAME,' #',PNO,' FAILED AT ACC=',ACC, ',ERR= ',ERR WRITE (99,*) ' ' ENDIF C## E X I T 90000 RETURN C## F O R M A T S: C99998 FORMAT (F7.2,A1,'SMALL',A1,'SL',A1,'S1(',F5.1,A1,'%)') 99998 FORMAT (F8.2,A1,'SMALL',A1,'SL',A1,'S1(',A1,'FIXTWO{' - ,I2,'}',A1,'%)') 99999 FORMAT ( A ) C## E N D OF ZZTEX. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> vectsg.f SUBROUTINE ZZVECT ( ACTION, N, U, V, ARGS ) C## A R G U M E N T S: INTEGER ACTION, N REAL U(N), V(N), ARGS(*) C!!!! DOUBLE PRECISION U(N), V(N), ARGS(*) C## S T A T U S: C IGNORE LINES BEGINNING WITH "C!!!!" . C C SYSTEM DEPENDENCE: NONE. C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C>RCS $HEADER: VECT.F,V 2.2 91/11/20 10:53:12 BUCKLEY EXP $ C>RCS $LOG: VECT.F,V $ C>RCS REVISION 2.2 91/11/20 10:53:12 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 2.1 90/10/04 14:44:32 BUCKLEY C>RCS FIXED MISSING GOTO 10000 FOR CASE 9. C>RCS C>RCS REVISION 2.0 90/07/31 11:38:24 BUCKLEY C>RCS MINOR MOD TO USE BLAS C>RCS C>RCS REVISION 1.9 89/06/30 13:39:55 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 16:43:03 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.1 89/01/17 16:50:14 BUCKLEY C>RCS INITIAL REVISION C>RCS C## D E S C R I P T I O N: C COMPUTE STANDARD VECTORS AND PUT INTO V. THE VALUE PUT INTO C V DEPENDS ON THE VALUE OF ACTION: C C IF ACTION = 0, IT IS EQUIVALENT TO SPECIFYING ACTION = N. C IF ACTION > 0, A CYCLE IS DEFINED AND MUST BE EXPANDED. IN C THIS CASE, THE FIRST "ACTION" COMPONENTS C OF U MUST DEFINED. THEY ARE CYCLICALLY C COPIED INTO V. IN THIS CASE, U AND V MAY C REFER TO THE SAME VECTORS IN THE CALL. C IF ACTION < 0 A SELECTED FORMULA IS USED TO COMPUTE VALUES C FOR THE COMPONENTS OF V. C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZVECT. C## S U B R O U T I N E S: C REAL(DBLE),ABS,MOD INTRINSIC C RD STATEMENT FUNCTION C## P A R A M E T E R S: REAL TENTH, FIFTH, HALF C!!!! DOUBLE PRECISION TENTH, FIFTH, HALF PARAMETER ( TENTH = .1D0, FIFTH = .2D0, HALF = .5D0 ) REAL RPT9, RPT8, RD29 C!!!! DOUBLE PRECISION RPT9, RPT8, RD29 PARAMETER ( RPT9 = .9D0, RPT8 = .8D0, RD29 = 1D0/29D0 ) REAL R1PD6, R2PDM6 C!!!! DOUBLE PRECISION R1PD6, R2PDM6 PARAMETER ( R1PD6 = 1D6, R2PDM6 = 2D-6 ) REAL RP04, RP01, R1PZ1 C!!!! DOUBLE PRECISION RP04, RP01, R1PZ1 PARAMETER ( RP04 = 4D-2, RP01 = .01D0, R1PZ1 = 1.0001D0 ) REAL R1P2, R7P5, RP1136 C!!!! DOUBLE PRECISION R1P2, R7P5, RP1136 PARAMETER ( R1P2 = 1.2D0, R7P5 = 7.5D0, RP1136 = 0.1136D0 ) REAL R1P5, R2P5, R2P625 C!!!! DOUBLE PRECISION R1P5, R2P5, R2P625 PARAMETER ( R1P5 = 1.5D0, R2P5 = 2.5D0, R2P625 = 2.625D0 ) REAL R10P1, R19P8, R20P2 C!!!! DOUBLE PRECISION R10P1, R19P8, R20P2 PARAMETER ( R10P1 = 10.1D0,R19P8 = 19.8D0,R20P2 = 20.2D0 ) REAL R2D3, R4D3, R7D3 C!!!! DOUBLE PRECISION R2D3, R4D3, R7D3 PARAMETER ( R2D3 = 2D0/3D0,R4D3 = 4D0/3D0,R7D3 = 7D0/3D0 ) REAL R2P25 C!!!! DOUBLE PRECISION R2P25 PARAMETER ( R2P25 = 2.25D0 ) REAL ZERO, ONE, TWO, THREE C!!!! DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) REAL FOUR, FIVE, SIX, SEVEN C!!!! DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) REAL EIGHT, NINE, TEN C!!!! DOUBLE PRECISION EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 9D0, TEN = 10D0 ) INTEGER JUSTF, BOTH, JUSTG, NOOP PARAMETER ( JUSTF = 1, BOTH = 0, JUSTG = -1, NOOP = 2 ) C## L O C A L D E C L: INTEGER I, K REAL R, Z ,RD C!!!! DOUBLE PRECISION R, Z ,RD C## S A V E: NONE SELECTED. C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NO DATA VALUES SET. C## E X E C U T I O N C## E X E C U T I O N C------ FUNCTION STATEMENT. RD(I) = REAL(I) C!!!! RD(I) = DBLE(I) C----- NOW EXECUTE. IF ( ACTION .LT. 0 ) THEN GOTO( - 100, 200, 300, 400, 500, 600, 700, 700, 900, 900, - 1100, 1200, 1300, 1400, 1500, 1600, 1700, 1800, 1900, 2000 ) - , ABS( ACTION ) C ---VECTOR 1 : V(I) = I/(N+1) 100 R = ONE / RD(N+1) DO 150 I = 1, N V(I) = R * RD(I) 150 CONTINUE GOTO 10000 C ---VECTOR 2 : V(I) = .1*I*(1-I)/(N+1) 200 R = TENTH / RD(N+1) DO 250 I = 1, N V(I) = R * RD(I) * RD(1-I) 250 CONTINUE GOTO 10000 C ---VECTOR 3 : V = -1.2, 1, 1, 1, ... , 1 300 V(1) = - R1P2 DO 350 I = 2, N V(I) = ONE 350 CONTINUE GOTO 10000 C ---VECTOR 4 : V = 1, 2, 3, ..., N 400 DO 450 I = 1, N V(I) = RD(I) 450 CONTINUE GOTO 10000 C ---VECTOR 5 : V(I) = 1 - I/N 500 R = ONE / RD(N) DO 550 I = 1, N V(I) = ONE - R * RD(I) 550 CONTINUE GOTO 10000 C ---VECTOR 6 : V(I) = Z*(Z - 1) WHERE Z = I/(N+1) 600 R = ONE / RD(N+1) DO 650 I = 1, N Z = R * RD(I) V(I) = Z * ( Z - ONE ) 650 CONTINUE GOTO 10000 C ---VECTORS 7,8 : V(I) = 0.2 * SIN((REAL(I**2)) C IN VECTOR 8, WHEN I = 2M+1, THE CONSTANT 0.2 IS C REPLACED BY -0.8. NOTE THAT N = M^2. 700 DO 730 I = 1,N V(I) = SIN(RD(I**2)) * FIFTH 730 CONTINUE IF ( ABS(ACTION) .EQ. 8 ) THEN I = 2 * NINT(SQRT(RD(N))) + 1 V(I) = - RPT8 * SIN(RD(I**2)) ENDIF GOTO 10000 C ---VECTORS 9,10 : V(I) DOCUMENTED IN TOI83B. C FOR LINEAR (9) AND NONLINEAR (10) MINIMUM SURFACE PROBLEMS, C FUNCTIONS MNSRF1 AND MNSRF2. 900 CONTINUE DO 950 I=1,N V(I)= ZERO 950 CONTINUE K = NINT( SQRT(RD(N)) ) IF ( ABS(ACTION) .EQ. 9 ) THEN DO 952 I=1,K Z = (RD(I)-ONE)/(RD(K)-ONE) V(I) = ONE + FOUR*Z V((I-1)*K + 1) = ONE + EIGHT*Z V(I + K*(K-1)) = NINE + FOUR*Z V(I*K) = FIVE + EIGHT*Z 952 CONTINUE ELSE IF ( ABS(ACTION) .EQ. 10 ) THEN DO 954 I=1,K Z = (RD(I)-ONE)/(RD(K)-ONE) V(I) = ONE + FOUR*Z + TEN*(ONE+Z)**2 V((I-1)*K + 1) = ONE + EIGHT*Z + TEN*(ONE-Z)**2 V(I + K*(K-1)) = NINE + FOUR*Z + TEN*Z**2 V(I*K) = FIVE + EIGHT*Z + TEN*(TWO-Z)**2 954 CONTINUE ENDIF GOTO 10000 C ---VECTOR 11 : V = 1/N. USED IN FUNCTION ARTRIG. 1100 CONTINUE DO 1150 I = 1, N V(I) = ONE/RD(N) 1150 CONTINUE GOTO 10000 C ---VECTOR 12. USED IN FUNCTION MANCIN. 1200 CONTINUE DO 1250 I = 1, N U(I) = ZERO 1250 CONTINUE CALL ZZFNS ( JUSTF, N, U, Z, U, K, U, V ) Z = -RD(14*N) / ( 196*N**2 - (36*(N-1)**2) ) CALL ZZSCAL ( N, Z, V, 1 ) GOTO 10000 C ---VECTOR 13 : V = 4/I. USED IN FUNCTION HILBRT. 1300 CONTINUE DO 1350 I = 1, N V(I) = FOUR/RD(I) 1350 CONTINUE GOTO 10000 C ---VECTOR 14 : V = -1, 1, 1, 1, ... , 1, 1, 1 C USED IN FUNCTION GENRSN. 1400 V(1) = - ONE DO 1450 I = 2, N V(I) = ONE 1450 CONTINUE GOTO 10000 C ---VECTOR 15 : V = (0, 0,...,0, N+1). USED IN FUNCTION BRWNAL. 1500 DO 1550 I = 1, N-1 V(I) = ZERO 1550 CONTINUE V(N) = RD(N+1) GOTO 10000 C ---VECTOR 16 : V = (T,T,...,T,T^{1-N}). USED IN FUNCTION BRWNAL C THE SOLUTION COMPONENT T IS PASSED INTO ZZVECT FROM ZZDSOL VIA C VARIABLE ARGS. IF THE VECTOR NUMBER IS CHANGED, IT MAY BE C NECESSARY TO CHANGE THE VALUE OF ARGS IN ZZDSOL. 1600 CONTINUE DO 1650 I = 1, N-1 V(I) = ARGS(1) 1650 CONTINUE V(N) = ARGS(1)**(1-N) GOTO 10000 C ---VECTOR 17 : V = (T,T,...,T). UNUSED AT PRESENT. C THE SOLUTION COMPONENT T IS PASSED INTO ZZVECT FROM ZZDSOL VIA C VARIABLE ARGS. IF THE VECTOR NUMBER IS CHANGED, IT MAY BE C NECESSARY TO CHANGE THE VALUE OF ARGS IN ZZDSOL. 1700 CONTINUE DO 1750 I = 1, N V(I) = ARGS(1) 1750 CONTINUE GOTO 10000 C ---VECTOR 18 : V = (T,T,0). USED IN FUNCTION BOX66. C THE SOLUTION COMPONENT T IS PASSED INTO ZZVECT FROM ZZDSOL VIA C VARIABLE ARGS. IF THE VECTOR NUMBER IS CHANGED, IT MAY BE C NECESSARY TO CHANGE THE VALUE OF ARGS IN ZZDSOL. 1800 CONTINUE V(1) = ARGS(1) V(2) = ARGS(1) V(3) = ZERO GOTO 10000 C ---VECTOR 19 : V = (0,0,T,T). USED IN FUNCTION TOIN4. C THE SOLUTION COMPONENT T IS PASSED INTO ZZVECT FROM ZZDSOL VIA C VARIABLE ARGS. IF THE VECTOR NUMBER IS CHANGED, IT MAY BE C NECESSARY TO CHANGE THE VALUE OF ARGS IN ZZDSOL. 1900 CONTINUE V(1) = ZERO V(2) = ZERO V(3) = ARGS(1) V(4) = ARGS(1) GOTO 10000 2000 CONTINUE GOTO 10000 ELSE IF ( ACTION .GT. 0 ) THEN K = 0 DO 5000 I = 1, N K = MOD ( K, ACTION ) + 1 V(I) = V(K) 5000 CONTINUE ENDIF 10000 GOTO 90000 C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZVECT. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> axpysg.f SUBROUTINE ZZAXPY (N,A,X,INCX,Y,INCY) C## A R G U M E N T S: INTEGER INCX, INCY, N REAL X(*), Y(*), A C!!!! DOUBLE PRECISION X(*), Y(*), A C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C>RCS $HEADER$ C>RCS $LOG$ C## D E S C R I P T I O N: C C CONSTANT TIMES A VECTOR PLUS A VECTOR. C USES UNROLLED LOOP FOR INCREMENTS EQUAL TO ONE. C JACK DONGARRA, LINPACK, 3/11/78. C SEE FURTHER COMMENTS IN ZZAMAX. C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZAXPY. C## S U B R O U T I N E S: MOD...INTRINSIC. C## P A R A M E T E R S: REAL ZERO, ONE, TWO, THREE C!!!! DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) REAL FOUR, FIVE, SIX, SEVEN C!!!! DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) REAL EIGHT, NINE, TEN C!!!! DOUBLE PRECISION EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 9D0, TEN = 10D0 ) C## L O C A L D E C L: INTEGER I, IX, IY, M C## S A V E: NONE SELECTED. C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NO VALUES ARE SET. C## E X E C U T I O N C## E X E C U T I O N IF ( N .GT. 0 .AND. A .NE. ZERO ) THEN IF( INCX .EQ. 1 .AND. INCY .EQ. 1 ) THEN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C M = MOD(N,4) IF( M .NE. 0 ) THEN C CLEAN-UP LOOP DO 30 I = 1,M Y(I) = Y(I) + A*X(I) 30 CONTINUE ENDIF DO 50 I = M+1,N,4 Y(I ) = Y(I ) + A*X(I ) Y(I + 1) = Y(I + 1) + A*X(I + 1) Y(I + 2) = Y(I + 2) + A*X(I + 2) Y(I + 3) = Y(I + 3) + A*X(I + 3) 50 CONTINUE ELSE C C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS C NOT EQUAL TO 1 C IX = 1 IY = 1 IF ( INCX .LT. 0 ) IX = (-N+1)*INCX + 1 IF ( INCY .LT. 0 ) IY = (-N+1)*INCY + 1 DO 10 I = 1,N Y(IY) = Y(IY) + A*X(IX) IX = IX + INCX IY = IY + INCY 10 CONTINUE ENDIF ENDIF C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C E N D OF ZZAXPY. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> copysg.f SUBROUTINE ZZCOPY (N, X, INCX, Y, INCY ) C## A R G U M E N T S: INTEGER INCX, INCY, N REAL X(*), Y(*) C!!!! DOUBLE PRECISION X(*), Y(*) C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C>RCS $HEADER$ C>RCS $LOG$ C## D E S C R I P T I O N: C C COPIES A VECTOR, X, TO A VECTOR, Y. C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. C JACK DONGARRA, LINPACK, 3/11/78. C SEE FURTHER COMMENTS IN ZZAMAX. C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZCOPY. C## S U B R O U T I N E S: MOD...INTRINSIC. C## P A R A M E T E R S: NONE ARE DEFINED. C## L O C A L D E C L: INTEGER I, IX, IY, M C## S A V E: NONE SELECTED. C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NO VALUES ARE SET. C## E X E C U T I O N C## E X E C U T I O N IF( N .GT. 0 ) THEN IF ( INCX .EQ. 1 .AND. INCY .EQ. 1 ) THEN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C M = MOD(N,7) IF ( M .NE. 0 ) THEN C CLEAN-UP LOOP DO 30 I = 1,M Y(I) = X(I) 30 CONTINUE ENDIF DO 50 I = M+1,N,7 Y(I ) = X(I ) Y(I + 1) = X(I + 1) Y(I + 2) = X(I + 2) Y(I + 3) = X(I + 3) Y(I + 4) = X(I + 4) Y(I + 5) = X(I + 5) Y(I + 6) = X(I + 6) 50 CONTINUE ELSE C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS C NOT EQUAL TO 1 C IX = 1 IY = 1 IF ( INCX .LT. 0 ) IX = (-N+1)*INCX + 1 IF ( INCY .LT. 0 ) IY = (-N+1)*INCY + 1 DO 10 I = 1,N Y(IY) = X(IX) IX = IX + INCX IY = IY + INCY 10 CONTINUE ENDIF ENDIF C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C E N D OF ZZCOPY. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> scalsg.f SUBROUTINE ZZSCAL (N,A,X,INCX) C## A R G U M E N T S: INTEGER INCX,N REAL A, X(*) C!!!! DOUBLE PRECISION A, X(*) C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: NONE. C>RCS $HEADER$ C>RCS $LOG$ C## D E S C R I P T I O N: C C SCALES A VECTOR BY A CONSTANT. C USES UNROLLED LOOPS FOR INCREMENT EQUAL TO ONE. C JACK DONGARRA, LINPACK, 3/11/78. C SEE FURTHER COMMENTS IN ZZAMAX. C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZSCAL. C## S U B R O U T I N E S: MOD...INTRINSIC. C## P A R A M E T E R S: NONE ARE DEFINED. C## L O C A L D E C L: INTEGER I, M, NINCX C## S A V E: NONE SELECTED. C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NO VALUES ARE SET. C## E X E C U T I O N C## E X E C U T I O N IF ( N .GT. 0 ) THEN IF ( INCX .NE. 1 ) THEN C C CODE FOR INCREMENT NOT EQUAL TO 1 C NINCX = N*INCX DO 10 I = 1,NINCX,INCX X(I) = A*X(I) 10 CONTINUE ELSE C CODE FOR INCREMENT EQUAL TO 1 C M = MOD(N,5) IF ( M .NE. 0 ) THEN C CLEAN-UP LOOP DO 30 I = 1,M X(I) = A*X(I) 30 CONTINUE ENDIF DO 50 I = M+1,N,5 X(I ) = A*X(I ) X(I+1) = A*X(I+1) X(I+2) = A*X(I+2) X(I+3) = A*X(I+3) X(I+4) = A*X(I+4) 50 CONTINUE ENDIF ENDIF C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C E N D OF ZZSCAL. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> mparsg.f REAL FUNCTION ZZMPAR(I) C!!!! DOUBLE PRECISION FUNCTION ZZMPAR(I) C## A R G U M E N T S: INTEGER I C## S T A T U S: C IGNORE LINES BEGINNING WITH "C!!!!" . C C SYSTEM DEPENDENCE: THE CODE IS VERY DEFINITELY MACHINE DEPENDENT C FOR IT CONTAINS MACHINE PRECISION CONSTANTS C FOR MANY MACHINES, AS DESCRIBED BELOW. C C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C>RCS $HEADER: MPAR.GL,V 2.3 91/11/22 11:45:19 BUCKLEY EXP $ C>RCS $LOG: MPAR.GL,V $ C>RCS REVISION 2.3 91/11/22 11:45:19 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 2.2 91/06/12 14:07:08 BUCKLEY C>RCS ADDED STARDENT C>RCS C>RCS REVISION 2.1 90/07/31 10:57:40 BUCKLEY C>RCS ADDED CONSTANTS FOR IEEE FOR PC'S C>RCS C>RCS REVISION 2.0 90/07/06 10:39:26 BUCKLEY C>RCS COMMON VERSION FOR TOMS AND MT C>RCS C>RCS REVISION 1.9.1.2 90/06/26 14:24:24 BUCKLEY C>RCS FIXED SINGLE/DOUBLE PRECISION CONSTANTS FOR SUN4 C>RCS C>RCS REVISION 1.9.1.1 89/07/01 11:36:48 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.9 89/06/30 13:30:15 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 13:46:28 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 12:13:23 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:34:59 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:34:31 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS IS A MODIFICATION OF THE TWO ROUTINES DPMPAR AND SPMPAR C OBTAINED FROM JORGE MORE. IT HAS BEEN CHANGED ONLY TO CONFORM C WITH MY CONVENTIONS, AND TO ADD STATEMENTS FOR THE CDC C CYBERS WHICH ARE ACCEPTABLE TO FTN5 (FORTRAN '77). THE C OTHER CHANGES ARE: C C 1. THE SINGLE NAME ZZMPAR HAS BEEN USED. IT IS DOUBLE OR SINGLE C PRECISION ACCORDING TO CONVERSION BY CONVRT, JUST AS FOR ALL C OF MY OTHER PROGRAMS. C C 2. THE ROUTINES HAVE BEEN MERGED SO THAT SINGLE AND DOUBLE C PRECISION STATEMENTS WHICH CORRESPOND APPEAR IN PAIRS. C C OTHERWISE ALL OF THE COMMENTS OF THE ORIGINAL AUTHORS APPLY. C THEIR ORIGINAL COMMENTS (UNALTERED) FOR THE DOUBLE PRECISION C VERSION FOLLOW IMMEDIATELY. C C FUNCTION DPMPAR C C THIS FUNCTION PROVIDES DOUBLE PRECISION MACHINE PARAMETERS C WHEN THE APPROPRIATE SET OF DATA STATEMENTS IS ACTIVATED (BY C REMOVING THE C FROM COLUMN 1) AND ALL OTHER DATA STATEMENTS ARE C RENDERED INACTIVE. MOST OF THE PARAMETER VALUES WERE OBTAINED C FROM THE CORRESPONDING BELL LABORATORIES PORT LIBRARY FUNCTION. C C THE FUNCTION STATEMENT IS C C DOUBLE PRECISION FUNCTION DPMPAR(I) C C WHERE C C I IS AN INTEGER INPUT VARIABLE SET TO 1, 2, OR 3 WHICH C SELECTS THE DESIRED MACHINE PARAMETER. IF THE MACHINE HAS C T BASE B DIGITS AND ITS SMALLEST AND LARGEST EXPONENTS ARE C EMIN AND EMAX, RESPECTIVELY, THEN THESE PARAMETERS ARE C C DPMPAR(1) B**(1 - T), THE MACHINE PRECISION, C C DPMPAR(2) B**(EMIN - 1), THE SMALLEST MAGNITUDE, C C DPMPAR(3) B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZMPAR. C## S U B R O U T I N E S: NONE ARE CALLED. C## P A R A M E T E R S: NONE ARE DEFINED. C C## L O C A L D E C L: C NOTE THAT THESE ARRAYS MUST HAVE DIMENSIONS 2 AND 4, RATHER C THAN 1 AND 2 AS ONE MIGHT EXPECT, BECAUSE OF THE PDP-11 C DEFINITIONS. INTEGER MCHEPS(2) C!!!! INTEGER MCHEPS(4) INTEGER MINMAG(2) C!!!! INTEGER MINMAG(4) INTEGER MAXMAG(2) C!!!! INTEGER MAXMAG(4) REAL RMACH(3) C!!!! DOUBLE PRECISION DMACH(3) INTEGER EMIN, EMAX, IMACH(10) REAL B, BINV, BM1, ONE, W, Z C!!!! DOUBLE PRECISION B, BINV, BM1, ONE, W, Z C## S A V E: SAVE RMACH C!!!! SAVE DMACH SAVE IMACH C## E Q U I V A L E N C E S: EQUIVALENCE (RMACH(1),MCHEPS(1)) C!!!! EQUIVALENCE (DMACH(1),MCHEPS(1)) EQUIVALENCE (RMACH(2),MINMAG(1)) C!!!! EQUIVALENCE (DMACH(2),MINMAG(1)) EQUIVALENCE (RMACH(3),MAXMAG(1)) C!!!! EQUIVALENCE (DMACH(3),MAXMAG(1)) C## C O M M O N: NONE IS DEFINED. C## D A T A: C-----MACHINE CONSTANTS FOR THE SUN-4. DATA MCHEPS(1) / X'34000000'/ C!!!! DATA MCHEPS(1),MCHEPS(2) / X'3CB00000', X'00000000' / DATA MINMAG(1) / X'00800000' / C!!!! DATA MINMAG(1),MINMAG(2) / X'00100000', X'00000000' / DATA MAXMAG(1) / X'7F7FFFFF' / C!!!! DATA MAXMAG(1),MAXMAG(2) / X'7FEFFFFF', X'FFFFFFFF'/ C## E X E C U T I O N C## E X E C U T I O N ZZMPAR = RMACH(I) C!!!! ZZMPAR = DMACH(I) C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZMPAR. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> secssg.f SUBROUTINE ZZSECS(SECS) C## A R G U M E N T S: REAL SECS C!!!! DOUBLE PRECISION SECS C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: SYSTEM ROUTINE FOR CPU USAGE. C THIS VERSION IS FOR SUN4 C C>RCS $HEADER: SECS.GL,V 2.1 91/11/22 11:45:25 BUCKLEY EXP $ C>RCS $LOG: SECS.GL,V $ C>RCS REVISION 2.1 91/11/22 11:45:25 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 2.0 90/07/06 10:48:10 BUCKLEY C>RCS COMMON VERSION FOR TOMS AND MT C>RCS C>RCS REVISION 1.9 89/06/30 13:30:19 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 13:46:31 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 12:13:31 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:35:12 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:34:33 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C THIS SUBROUTINE SHOULD OBTAIN (FROM THE OPERATING SYSTEM) THE C AMOUNT OF CPU TIME USED BY THE CALLING PROGRAM SINCE THE C EXECUTION BEGAN. IF DESIRABLE, "SECS" CAN ALSO BE CONVERTED C TO DOUBLE PRECISION (SEE CONVRT). HOWEVER, THE ROUTINE ACTUALLY C WORKS TOTALLY AS A SINGLE PRECISION ROUTINE, EXCEPT THAT THE C VALUE WHICH IS PASSED BACK MAY BE IN EITHER PRECISION AS C APPROPRIATE. C TIME IS MEASURED FROM THE FIRST CALL TO ZZSECS. THUS C ON THE FIRST CALL TO ZZSECS, A TIME OF 0.0 SECONDS IS ALWAYS C RETURNED. C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZSECS. C## S U B R O U T I N E S: A SYSTEM CLOCK. C## P A R A M E T E R S: REAL ZERO PARAMETER ( ZERO = 0.0E0 ) C## L O C A L D E C L: LOGICAL FIRST REAL ETIME, DUMMY(2) REAL STTIME, SEC C## S A V E: SAVE FIRST, STTIME C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA FIRST/.TRUE./ C## E X E C U T I O N C## E X E C U T I O N IF ( FIRST ) THEN FIRST = .FALSE. STTIME = ETIME(DUMMY) SEC = ZERO ELSE SEC = ETIME(DUMMY) - STTIME ENDIF SECS = SEC C!!!! SECS = DBLE(SEC) C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZSECS. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> casesg.f SUBROUTINE ZZCASE (STRING, TYPE ) C## A R G U M E N T S: CHARACTER *(*) STRING INTEGER TYPE C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NOT REQUIRED. C C SYSTEM DEPENDENCE: SYSTEM ROUTINE FOR CASE C CONVERSION OF LETTERS. C C THIS IS A VERSION FOR SUN4 C>RCS $HEADER: CASE.GL,V 2.0 90/07/05 12:44:20 BUCKLEY EXP $ C>RCS $LOG: CASE.GL,V $ C>RCS REVISION 2.0 90/07/05 12:44:20 BUCKLEY C>RCS COMMON VERSION FOR TOMS AND GL C>RCS C>RCS REVISION 1.9.1.1 89/06/30 14:59:19 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.9 89/06/30 13:30:11 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 16:07:53 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/20 13:48:39 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C## D E S C R I P T I O N: C THIS CONVERTS EACH LOWER CASE ALPHABETIC LETTER TO C UPPER CASE, OR VICE VERSA. C IF TYPE = CTOUPP, CONVERSION IS LOWER TO UPPER C IF TYPE = CTOLOW, CONVERSION IS UPPER TO LOWER C IF TYPE = CTOCAP, USE UPPER FOR FIRST LETTER; LOWER FOR REST C ALL OTHER CHARACTERS ARE LEFT UNCHANGED. C## E N T R Y P O I N T S: THE NATURAL ENTRY TTOUPPR. C## S U B R O U T I N E S: LEN (INTRINSIC). C## P A R A M E T E R S: INTEGER CTOUPP, CTOLOW, CTOCAP PARAMETER ( CTOUPP = 1, CTOLOW = 2, CTOCAP = 3 ) CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) CHARACTER*(*) PERIOD, COMMA, SEMICN PARAMETER ( PERIOD = '.', COMMA = ',', SEMICN = ';' ) CHARACTER*(*) COLON, DASH, EQUALS PARAMETER ( COLON = ':', DASH = '-', EQUALS = '=' ) CHARACTER*(*) OBRACE, CBRACE, UNDERS PARAMETER ( OBRACE = '{', CBRACE = '}', UNDERS = '_' ) CHARACTER*(*) PLUS, MINUS, EXCLAM PARAMETER ( PLUS = '+', MINUS = '-', EXCLAM = '!' ) CHARACTER*(*) GTHAN, LTHAN, QUESMK PARAMETER ( GTHAN = '>', LTHAN = '<', QUESMK = '?' ) CHARACTER*(*) SLASH, BSLASH, PERCNT PARAMETER ( SLASH = '/', BSLASH = '\\',PERCNT = '%' ) CHARACTER*(*) CARAT, ATSIGN, TILDE PARAMETER ( CARAT = '^', ATSIGN = '@', TILDE = '~' ) C## L O C A L D E C L: INTEGER I, SHIFT LOGICAL FIRST CHARACTER *1 CH C## S A V E: SAVE FIRST, SHIFT C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA FIRST/.TRUE./ C## E X E C U T I O N C## E X E C U T I O N IF (FIRST) THEN FIRST = .FALSE. SHIFT = ICHAR('A') - ICHAR('a') ENDIF I = 0 100 I = I + 1 IF ( I .LE. LEN(STRING) ) THEN IF ( TYPE .EQ. CTOUPP ) THEN IF ('a' .LE. STRING(I:I) .AND. STRING(I:I) .LE. 'z') THEN CH = CHAR( ICHAR(STRING(I:I)) + SHIFT ) ELSE CH = STRING(I:I) ENDIF ELSE IF ( TYPE .EQ. CTOLOW .OR. TYPE .EQ. CTOCAP ) THEN IF ('A' .LE. STRING(I:I) .AND. STRING(I:I) .LE. 'Z') THEN CH = CHAR( ICHAR(STRING(I:I)) - SHIFT ) ELSE CH = STRING(I:I) ENDIF ENDIF STRING(I:I) = CH GOTO 100 ENDIF IF ( TYPE .EQ. CTOCAP .and. - 'a' .LE. STRING(1:1) .AND. STRING(1:1) .LE. 'z') THEN CH = CHAR( ICHAR(STRING(1:1)) + SHIFT ) STRING(1:1) = CH ENDIF C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF TOUPPR. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> datesg.f SUBROUTINE ZZDATE (CHDATE) C## A R G U M E N T S: CHARACTER *(*) CHDATE C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NOT REQUIRED. C SYSTEM DEPENDENCE: SYSTEM ROUTINE FOR DATE. C C THIS VERSION IS FOR SUN4 C C>RCS $HEADER: DATE.GL,V 2.1 91/11/22 11:45:18 BUCKLEY EXP $ C>RCS $LOG: DATE.GL,V $ C>RCS REVISION 2.1 91/11/22 11:45:18 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 2.0 90/07/05 12:50:05 BUCKLEY C>RCS COMMON VERSION FOR TOMS AND MT C>RCS C>RCS REVISION 1.9 89/06/30 13:30:12 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 13:46:26 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 12:12:13 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:33:41 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:34:30 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C THIS ROUTINE MUST CALL A SYSTEM ROUTINE TO GET THE CURRENT DATE. C ZZDATE MUST RETURN THIS DATE IN THE CHARACTER VARIABLE CHDATE C IN THE FORM C C (YY+MM+DD) C C AS REQUIRED BY THE ROUTINE ZZDTTM. CHDATE MUST OF LENGTH 10. C ONLY THE 6 CHARACTERS YY MM DD ARE ACTUALLY USED. THE OTHERS C CAN BE ANYTHING, I.E. ONLY THE POSITION OF THE YY MM DD MATTERS. C C THIS MUST CALL A SYSTEM ROUTINE TO GET THE DATE. C TO IMPLEMENT THIS ON ANOTHER SYSTEM, ONE MAY EITHER C C (A) INCORPORATE AN ALTERNATE VERSION OF ZZDATE; C C (B) USE THE "DUMMY" VERSION OF THIS ROUTINE WITH THE SINGLE C EXECUTABLE STATEMENT CHDATE='( + + )', IN WHICH CASE NO C DATE INFORMATION WILL APPEAR IN THE OUTPUT. C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZDATE. C## S U B R O U T I N E S: SYSTEM DATE ROUTINE. C## P A R A M E T E R S: INTEGER CTOUPP, CTOLOW, CTOCAP PARAMETER ( CTOUPP = 1, CTOLOW = 2, CTOCAP = 3 ) C## L O C A L D E C L: CHARACTER * 24 UNXDAT CHARACTER * 3 NAME (12), TEMP INTEGER I C## S A V E: SAVE NAME C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA NAME /'JAN','FEB','MAR','APR','MAY','JUN', - 'JUL','AUG','SEP','OCT','NOV','DEC' / C## E X E C U T I O N C## E X E C U T I O N C---- INITIALIZE CHDATE CHDATE = '( + + )' CALL FDATE(UNXDAT) CHDATE(2:3) = UNXDAT(23:24) CHDATE(8:9) = UNXDAT(9:10) TEMP = UNXDAT(5:7) CALL ZZCASE(TEMP, CTOUPP) DO 100 I = 1,12 IF ( TEMP .EQ. NAME(I) ) THEN WRITE ( CHDATE(5:6), '(I2.2)' ) I GOTO 90000 ENDIF 100 CONTINUE C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZDATE. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> timesg.f SUBROUTINE ZZTIME ( CHTIME ) C## A R G U M E N T S: CHARACTER *(*) CHTIME C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NOT REQUIRED. C C SYSTEM DEPENDENCE: SYSTEM ROUTINE FOR TIME. C C THIS VERSION IS FOR SUN4 C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C>RCS $HEADER: TIME.GL,V 2.1 91/11/22 11:45:26 BUCKLEY EXP $ C>RCS $LOG: TIME.GL,V $ C>RCS REVISION 2.1 91/11/22 11:45:26 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 2.0 90/07/06 10:52:37 BUCKLEY C>RCS COMMON VERSION FOR TOMS AND MT C>RCS C>RCS REVISION 1.9 89/06/30 13:30:20 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 13:46:32 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 12:13:33 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:35:16 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:34:33 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE MUST CALL A SYSTEM ROUTINE TO GET THE CURRENT TIME. C IT MUST RETURN THIS TIME IN THE CHARACTER VARIABLE CHTIME C IN THE FORM C C (HH+MM+SS) C C AS REQUIRED BY THE ROUTINE ZZDTTM. CHTIME MUST BE OF LENGTH 10. C ONLY THE SIX CHARACTERS HH MM SS ARE ACTUALLY USED. THE OTHERS C CAN BE ANYTHING, BUT THE HH, MM AND SS MUST BE IN THE CORRECT C POSITION. HH SHOULD BE BETWEEN 0 AND 23, I.E. BASED ON THE 24 HOUR C CLOCK. OF COURSE MM AND SS MUST BE IN THE RANGE 0 TO 59. C C THIS VERSION CALLS A SYSTEM DEPENDENT ROUTINE. C TO IMPLEMENT THIS ON ANOTHER SYSTEM, ONE MAY EITHER C C (A) INCORPORATE AN ALTERNATE VERSION OF ZZTIME; C C (B) USE THE "DUMMY" VERSION OF THIS ROUTINE WITH THE SINGLE C EXECUTABLE STATEMENT CHTIME=' ', IN WHICH CASE NO C TIME INFORMATION WILL APPEAR IN THE OUTPUT. C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZTIME. C## S U B R O U T I N E S: SYSTEM ROUTINE TO GET TIME OF DAY. C## P A R A M E T E R S: NONE ARE DEFINED. C## L O C A L D E C L: CHARACTER * 24 UNXTIM C## S A V E: NONE SELECTED. C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NONE ARE SET. C## E X E C U T I O N C## E X E C U T I O N CALL FDATE (UNXTIM) CHTIME(2:9) = UNXTIM(12:19) C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZTIME. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> opensg.f SUBROUTINE ZZOPEN ( IUNIT, FLAG, INAME, * , RECLEN ) C## A R G U M E N T S: INTEGER IUNIT, RECLEN LOGICAL FLAG CHARACTER *(*) INAME C## S T A T U S: C IGNORE LINES BEGINNING WITH "C!!!!" . C C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR C OPENING AND CLOSING FILES. C C THIS VERSION IS FOR SUN4 C C>RCS $HEADER: OPEN.GL,V 2.1 91/11/22 11:45:21 BUCKLEY EXP $ C>RCS $LOG: OPEN.GL,V $ C>RCS REVISION 2.1 91/11/22 11:45:21 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 2.0 90/07/06 10:43:19 BUCKLEY C>RCS COMMON VERSION FOR TOMS AND MT C>RCS C>RCS REVISION 1.9.1.2 89/07/01 11:51:41 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.9.1.1 89/07/01 11:36:50 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.9 89/06/30 13:30:16 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 13:46:29 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 12:13:26 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:35:02 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:34:31 BUCKLEY C>RCS INITIAL REVISION C>RCS C## D E S C R I P T I O N: C C THIS OPENS THE FILES NEEDED FOR TESTPACK AND KEEPS TRACK OF C WHICH ARE OPEN AND WHICH ARE NOT. IT ALSO SUPPLIES THE APPRO- C PRIATE ARGUMENTS FOR EACH FILE. C C IF NAME IS NOT BLANK ON ENTRY, THEN THE FILE IS OPENED C WITH THE NAME GIVEN. OTHERWISE, NO NAME IS SPECIFIED WHEN C OPENING THE FILE. C C THE OPEN IS ONLY DONE IF "FLAG" IS TRUE. C C IF RECLEN IS NOT EQUAL TO ZERO, THEN THE FILE IS OPENED C AS DIRECT ACCESS UNFORMATTED. C C IF RECLEN IS EQUAL TO ZERO, THEN THE FILE IS OPENED C FOR FORMATTED SEQUENTIAL ACCESS. C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZOPEN AND ZZCLSE C## S U B R O U T I N E S: OPEN, CLOSE, REAL ...INTRINSIC C ZZERRM ...FOR ERROR MESSAGES. C## P A R A M E T E R S: INTEGER FILENL, NFILES PARAMETER ( FILENL = 80, NFILES = 15 ) CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) CHARACTER*(*) PERIOD, COMMA, SEMICN PARAMETER ( PERIOD = '.', COMMA = ',', SEMICN = ';' ) CHARACTER*(*) COLON, DASH, EQUALS PARAMETER ( COLON = ':', DASH = '-', EQUALS = '=' ) CHARACTER*(*) OBRACE, CBRACE, UNDERS PARAMETER ( OBRACE = '{', CBRACE = '}', UNDERS = '_' ) CHARACTER*(*) PLUS, MINUS, EXCLAM PARAMETER ( PLUS = '+', MINUS = '-', EXCLAM = '!' ) CHARACTER*(*) GTHAN, LTHAN, QUESMK PARAMETER ( GTHAN = '>', LTHAN = '<', QUESMK = '?' ) CHARACTER*(*) SLASH, BSLASH, PERCNT PARAMETER ( SLASH = '/', BSLASH = '\\',PERCNT = '%' ) CHARACTER*(*) CARAT, ATSIGN, TILDE PARAMETER ( CARAT = '^', ATSIGN = '@', TILDE = '~' ) LOGICAL T, F PARAMETER ( T = .TRUE., F = .FALSE. ) CHARACTER*(*) TRUE, QT, FALSE, QF PARAMETER ( TRUE = 'TRUE', QT = 'T', FALSE = 'FALSE', QF = 'F' ) INTEGER ITRUE, IFALSE PARAMETER ( ITRUE = 1, IFALSE = 0 ) REAL RTRUE, RFALSE C!!!! DOUBLE PRECISION RTRUE, RFALSE PARAMETER ( RTRUE = 1.D0, RFALSE = 0.D0 ) INTEGER CTOUPP, CTOLOW, CTOCAP PARAMETER ( CTOUPP = 1, CTOLOW = 2, CTOCAP = 3 ) INTEGER PREPRC, DAUF, INPTUN PARAMETER ( PREPRC = 1, DAUF = 2, INPTUN = 3 ) INTEGER TEMPUN, STDIN, TRMOUT PARAMETER ( TEMPUN = 4, STDIN = 5, TRMOUT = 6 ) INTEGER WRITUN, TRACUN, SUMMUN PARAMETER ( WRITUN = 7, TRACUN = 8, SUMMUN = 9 ) INTEGER COPYUN, TEXUN PARAMETER ( COPYUN =10, TEXUN =11 ) CHARACTER *(*) SEQ , DIR PARAMETER ( SEQ = 'SEQUENTIAL', DIR = 'DIRECT' ) CHARACTER *(*) UNKN , NEW PARAMETER ( UNKN = 'UNKNOWN' , NEW = 'NEW' ) CHARACTER *(*) OLD , SCR PARAMETER ( OLD = 'OLD' , SCR = 'SCRATCH' ) CHARACTER *(*) DEL , KEEP PARAMETER ( DEL = 'DELETE' , KEEP = 'KEEP' ) CHARACTER *(*) FMT , UNFRMT PARAMETER ( FMT = 'FORMATTED' , UNFRMT = 'UNFORMATTED' ) C## L O C A L D E C L: INTEGER ERRINT, UNIT LOGICAL OPENFS(NFILES), REW, OPENIT, COPY CHARACTER STAT*7, ACCS*10, FRMT*11 CHARACTER *(FILENL) COPYNM, NAME REAL RD C!!!! DOUBLE PRECISION RD C## S A V E: SAVE OPENFS, COPY, COPYNM C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA OPENFS / NFILES * .FALSE. / DATA COPY/F/, COPYNM/BLANK/ C## E X E C U T I O N C## E X E C U T I O N C----- DEFINE A STATEMENT FUNCTION. RD(UNIT) = REAL(UNIT) C!!!! RD(UNIT) = DBLE(UNIT) IF ( FLAG ) THEN IF ( RECLEN .EQ. 0 ) THEN ACCS = SEQ FRMT = FMT ELSE ACCS = DIR FRMT = UNFRMT ENDIF UNIT = IUNIT NAME = INAME 100 CONTINUE OPENIT = .NOT. OPENFS(UNIT) REW = .FALSE. IF ( UNIT .EQ. SUMMUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. TRMOUT ) THEN OPENIT = .FALSE. ELSE IF ( UNIT .EQ. STDIN ) THEN OPENIT = .FALSE. ELSE IF ( UNIT .EQ. PREPRC) THEN STAT = OLD REW = .TRUE. ELSE IF ( UNIT .EQ. TEMPUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. WRITUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. TRACUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. DAUF ) THEN STAT = OLD ELSE IF ( UNIT .EQ. COPYUN ) THEN STAT = UNKN COPY = T ELSE IF ( UNIT .EQ. INPTUN ) THEN STAT = OLD REW = .TRUE. ELSE CALL ZZERRM ( RD(UNIT), *91000, - 'IS REQUEST TO OPEN UNKNOWN UNIT # ' ) ENDIF C FOR THE "CHOICE OF UNIT..." 500 IF ( OPENIT ) THEN CALL ZZCASE ( STAT, CTOLOW ) CALL ZZCASE ( ACCS, CTOLOW ) CALL ZZCASE ( FRMT, CTOLOW ) IF ( NAME .EQ. BLANK ) THEN C PRINT*,'OPENING ',UNIT,'NAME=' IF ( RECLEN .EQ. 0 ) THEN OPEN ( UNIT = UNIT, - ERR = 1000, - IOSTAT = ERRINT, - STATUS = STAT, - ACCESS = ACCS, - FORM = FRMT ) ELSE OPEN ( UNIT = UNIT, - ERR = 1000, - IOSTAT = ERRINT, - STATUS = STAT, - ACCESS = ACCS, - RECL = RECLEN, - FORM = FRMT ) ENDIF ELSE C NAMED FILE IF ( RECLEN .EQ. 0 ) THEN C PRINT*,'OPENING ',UNIT,'NAME=',NAME(1:20) OPEN ( UNIT = UNIT, - ERR = 1000, - IOSTAT = ERRINT, - FILE = NAME, - STATUS = STAT, - ACCESS = ACCS, - FORM = FRMT ) C PRINT*,'OK' ELSE OPEN ( UNIT = UNIT, - ERR = 1000, - FILE = NAME, - IOSTAT = ERRINT, - STATUS = STAT, - ACCESS = ACCS, - RECL = RECLEN, - FORM = FRMT ) ENDIF ENDIF ENDIF C FOR EACH UNIT FROM 1 TO NFILES WE NEED TO KEEP A RECORD OF C WHETHER IT IS CURRENTLY OPEN. OPENFS(UNIT) = .TRUE. IF ( REW .AND. RECLEN .EQ. 0 ) THEN REWIND UNIT ENDIF GOTO 1025 1000 IF ( UNIT .EQ. DAUF ) THEN C CREATE THE DAUF. STAT = NEW GOTO 500 ELSE GOTO 1050 ENDIF 1025 CONTINUE IF ( COPY .AND. UNIT .EQ. STDIN ) THEN UNIT = COPYUN NAME = COPYNM GOTO 100 ENDIF ENDIF C FOR THE "IF FLAG..." GOTO 90000 1050 CONTINUE GOTO 91000 C## E N T R Y ZZCLSE: ENTRY ZZCLSE ( IUNIT, * ) STAT = KEEP IF ( IUNIT .EQ. SUMMUN ) THEN STAT = KEEP ELSE IF ( IUNIT .EQ. TRMOUT ) THEN OPENFS(TRMOUT) = .FALSE. ELSE IF ( IUNIT .EQ. STDIN ) THEN OPENFS(STDIN ) = .FALSE. ELSE IF ( IUNIT .EQ. TEMPUN ) THEN STAT = KEEP ELSE IF ( IUNIT .EQ. WRITUN ) THEN ELSE IF ( IUNIT .EQ. TRACUN ) THEN ELSE IF ( IUNIT .EQ. COPYUN ) THEN STAT = KEEP COPY = F ELSE IF ( IUNIT .EQ. DAUF ) THEN ELSE IF ( IUNIT .EQ. PREPRC ) THEN ELSE IF ( IUNIT .EQ. INPTUN ) THEN ELSE CALL ZZERRM ( RD(IUNIT), *91000, - 'IS IGNORING REQUEST TO CLOSE UNKNOWN UNIT #' ) ENDIF IF ( OPENFS(IUNIT) ) THEN CALL ZZCASE ( STAT, CTOLOW ) C PRINT*,'CLOSING ',IUNIT CLOSE ( UNIT = IUNIT, STATUS = STAT ) OPENFS(IUNIT) = .FALSE. ENDIF RETURN C## E X I T 90000 CONTINUE CALL ZZCASE (STAT,CTOUPP) IF ( IUNIT .EQ. DAUF .AND. STAT .EQ. NEW ) THEN GOTO 91000 ELSE RETURN ENDIF 91000 RETURN 1 C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZOPEN. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> reclsg.f INTEGER FUNCTION ZZRECL ( CPERLN, IPERLN, LPERLN, RPERLN ) C## A R G U M E N T S: INTEGER CPERLN, IPERLN, LPERLN, RPERLN C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: SYSTEM ROUTINE FOR DIRECT C ACCESS UNFORMATTED RECORD LENGTH C C THIS VERSION IS FOR SUN4 C C>RCS $HEADER: RECL.GL,V 2.1 91/11/22 11:45:23 BUCKLEY EXP $ C>RCS $LOG: RECL.GL,V $ C>RCS REVISION 2.1 91/11/22 11:45:23 BUCKLEY C>RCS FINAL SUBMISSION TO TOMS C>RCS C>RCS REVISION 2.0 90/07/16 14:39:15 BUCKLEY C>RCS ADDED LAHEY C>RCS C>RCS REVISION 1.9 89/06/30 13:30:18 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 13:46:30 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/18 12:13:29 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 14:35:07 BUCKLEY C>RCS INITIAL INSTALLATION OF MT INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:34:32 BUCKLEY C>RCS INITIAL REVISION C>RCS C## D E S C R I P T I O N: C C THIS ROUTINE USES FOUR INTEGER CONSTANTS NEEDED TO DETERMINE C THE LENGTH OF AN UNFORMATTED RECORD FOR READING AND WRITING C DIRECT ACCESS FILES. THE PROCESSOR IS ASSUMED, ACCORDING C TO THE FORTRAN STANDARD, TO WRITE UNFORMATTED RECORDS C IN "PROCESSOR DEFINED UNITS", I.E. IN PDU'S. C C HERE WE MUST DEFINE FOUR CONSTANTS: C C CHARS THE NUMBER OF PDU'S NEEDED TO WRITE ONE CHARACTER; C INTS THE NUMBER OF PDU'S NEEDED TO WRITE ONE INTEGER VALUE; C LOGS THE NUMBER OF PDU'S NEEDED TO WRITE ONE LOGICAL VALUE; C REALS THE NUMBER OF PDU'S NEEDED TO WRITE ONE REAL(DP) VALUE. C C NOTE THAT IT MAY HAPPEN (PARTICULARLY WITH CHARACTER OR LOGICAL C DATA) THAT SEVERAL VALUES MAY FIT INTO ONE PDU. IN THIS CASE, SET C THE CONSTANT TO A NEGATIVE VALUE. FOR EXAMPLE, ON A CYBER, A PDU C IS ONE WORD AND 10 CHARACTERS FIT PER WORD. IN THIS CASE, CHARS C IS SET TO -10. BUT ON A VAX, A PDU IS ONE BYTE AND AN INTEGER C OCCUPIES 4 BYTES, SO INTS IS SET TO 4. NOTE THAT THE VALUES FOR C 'REALS' WILL GENERALLY BE DIFFERENT FOR THE SINGLE AND DOUBLE C PRECISION VERSIONS ON THE SAME MACHINE. C C ON ENTRY, THE FOUR ARGUMENTS INDICATE HOW MANY VALUES OF EACH OF C THE FOUR BASIC TYPES ARE REQUIRED TO FIT IN ONE DIRECT ACCESS C UNFORMATTED RECORD. THIS ROUTINE WILL DETERMINE THE MINIMUM RECORD C LENGTH NEEDED TO SATISFY ALL FOUR REQUIREMENTS. THAT VALUE WILL BE C RETURNED AS THE VALUE OF THE FUNCTION ZZRECL. C C IT WILL THEN *RETURN* IN EACH OF THE FOUR ARGUMENTS THE *ACTUAL* C NUMBER OF EACH OF THESE WHICH CAN FIT IN THE RECORD OF THE SIZE C DETERMINED. C C N.B. **** THIS ROUTINE ASSUMES *NO MIXING* OF DATA TYPES ON C ANY ONE RECORD WHEN USING DIRECT ACCESS UNFORMATTED I/O. C THUS EACH TIME A RECORD IS WRITTEN, IT CONTAINS *ONLY* C CHARACTER DATA, OR *ONLY* INTEGER DATA, OR *ONLY* REAL C DATA, OR *ONLY* LOGICAL DATA. ANY MIXING WOULD C TOTALLY DESTROY ANY HOPE OF PORTABILITY TO SOME SYSTEMS. C C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZRECL. C## S U B R O U T I N E S: ABS, MAX ... INTRINSIC C C## P A R A M E T E R S: INTEGER CHARS, INTS, LOGS, REALS PARAMETER ( CHARS = 1, INTS = 4, LOGS = 4, REALS = 4 ) C!!!! PARAMETER ( CHARS = 1, INTS = 4, LOGS = 4, REALS = 8 ) C## L O C A L D E C L: INTEGER N C## S A V E: NONE SELECTED. C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NONE ARE SET. C## E X E C U T I O N C## E X E C U T I O N ZZRECL = 1 IF ( CHARS .LT. 0 ) THEN N = ABS(CHARS) N = ( CPERLN + N - 1 ) / N ELSE N = CPERLN * CHARS ENDIF ZZRECL = MAX ( ZZRECL, N ) IF ( INTS .LT. 0 ) THEN N = ABS(INTS) N = ( IPERLN + N - 1 ) / N ELSE N = IPERLN * INTS ENDIF ZZRECL = MAX ( ZZRECL, N ) IF ( LOGS .LT. 0 ) THEN N = ABS(LOGS) N = ( LPERLN + N - 1 ) / N ELSE N = LPERLN * LOGS ENDIF ZZRECL = MAX ( ZZRECL, N ) IF ( REALS .LT. 0 ) THEN N = ABS(REALS) N = ( RPERLN + N - 1 ) / N ELSE N = RPERLN * REALS ENDIF ZZRECL = MAX ( ZZRECL, N ) C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZRECL. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> mtsg.f PROGRAM ZZMT C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN S I N G L E PRECISION. C!!!! THIS VERSION IS IN D O U B L E PRECISION. C C SYSTEM DEPENDENCE: C THE CURRENT VERSION INCLUDES CODE FOR: C C THIS VERSION IS FOR SUN4 C C>RCS $HEADER: MT.GL,V 2.8 92/01/06 13:49:01 BUCKLEY EXP $ C>RCS $LOG: MT.GL,V $ C>RCS REVISION 2.8 92/01/06 13:49:01 BUCKLEY C>RCS MINOR FIX FOR TOMS C>RCS C>RCS REVISION 2.7 91/12/16 12:22:49 BUCKLEY C>RCS MINOR FIX FOR TOMS. C>RCS C>RCS REVISION 2.6 91/12/16 12:20:11 BUCKLEY C>RCS MINOR FIX FOR TOMS. C>RCS C>RCS REVISION 2.5 90/10/12 13:40:08 BUCKLEY C>RCS FIXED GROUPS C>RCS C>RCS REVISION 2.4 90/10/10 20:38:31 BUCKLEY C>RCS FIXED CASE WHERE NO GROUPS AND NO PROLOG PRESENT. C>RCS C>RCS REVISION 2.3 90/10/04 13:08:09 BUCKLEY C>RCS FIXED BRANCH TO 2060 INSIDE IF C>RCS C>RCS REVISION 2.2 90/08/29 16:45:33 BUCKLEY C>RCS FIXED FILE NAME LENGTH FOR INPUT FILE. C>RCS C>RCS REVISION 2.1 90/08/05 16:07:41 BUCKLEY C>RCS FIXED INITIAL FILE READING WHEN FILES NOT PRESENT. C>RCS C>RCS REVISION 2.0 90/07/31 11:42:40 BUCKLEY C>RCS PRETTY WELL READY TO SEND TO TOMS AGAIN. C>RCS C>RCS REVISION 1.9.1.4 89/07/01 07:25:33 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.9.1.3 89/06/30 21:23:00 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.9.1.2 89/06/30 17:14:47 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.9.1.1 89/06/30 14:58:25 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.9 89/06/30 13:10:09 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.6 89/05/21 12:52:59 BUCKLEY C>RCS MINOR FIXES IN PRNT AND DCOD C>RCS C>RCS REVISION 1.5 89/05/20 21:26:29 BUCKLEY C>RCS TMP C>RCS C>RCS REVISION 1.4 89/05/20 21:04:11 BUCKLEY C>RCS TEMP C>RCS C>RCS REVISION 1.3 89/05/18 12:17:16 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.2 89/05/15 11:17:38 BUCKLEY C>RCS INITIAL MT REVISION INTO RCS FORM. C>RCS C>RCS REVISION 1.1 89/01/17 16:38:11 BUCKLEY C>RCS INITIAL REVISION C>RCS C C## D E S C R I P T I O N: SEE EXTERNAL DESCRIPTION FOR TP. C## E N T R Y P O I N T S: THE NATURAL ENTRY ZZMT. C## S U B R O U T I N E S: C C ==> REVISE C GENERIC: ABS LEN SQRT INDEX C C ZZADDP (ZZASET) ZZNRM2 C ZZAFTR ZZOPEN (ZZCLSE,ZZOSET) C [ZZBASE] ZZPRNT (ZZPSET,ZZPGET) C ZZBFOR ZZPUTG (ZZDEFP) C [ZZBSTR] ZZPUTP (ZZPDEF) C [ZZCNTR] ZZRDCH C [ZZDATE] ZZRDIN C ZZDCOD (ZZDSET) ZZRDLG C ZZDEXP ZZRDRL C ZZDSRT ZZRECL C [ZZDTTM] [ZZSCAL] C ZZERRM (ZZETRM) ZZSECS C ZZEVAL (ZZEGET,ZZESRT,ZZESET,ZZECHK) ZZSHFT C ZZFNS (ZZFPAR,ZZFSET) ZZSMRY C [ZZGETG](ZZDEFG) ZZSORT C ZZGETP (ZZGDEF) ZZSRCH C ZZLADV ZZSTX0 C ZZLENG ZZWRCH C ZZLINK ZZWRIN C ZZLMOD ZZWRLG C ZZLPCK ZZWRRL C [ZZMPAR] C C## P A R A M E T E R S: C+++++ REAL CONSTANT DEFINITIONS, TRUE FALSE STUFF AND++++++++++++++++++ C+++++ PREDEFINED SPECIAL CHARACTERS AND STRINGS +++++++++++++++++++++++ REAL ZERO, ONE, TWO, THREE C!!!! DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) REAL FOUR, FIVE, SIX, SEVEN C!!!! DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) REAL EIGHT, NINE, TEN C!!!! DOUBLE PRECISION EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 9D0, TEN = 10D0 ) LOGICAL T, F PARAMETER ( T = .TRUE., F = .FALSE. ) CHARACTER*(*) TRUE, QT, FALSE, QF PARAMETER ( TRUE = 'TRUE', QT = 'T', FALSE = 'FALSE', QF = 'F' ) INTEGER ITRUE, IFALSE PARAMETER ( ITRUE = 1, IFALSE = 0 ) REAL RTRUE, RFALSE C!!!! DOUBLE PRECISION RTRUE, RFALSE PARAMETER ( RTRUE = 1.D0, RFALSE = 0.D0 ) CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) CHARACTER*(*) PERIOD, COMMA, SEMICN PARAMETER ( PERIOD = '.', COMMA = ',', SEMICN = ';' ) CHARACTER*(*) COLON, DASH, EQUALS PARAMETER ( COLON = ':', DASH = '-', EQUALS = '=' ) CHARACTER*(*) OBRACE, CBRACE, UNDERS PARAMETER ( OBRACE = '{', CBRACE = '}', UNDERS = '_' ) CHARACTER*(*) PLUS, MINUS, EXCLAM PARAMETER ( PLUS = '+', MINUS = '-', EXCLAM = '!' ) CHARACTER*(*) GTHAN, LTHAN, QUESMK PARAMETER ( GTHAN = '>', LTHAN = '<', QUESMK = '?' ) CHARACTER*(*) SLASH, BSLASH, PERCNT PARAMETER ( SLASH = '/', BSLASH = '\\',PERCNT = '%' ) CHARACTER*(*) CARAT, ATSIGN, TILDE PARAMETER ( CARAT = '^', ATSIGN = '@', TILDE = '~' ) INTEGER CTOUPP, CTOLOW, CTOCAP PARAMETER ( CTOUPP = 1, CTOLOW = 2, CTOCAP = 3 ) C+++++ PREDEFINED SPECIAL CHARACTERS AND STRINGS +++++++++++++++++++++++ CHARACTER *(*) UNDEFN PARAMETER ( UNDEFN = 'UNDEFN' ) CHARACTER *(*) ENDIT, TESTCH PARAMETER ( ENDIT = 'END', TESTCH = GTHAN ) C----- DECODE, READ ERROR MAX'S. INTEGER MAXERR, RDERMX PARAMETER ( MAXERR = 3, RDERMX = 5 ) C+++++ INTEGER ENUMERATED CONSTANTS, A LA PASCAL +++++++++++++++++++++++ C----- CODES FOR SORTING. INTEGER SPRNAM, SPRNUM, SASIS, SRECNO PARAMETER ( SPRNAM = 1, SPRNUM = 2, SASIS = 3, SRECNO = 4 ) INTEGER SFNNAM, SFNNUM, SDIMN, SPROLG PARAMETER ( SFNNAM = 5, SFNNUM = 6, SDIMN = 7, SPROLG = 8 ) C----- COMMAND INPUT MODE INTEGER CMODE, PMODE, GMODE PARAMETER ( CMODE = 1, PMODE = 2, GMODE = 3 ) C----- CODES FOR MODE. INTEGER CINTAC, CBATCH PARAMETER ( CINTAC = 1, CBATCH = 2 ) C----- CODES FOR CHECK. INTEGER CHOFF, CHON, CHNAM, CHNUM PARAMETER ( CHOFF = 1, CHON = 2, CHNAM = 3, CHNUM = 4 ) C----- CODES FOR GO. INTEGER CNOGO, CGOGO PARAMETER ( CNOGO = 0, CGOGO = 1 ) C----- CODES FOR SMRY. INTEGER CCOLD, CDOFLE, CDOTRM, NWISHS PARAMETER ( CCOLD = 1, CDOFLE = 2, CDOTRM = 3, NWISHS = 3 ) C----- CODES FOR LOOPS. INTEGER LLIST, LARITH, LGEOMT PARAMETER ( LLIST = 1, LARITH = 2, LGEOMT = 3 ) DOUBLE PRECISION DEFADD, DEFMUL PARAMETER ( DEFADD = 1.0D0, DEFMUL = 10.0D0 ) C ANY FORM OF LOOP REQUIRES 5 ENTRIES IN LOOPC, WHEREAS A LIST C REQUIRES 2, PLUS THE NUMBER OF LIST ELEMENTS, ENTRIES. INTEGER LOOPSP, LISTSP PARAMETER ( LOOPSP = 5, LISTSP = 2 ) C----- CODES FOR VALUES TO PRINT WHEN CURRENT VALUES REQ'D. INTEGER CINPUT, CLOOPS, CCONTR, CALL PARAMETER ( CINPUT = 1, CLOOPS = 2, CCONTR = 3, CALL = 4 ) C----- FLAGS FOR SINGLE/DOUBLE PRECISION, VALUES FOR PARAMETER C CLASSES ( NOTE TYPE REAL ), AND CONSTANTS FOR DECODE MODE. INTEGER SINGLE, DOUBLE PARAMETER ( SINGLE = 1, DOUBLE = 2 ) INTEGER TLOGIC, TYREAL, TINTGR, TSTRNG INTEGER TINTPW, TYCHAR, TINTLT, TYNONE PARAMETER ( TLOGIC = 0, TINTGR = 3, TINTPW = 4 ) PARAMETER ( TINTLT = 5, TYCHAR = 6, TSTRNG = 7, TYNONE = 8 ) PARAMETER ( TYREAL = SINGLE ) C!!!! PARAMETER ( TYREAL = DOUBLE ) C MODES FOR DECODING. INTEGER DCDNEW, DCDDON PARAMETER ( DCDNEW = 0, DCDDON = DCDNEW ) INTEGER DCDOLD, DCDMOR PARAMETER ( DCDOLD = 1, DCDMOR = DCDOLD ) INTEGER DCDREP, DCDERR PARAMETER ( DCDREP = 2, DCDERR = DCDREP ) INTEGER DCDCON, DCDBAD PARAMETER ( DCDCON = 3, DCDBAD = 4 ) INTEGER CONT, DEL, ESC, SEP, RADIX, ASSMT, COM1, COM2 INTEGER RADPRB, RADFUN, RADGRP, STRNG1, STRNG2, LOOPA, LOOPG INTEGER NDCCHS PARAMETER ( CONT = 1, DEL = 2, ESC = 3, SEP = 4, - RADIX = 5, ASSMT = 6, COM1 = 7, COM2 = 8, - RADPRB = 9, RADFUN =10, RADGRP =11, STRNG1 =12, - STRNG2 =13, LOOPA =14, LOOPG =15 ) PARAMETER ( NDCCHS = 15 ) C----- CODES FOR ZZEVAL. INTEGER CANAL, CDIFF, CTEST, CFIRST PARAMETER ( CANAL = 1, CDIFF = 2, CTEST = 3, CFIRST = 4 ) INTEGER JUSTF, BOTH, JUSTG, NOOP PARAMETER ( JUSTF = 1, BOTH = 0, JUSTG = -1, NOOP = 2 ) C----- CODES FOR ZZTERM. INTEGER NL1, NL2, NLINF PARAMETER ( NL1 = 1, NL2 = 2, NLINF = 3 ) INTEGER NQUITS PARAMETER ( NQUITS = 4 ) INTEGER PGRAD, PSTEP, PSHXG, PFUNC PARAMETER ( PGRAD = 1, PSTEP = 2, PSHXG = 3, PFUNC = 4 ) C----- STATUS CODES. C--ON ENTRY: INTEGER CNORML, CRCSTR, CRCRPT, CRCNFG PARAMETER ( CNORML = 0, CRCSTR = 1, CRCRPT = 2, CRCNFG = 3 ) INTEGER CNRMFG, CPSTHR PARAMETER ( CNRMFG = -1, CPSTHR = -2 ) C--ON EXIT: INTEGER CDONE, CRCF, CRCFG, CRCG PARAMETER ( CDONE = 0, CRCF = 1, CRCFG = 2, CRCG = 3 ) INTEGER CNSTOR, CIPMIN, CIPUNF, CBDMTH PARAMETER ( CNSTOR = -1, CIPMIN = -2, CIPUNF = -3, CBDMTH = -4 ) INTEGER CLSFAL, CNODSC, CXSFNC, CPSBCK PARAMETER ( CLSFAL = -5, CNODSC = -6, CXSFNC = -7, CPSBCK = -8 ) INTEGER CRABRT, CUSERV PARAMETER ( CRABRT = -9, CUSERV = -10 ) C----- TERMINAL CHARACTERISTICS, INCLUDING EOF HANDLING C AND AMOUNT OF SUMMARY OUTPUT. INTEGER CNONE, CMIN, CMED, CFULL PARAMETER ( CNONE = 1, CMIN = 2, CMED = 3, CFULL = 4 ) INTEGER CEOFAC, CEOFIG PARAMETER ( CEOFAC = 1, CEOFIG=2 ) INTEGER CCPRSN, CCMISS PARAMETER ( CCPRSN = 1, CCMISS = 2 ) C+++++ CONTROL OVER SIZES OF AND ACCESS TO STRINGS AND ARRAYS ++++++++++ C----- STRING LENGTHS. INTEGER PNAMLN, FNAMLN, GNAMLN PARAMETER ( PNAMLN = 8, FNAMLN = PNAMLN, GNAMLN = PNAMLN ) INTEGER TITLEN, PDESCL PARAMETER ( TITLEN = 72, PDESCL = 72 ) INTEGER INLINE, KEYLEN, PRMPTL PARAMETER ( INLINE =100, KEYLEN = 8, PRMPTL = 27 ) C----- ARRAY SIZES. INTEGER MAXN PARAMETER ( MAXN = 10000 ) INTEGER NOFNS, DFPRBS, MXGRPS, MXGSZ PARAMETER ( NOFNS = 80, DFPRBS = 450, MXGRPS = 50, MXGSZ = 200 ) INTEGER NULLIN, MXCRIT, RGL PARAMETER ( NULLIN=0, MXCRIT=20, RGL=MXCRIT+1 ) INTEGER ERL, CPL, SVL PARAMETER ( ERL=MXCRIT+2, CPL=MXCRIT+3, SVL=MXCRIT+4 ) INTEGER NL PARAMETER ( NL = MXCRIT+4 ) INTEGER MXPARS, MXPRBS, MXSOLN PARAMETER ( MXPARS = 80, MXPRBS = 50, MXSOLN = 5*MAXN ) INTEGER LR, LI PARAMETER ( LR = 10*MAXN, LI = 5*MAXN ) INTEGER EXTRA, NTR PARAMETER ( EXTRA = 5*MAXN, NTR = 15 ) C----- NUMBER OF SUBROUTINE NAMES. INTEGER MXSUBS PARAMETER ( MXSUBS = 5 ) C----- NUMBER OF FUNCTION ARGUMENTS. INTEGER FNO PARAMETER ( FNO = 10 ) C----- NUMBER OF USER DEFINABLE ARGUMENT NAMES. INTEGER NU PARAMETER ( NU = 21 ) INTEGER DUSRNO PARAMETER ( DUSRNO = 0 ) C----- POSITION FLAGS FOR ENTRIES IN THE PRECNO ARRAY. C DEFINITIONS OF THE ROWS IN THE ARRAY PRECNO. ( PRECNO HOLDS THE C RECORD NUMBER IN THE DAUF FILE, THE MINIMUM DIMENSION, AND THE C FUNCTION NUMBER OF EACH PROBLEM. ) INTEGER RECN, DIMN, FNO1 PARAMETER ( RECN = 1, DIMN = 2, FNO1 = 3 ) C----- POSITION FLAGS FOR ENTRIES IN THE PINTS ARRAY. INTEGER PPTMAX, PPTIX0, PPTDES PARAMETER ( PPTMAX = 1, PPTIX0 = 2, PPTDES = 3 ) INTEGER PPTORD, PPTLPX, PPTLPC, PPTSOL PARAMETER ( PPTORD = 4, PPTLPX = 5, PPTLPC = 6, PPTSOL = 7 ) INTEGER NPNTS PARAMETER ( NPNTS = 7 ) C----- SET UP OUTER LOOP POINTERS; PTUSER WILL BE INITIALIZED AT C THE START OF EXECUTION SINCE IT IS AN ARRAY. INTEGER PTACC, PTFACT, PTGXPN PARAMETER ( PTACC = 1, PTFACT = PTACC + 1, PTGXPN = PTFACT + 1) INTEGER NOUTER, PTUSER(NU) PARAMETER ( NOUTER = 3 ) C----- SET UP INNER LOOP POINTERS; PTFARG WILL BE INITIALIZED AT C THE START OF EXECUTION SINCE IT IS AN ARRAY. INTEGER PTNDIM, PTSCAL, PTPXPN PARAMETER ( PTNDIM = 1, PTSCAL = 2, PTPXPN = 3 ) INTEGER NINNER PARAMETER ( NINNER = 3 ) INTEGER PTFARG(FNO) C----- SET UP PARAMETERS DEFINING SIZES OF LOOP ARRAYS. INTEGER ILPXSZ, ILPCSZ PARAMETER ( ILPXSZ = FNO + NINNER, ILPCSZ = 5 * ILPXSZ ) INTEGER OLPXSZ, OLPCSZ PARAMETER ( OLPXSZ = NU + NOUTER, OLPCSZ = 5 * OLPXSZ ) C+++++ DEFINITIONS OF I/O UNITS ++++++++++++++++++++++++++++++++++++++++ INTEGER PREPRC, DAUF, INPTUN PARAMETER ( PREPRC = 1, DAUF = 2, INPTUN = 3 ) INTEGER TEMPUN, STDIN, TRMOUT PARAMETER ( TEMPUN = 4, STDIN = 5, TRMOUT = 6 ) INTEGER WRITUN, TRACUN, SUMMUN PARAMETER ( WRITUN = 7, TRACUN = 8, SUMMUN = 9 ) INTEGER COPYUN, TEXUN PARAMETER ( COPYUN =10, TEXUN =11 ) INTEGER FILENL, NFILES PARAMETER ( FILENL = 80, NFILES = 15 ) CHARACTER *( FILENL ) NMPRLG, NMTRMI, NMTEMP, NMPROB, NMGRPS CHARACTER *( FILENL ) NMSUMM, NMDAUF, NMCOPY, NMBATC PARAMETER ( NMPRLG = 'PROLOG', NMDAUF = 'DAUF', NMTEMP = BLANK, - NMTRMI = BLANK, NMSUMM = BLANK, NMPROB ='DEFNS', - NMGRPS = 'GROUPS', NMCOPY = 'COPY', NMBATC ='BATCH') C RECORD LENGTH FOR SEQUENTIAL FILES. INTEGER RECL PARAMETER ( RECL = 0 ) C LINE LENGTHS REQUIRED FOR DIRECT ACCESS UNFORMATTED RECORDS. INTEGER DCPRLN, DLPRLN, DIPRLN, DRPRLN PARAMETER ( DCPRLN = 16, DLPRLN = 4, DIPRLN = 4, DRPRLN = 2 ) C+++++ DEFAULT VALUES ++++++++++++++++++++++++++++++++++++++++++++++++++ C----- TRACE VALUES, MISSING PARAMETERS AND USER PARAMETERS. REAL DFLT, DUSVAL C!!!! DOUBLE PRECISION DFLT, DUSVAL LOGICAL DTRVAL PARAMETER ( DTRVAL = F, DFLT = ONE , DUSVAL = ZERO ) C----- SPECIAL CHARACTERS FOR DECODING. CHARACTER * 1 DCONTN, DDLIMT, DESCAP, DSEPAR, DRADIX, DASSMT CHARACTER * 1 DCOM1, DCOM2, DRDPRB, DRDFUN, DRDGRP, DSTRG1 CHARACTER * 1 DSTRG2, DLOOPA, DLOOPG PARAMETER ( DCONTN = '$', DDLIMT = ',', DESCAP = '!' ) PARAMETER ( DSEPAR = ';', DRADIX = '/', DASSMT = '=' ) PARAMETER ( DCOM1 = '<', DCOM2 = '>', DSTRG1 = '''' ) PARAMETER ( DSTRG2 = '"', DLOOPA = ':', DLOOPG = '*' ) PARAMETER ( DRDPRB = 'P', DRDFUN = 'F', DRDGRP = 'G' ) C----- TITLE REQUIRED FOR STEP 1. LOGICAL DTITLR PARAMETER ( DTITLR = T ) C----- SORTING. LOGICAL DASC INTEGER DSORT PARAMETER ( DSORT = SASIS, DASC = T ) C----- SUBROUTINE NUMBER AND COMMUNICATION METHOD. INTEGER DSUBR LOGICAL DREVRS PARAMETER ( DSUBR = 1, DREVRS = F ) C----- FOR ZZEVAL. INTEGER DGXPNS LOGICAL DTRF, DTRG, DETRAC PARAMETER ( DTRF = F, DTRG = F, DETRAC = F, DGXPNS = 1 ) INTEGER DDERV, DPXPNS PARAMETER ( DDERV = CANAL, DPXPNS = 0 ) C----- FOR ZZPRNT. LOGICAL DGRAD, DPOINT, DIGRAD PARAMETER ( DGRAD = T, DPOINT = T, DIGRAD = F ) LOGICAL DIPT, DLOCAL PARAMETER ( DIPT = T, DLOCAL = F ) INTEGER DPRINT, DIPR PARAMETER ( DPRINT = -1000, DIPR = 0 ) C----- FACTOR FOR STARTING POINT FOR ZZSTX0. REAL DFACTR C!!!! DOUBLE PRECISION DFACTR PARAMETER ( DFACTR = ONE ) C----- LIST OF CRITERIA. INTEGER DCRIT PARAMETER ( DCRIT = 0 ) C----- FOR ZZTERM. REAL DACC C!!!! DOUBLE PRECISION DACC INTEGER DNORM PARAMETER ( DNORM = NL2, DACC = 1.D-5 ) LOGICAL DTTRAC, DRELF, DRELG PARAMETER ( DTTRAC = F, DRELF = T, DRELG = T ) CHARACTER *(*) DQUITS PARAMETER ( DQUITS = 'FTTF' ) C----- PROBLEM DEFAULTS INTEGER DMAXF, DNDIM, DSCAL, DPEXPS PARAMETER ( DMAXF = 200, DNDIM = 2, DSCAL = 0, DPEXPS = 0 ) LOGICAL DPERM PARAMETER ( DPERM = T ) INTEGER DARGNO REAL DFARG C!!!! DOUBLE PRECISION DFARG PARAMETER ( DFARG = DFLT, DARGNO = 0 ) INTEGER DIX0 REAL DX1, DX2 C!!!! DOUBLE PRECISION DX1, DX2 PARAMETER ( DIX0 = 2, DX1 = ZERO, DX2 = ZERO ) C----- OUTPUT LEVEL FOR SMRY. INTEGER DSELEV LOGICAL DLONGF PARAMETER ( DSELEV = CMIN, DLONGF = F ) C+++++ DEFAULTS FOR I/O CONTROL ++++++++++++++++++++++++++++++++++++++++ CHARACTER *( FILENL ) DNMWRT, DNMTRC, DNTRMO PARAMETER ( DNMWRT = 'RESULT', DNMTRC = 'TRACE', DNTRMO = BLANK ) C INPUT AND OUTPUT FLAGS. LOGICAL DWRSUM, DUPCAS, DEOF, DVRIFY, DIMMED, DCOPY, DTEX LOGICAL DINTAC, DCDTRC, DCHECK, DBRIEF, DTRMRD, DFLTRC PARAMETER ( DWRSUM = T, DUPCAS = F, DEOF = F, DCOPY = F, - DVRIFY = F, DINTAC = F, DCDTRC = F, DTEX = F, - DCHECK = T, DBRIEF = F, DTRMRD = T, - DFLTRC = F, DIMMED = F ) C+++++ DEFINE STRUCTURES AND ENTRIES FOR DICTIONARY FOR COMMAND MODE. C NUMBER OF ENTRIES IN THE DICTIONARIES. INTEGER NCMDS, NCPARS, NDEFS, NDPARS C DECLARE COMMAND AND PARAMETER STRINGS. CHARACTER * (*) CCMDS, CPAR, DEFN, DPAR C DEFINE KEYWORDS FOR COMMANDS. PARAMETER( CCMDS = 'ABORT '//'ACCURACY'//'ADD '//'ARITHMET' - //'ASCENDIN'//'ASSIGNME'//'BRIEF '//'BYE '//'CC ' - //'CHECK '//'COMMENT '//'CONTINUA'//'COPY '//'CRITERIA' - //'DECODE '//'DEFAULT '//'DEFINITI'//'DELIMITE'//'DERIVATI' - //'DESCENDI'//'DOSUMMAR'//'DROP '//'END ' - //'EOF '//'ESCAPE '//'EVTRACE '//'EXPENSE '//'FABSOLUT' - //'FACTOR '//'FORWARD '//'FREE '//'FRELATIV'//'FTRACE ' - //'GABSOLUT' - // - 'GEOMETRI'//'GRELATIV'//'GTRACE '//'IMMEDIAT'//'INPUT ' - // 'LIST '//'LONGF '//'MEMORY '//'MODE ' - //'NORM '// 'PGRADIEN'//'POINT ' - //'PRINT '//'QUIT '//'RADIX '//'RENAME ' - //'REQUIRED'//'RESET '//'RESULTS '//'REVERSE '//'SEE ' - //'SELECT '//'SEPARATO'//'SORT '//'START '//'STRING ' - //'SUBROUTI'//'SUMMARY '//'TERMINAT'//'TEX '//'TITLE ' - //'TRACES '//'TRACEUN ' - // - 'TTRACE '//'UPPERCAS'//'USER '//'VALUES '//'VERIFY ' - //'WATCH '//'WITH ') C DEFINE PARAMETERS. PARAMETER( CPAR = 'ABSSUM '//'ACTIVE '//'ALL '//'ANALYTIC' - //'ASIS '//'BATCH '//'CONTROL ' - //'DIFFEREN'//'DIMENSIO'//'EUCLIDEA'//'FIRST '//'FNAME ' - //'FNO '//'FNUMBER '//'FROBENIU'//'FULL '//'GO ' - //'IGNORED '//'INFINITY'//'INPUT '//'INTERACT' - //'LOOPS '//'L1 '//'L2 '//'MAXIMUM '//'MEDIUM ' - //'MINIMAL '//'MISSING '//'NAMES '//'NO '//'NONE ' - // - 'NULL '//'NUMBERS '//'OFF '//'OK '//'ON ' - //'PNAME '//'PNO '//'PNUMBER '//'PRESENT '//'PROLOG ' - //'RECORDNO'//'RUN ' - //'SUPREMUM'//'TESTMODE'//'YES ' ) C DEFINE STRUCTURE FOR COMMAND DICTIONARY. C SET UP NAMED INDEX FOR EACH KEYWORD. ALL ARE INTEGERS. INTEGER XABORT, XACCUR, XADD, XARITH, XASC, XASSMT, - XBRIEF, XBYE, XCC, XCHECK, XCOMME, XCONTI, XCOPY, XCRIT, - XDECOD, XDEFAU, - XDEFIN, XDELIM, XDERIV, XDESC, XDOSUM, XDROP, XEND, - XEOF, XESCAP, XEVTRC, XEXPNS, XFABS, XFACTO, XFORWO, XFREE, - XFREL, XFTRAC, XGABS, XGEOME, - XGREL, XGTRAC, XIMMED, XINPUT, XLIST, XLONGF, - XMEMOR, XMODE, XNORM, XPGRAD, XPOINT, - XPRINT, XQUIT, XRADIX, XRENAM, XREQUI, XRESET, XRESUL, XREVER, - XSEE, XSELCT, XSEPAR, XSORT, XSTART, - XSTRIN, XSUBRO, XSUMMA, XTERM, XTEX, XTITLE, XTRACE, XTRCUN, - XTTRAC, XUPPER, XUSER, XVALUE, XVERIF, XWATCH, XWITH, XXLAST PARAMETER ( XABORT= 1,XACCUR=XABORT+1,XADD =XACCUR+1, - XARITH=XADD +1,XASC =XARITH+1,XASSMT=XASC +1, - XBRIEF=XASSMT+1,XBYE =XBRIEF+1,XCC =XBYE +1,XCHECK=XCC +1, - XCOMME=XCHECK+1,XCONTI=XCOMME+1,XCOPY =XCONTI+1,XCRIT =XCOPY +1, - XDECOD=XCRIT +1,XDEFAU=XDECOD+1, - XDEFIN=XDEFAU+1,XDELIM=XDEFIN+1,XDERIV=XDELIM+1,XDESC =XDERIV+1, - XDOSUM=XDESC +1,XDROP =XDOSUM+1,XEND =XDROP +1,XEOF =XEND +1, - XESCAP=XEOF +1,XEVTRC=XESCAP+1,XEXPNS=XEVTRC+1,XFABS =XEXPNS+1, - XFACTO=XFABS +1,XFORWO=XFACTO+1,XFREE =XFORWO+1,XFREL =XFREE +1, - XFTRAC=XFREL +1,XGABS =XFTRAC+1, - XGEOME=XGABS +1,XGREL =XGEOME+1,XGTRAC=XGREL +1,XIMMED=XGTRAC+1, - XINPUT=XIMMED+1,XLIST =XINPUT+1,XLONGF=XLIST +1, - XMEMOR=XLONGF+1,XMODE =XMEMOR+1,XNORM =XMODE +1,XPGRAD=XNORM +1) PARAMETER ( XPOINT=XPGRAD+1, - XPRINT=XPOINT+1,XQUIT =XPRINT+1,XRADIX=XQUIT +1,XRENAM=XRADIX+1, - XREQUI=XRENAM+1,XRESET=XREQUI+1,XRESUL=XRESET+1,XREVER=XRESUL+1, - XSEE =XREVER+1,XSELCT=XSEE +1,XSEPAR=XSELCT+1,XSORT =XSEPAR+1, - XSTART=XSORT +1, - XSTRIN=XSTART+1,XSUBRO=XSTRIN+1,XSUMMA=XSUBRO+1,XTERM =XSUMMA+1, - XTEX =XTERM +1,XTITLE=XTEX +1, - XTRACE=XTITLE+1,XTRCUN=XTRACE+1,XTTRAC=XTRCUN+1,XUPPER=XTTRAC+1, - XUSER =XUPPER+1,XVALUE=XUSER +1,XVERIF=XVALUE+1,XWATCH=XVERIF+1, - XWITH =XWATCH+1, - XXLAST=XWITH ) PARAMETER ( NCMDS = XXLAST+NU ) C DEFINE STRUCTURES FOR KEYWORD PARAMETERS FOR COMMANDS. INTEGER ZABSSU, ZACTIV, ZALL , ZANALY, ZASIS , ZBATCH, - ZCONTR, ZDIFFE, ZDIMEN, ZEUCLI, ZFIRST, ZFNAME, ZFNO , - ZFNUMB, ZFROBE, ZFULL , ZGO, ZIGNOR, ZINFIN, ZINPUT, - ZINTER, ZLOOPS, ZL1 , ZL2 , ZMAXIM, ZMEDIM, ZMINIM, ZMISSI, - ZNAMES, ZNO , ZNONE, ZNULL, ZNUMBE, ZOFF, ZOK, ZON , - ZPNAME, ZPNO , ZPNUMB, ZPRESE, ZPROLG, ZRECNO, ZRUN, - ZSUPRE, ZTESTM, ZYES, ZZLAST PARAMETER ( ZABSSU= 1,ZACTIV=ZABSSU+1,ZALL =ZACTIV+1, - ZANALY=ZALL +1,ZASIS =ZANALY+1,ZBATCH=ZASIS +1, - ZCONTR=ZBATCH+1,ZDIFFE=ZCONTR+1,ZDIMEN=ZDIFFE+1,ZEUCLI=ZDIMEN+1, - ZFIRST=ZEUCLI+1,ZFNAME=ZFIRST+1,ZFNO =ZFNAME+1,ZFNUMB=ZFNO +1, - ZFROBE=ZFNUMB+1,ZFULL =ZFROBE+1,ZGO =ZFULL +1, - ZIGNOR=ZGO +1,ZINFIN=ZIGNOR+1,ZINPUT=ZINFIN+1,ZINTER=ZINPUT+1, - ZLOOPS=ZINTER+1,ZL1 =ZLOOPS+1,ZL2 =ZL1 +1,ZMAXIM=ZL2 +1, - ZMEDIM=ZMAXIM+1,ZMINIM=ZMEDIM+1,ZMISSI=ZMINIM+1,ZNAMES=ZMISSI+1, - ZNO =ZNAMES+1,ZNONE =ZNO +1,ZNULL =ZNONE +1,ZNUMBE=ZNULL +1, - ZOFF =ZNUMBE+1,ZOK =ZOFF +1,ZON =ZOK +1,ZPNAME=ZON +1, - ZPNO =ZPNAME+1,ZPNUMB=ZPNO +1,ZPRESE=ZPNUMB+1,ZPROLG=ZPRESE+1, - ZRECNO=ZPROLG+1,ZRUN =ZRECNO+1, - ZSUPRE=ZRUN +1,ZTESTM=ZSUPRE+1,ZYES =ZTESTM+1, - ZZLAST=ZYES ) PARAMETER ( NCPARS = ZZLAST + MXSUBS ) C DEFINE STRUCTURE FOR PROBLEM DEFINITION DICTIONARY. C SET UP NAMED INDEX FOR EACH KEYWORD. ALL ARE INTEGERS. C-----CREATION OF THE DEFINITION DICTIONARY. PARAMETER( DEFN = 'ADD '//'ARGUMENT'//'DEFINITI'//'DESCRIPT' - //'DIMENSIO'//'DROP '//'END '//'EXPENSE '//'FUNCTION' - //'GROUP '//'LIMIT '//'MAX '//'N '//'PERMANEN' - //'PROBLEM '//'SCALE '//'SELECT ' - //'SOLUTION'//'START '//'TEMPORAR'//'USE '//'X0 ') C THERE ARE NO NAMED PARAMETERS IN DEFINITION MODE. PARAMETER ( DPAR = ' ' ) INTEGER QADD, QARG , QDEFN, QDESCR, QDIMEN, QDROP, QEND , - QEXPNS, QFUNCT, QGROUP, QLIMIT, QMAX , QN , QPERMA, - QPROBL, QSCALE, QSELCT, QSOLN , - QSTART, QTEMP , QUSE , QX , QQLAST PARAMETER ( QADD = 1,QARG =QADD +1,QDEFN =QARG +1, - QDESCR=QDEFN +1,QDIMEN=QDESCR+1,QDROP =QDIMEN+1, - QEND =QDROP +1,QEXPNS=QEND +1,QFUNCT=QEXPNS+1,QGROUP=QFUNCT+1, - QLIMIT=QGROUP+1,QMAX =QLIMIT+1,QN =QMAX +1, - QPERMA=QN +1,QPROBL=QPERMA+1,QSCALE=QPROBL+1,QSELCT=QSCALE+1, - QSOLN =QSELCT+1, - QSTART=QSOLN +1,QTEMP =QSTART+1,QUSE =QTEMP +1,QX =QUSE +1, - QQLAST=QX ) PARAMETER ( NDEFS = QQLAST ) PARAMETER ( NDPARS = 1 ) C## L O C A L D E C L: C----- EXTERNAL FUNCTIONS. INTEGER ZZLENG, ZZRECL EXTERNAL ZZFNS, ZZLENG, ZZRECL REAL ZZNRM2, RD C!!!! DOUBLE PRECISION ZZNRM2, RD C-----REMOTE BLOCKS. INTEGER REMOT1, REMOT2, REMOT4, REMOT5, REMOT7 INTEGER RETRN1, RETRN2, RETRN4, RETRN5, RETRN7, RETERR C-----ARRAYS AND I/O STRINGS, EXCEPT FOR DICTIONARIES. INTEGER IW(EXTRA) REAL RW(EXTRA) DOUBLE PRECISION DW(EXTRA) REAL G(MAXN), RWORK(LR), X(MAXN), SOLNS(MXSOLN) C!!!! DOUBLE PRECISION G(MAXN), RWORK(LR), X(MAXN), SOLNS(MXSOLN) REAL PARS(MXPARS), USER(NU), USERD(NU), X0(MAXN) C!!!! DOUBLE PRECISION PARS(MXPARS), USER(NU), USERD(NU), X0(MAXN) LOGICAL TRACES(NTR) INTEGER LIST(MXPRBS), IWORK(LI), PRECNO(3,DFPRBS), GROUPS(MXGRPS) INTEGER MAP1(NCMDS), INVMP1(NCMDS), MAP2(NDEFS), INVMP2(NDEFS) INTEGER MAP3(NCPARS), INVMP3(NCPARS) INTEGER ILOOPX(ILPXSZ+1), IORDER(ILPXSZ) INTEGER OLOOPX(OLPXSZ+1), OORDER(OLPXSZ) REAL ILOOPC(ILPCSZ), OLOOPC(OLPCSZ) C!!!! DOUBLE PRECISION ILOOPC(ILPCSZ), OLOOPC(OLPCSZ) CHARACTER *(KEYLEN) KEYSTR(MXPARS), S1, S2 CHARACTER *((PNAMLN+FNAMLN)*DFPRBS) NAMES CHARACTER *(GNAMLN*MXGRPS) GNAMES CHARACTER *(TITLEN) TITLE CHARACTER *(INLINE) LL(NL) CHARACTER *(FILENL) NMWRIT, NMTRAC, NMNEXT, NMTRMO, NMCURR CHARACTER *(PRMPTL) PROMPT(9) C-----DECLARATIONS OF KEYWORD DICTIONARIES. CHARACTER * ( KEYLEN*NCMDS ) CMDS CHARACTER * ( KEYLEN*NDEFS ) DEFNS INTEGER CINF(NCMDS,2), DINF(NDEFS,2) C-----PARAMETER NAME KEYWORDS. CHARACTER *(KEYLEN*NCPARS) CPARS CHARACTER *(KEYLEN*NDPARS) DPARS INTEGER CPINF(NCPARS,2), DPINF(NDPARS,2) C-----DECLARATION OF CONTROL ON TITLE REQUIREMENT. LOGICAL TITREQ C-----I/O DEFINITIONS. INTEGER READUN, SEELEV, NEXTUN, TRCOUT, RESOUT INTEGER CPERLN, IPERLN, LPERLN, RPERLN INTEGER RECLEN, RECNO, RECP LOGICAL WRTSUM, CHECK, INTACT, VERIFY, LONGF, IMMED LOGICAL BRIEF, DCTRAC, UPCASE, EOFBLK, FLTRAC, COPY, TEX C-----STATUS CODES. INTEGER NORMFG, NORMAL, RCSTRT, RCRPT, RCNOFG, PSTHRU INTEGER DONE, RCF, RCFG, RCG, NOSTOR, IPMIN, PSBACK INTEGER IPUNDF, BDMETH, LSFAIL, NODESC, XSFUNC, RABORT, USERV C-----VARIABLE DECLARATIONS OF A MISCELLANEOUS TYPE. LOGICAL GOTDAF, SORTFL, EOPH, OVER, TRMRD, OUTER, TODO(NWISHS) LOGICAL SEPART, CRITLN, NONE, GLBLOK, PRMISS, NOPRLG, FAKEIT CHARACTER*10 CNORM(3), CTYPE(5), CDERV(4) CHARACTER*10 VCHEC(4), VCC (2), VSEE (4), VSORT(7) CHARACTER*1 LASTDL, CH INTEGER KEYNO, DCDMOD, PARCT, NPROBS, DEFNMD, ERRFLG, LNO INTEGER PROBCT, MAPKEY, PROB, LINELN, PHASE, IPTYPE, LASTLN INTEGER STATUS, ITCT, SVPHAS, SAVUNT, LISTCD, VALS, TMPUN INTEGER I, J, K, II, JJ, KK, N, SCAL, PTSOLN, SOLNX, LPTYPE INTEGER OSCAL, OINDEX, CNEXT, SOLNF, CASE, FREEPT INTEGER USERNO, ARGNO, TCT, CRITNO, RDERCT, RPSOUT REAL PRTIME, TM, TMIN, GSQ, PAR1, FNC, TFUNC, TIMEIT C!!!! DOUBLE PRECISION PRTIME, TM, TMIN, GSQ, PAR1, FNC, TFUNC, TIMEIT REAL VALUE, MING, MAXG, DF, DX, FSTAR C!!!! DOUBLE PRECISION VALUE, MING, MAXG, DF, DX, FSTAR C-----VARIABLES FOR TERMINAL CHARACTERISTICS. INTEGER SYSCC C-----DEFINITION OF SUBROUTINE, SORTING, MEMORY AND COMMUNICATION. INTEGER SUBR, SORT, MEMORY CHARACTER * ( KEYLEN ) SUBNAM LOGICAL REVERS, ASC C-----SPECIAL CHARACTERS. CHARACTER *(NDCCHS) DCC C-----ERROR COUNTER FOR ZZDCOD ERRORS. INTEGER ERRCNT C-----VARIABLES FOR ZZEVAL. INTEGER FUNCCT, GRADCT, DERVMD, INDX, GCNT INTEGER EXPENS, GEXPNS, PEXPNS LOGICAL TRF, TRG, EVTRAC REAL MXERR, DIGS C!!!! DOUBLE PRECISION MXERR, DIGS C-----VARIABLES FOR ZZFNS. REAL FARG(FNO) C!!!! DOUBLE PRECISION FARG(FNO) C-----VARIABLES FOR ZZPRNT. INTEGER PRINTL, IPRL LOGICAL GRAD, WRITFL, POINT, IGRAD, IPOINT, LOCAL C-----STARTING POINT FACTOR FOR ZZSTX0. REAL FACTOR C!!!! DOUBLE PRECISION FACTOR C-----DECLARATIONS FOR VARIABLES FOR ZZTERM AND ACCURACY. INTEGER NORM LOGICAL TTRACE, RELF, RELG CHARACTER *(NQUITS) QUITS REAL ACC C!!!! DOUBLE PRECISION ACC C----- DECLARE PROBLEM STORAGE VARIABLES FOR GETG, GETP, PUTG, PUTP INTEGER PPNUM, PFNUM, PMAX, IX0, TPPNUM INTEGER LORDER, LLOOPX, LLOOPC, LDESC LOGICAL PPERM CHARACTER * (PNAMLN) PPNAM, TPPNAM CHARACTER * (FNAMLN) PFNAM CHARACTER * (PDESCL) PDESC REAL LPDATA(ILPCSZ) C!!!! DOUBLE PRECISION LPDATA(ILPCSZ) C----- DECLARE FOR GROUP DEFINITIONS INTEGER PGNUM, GRPSZ, GMEMBS( MXGSZ ), G1( MXGSZ ) CHARACTER * (GNAMLN) PGNAM C## S A V E: NONE SELECTED. C## E Q U I V A L E N C E S: INTEGER PINTS(NPNTS) EQUIVALENCE (PINTS(PPTMAX),PMAX ),(PINTS(PPTIX0),IX0 ) EQUIVALENCE (PINTS(PPTDES),LDESC ),(PINTS(PPTORD),LORDER) EQUIVALENCE (PINTS(PPTLPX),LLOOPX),(PINTS(PPTLPC),LLOOPC) EQUIVALENCE (PINTS(PPTSOL),PTSOLN) C## C O M M O N: NONE IS DEFINED. C## D A T A: NO DATA VALUES SET. C----- STATUS CONSTANTS. DATA NORMFG/CNRMFG/, NORMAL/CNORML/, RCSTRT/CRCSTR/, - RCRPT /CRCRPT/, RCNOFG/CRCNFG/, PSTHRU/CPSTHR/ DATA DONE /CDONE/, RCF /CRCF/, RCFG /CRCFG/, RCG/CRCG/ - NOSTOR/CNSTOR/, IPMIN /CIPMIN/, IPUNDF/CIPUNF/, - BDMETH/CBDMTH/, LSFAIL/CLSFAL/, NODESC/CNODSC/, - RABORT/CRABRT/, XSFUNC/CXSFNC/, USERV /CUSERV/, - PSBACK/CPSBCK/ C>> C-----DEFINE I/O UNITS AND CONTROL FOR DIRECT ACCESS I/O . DATA NMWRIT /DNMWRT/, NMTRAC /DNMTRC/ DATA CPERLN /DCPRLN/, IPERLN /DIPRLN/ DATA LPERLN /DLPRLN/, RPERLN /DRPRLN/ DATA TRCOUT/TRACUN/, RESOUT/WRITUN/ C-----DEFINE I/O CONTROL. DATA WRTSUM/DWRSUM/, SEELEV/DSELEV/, UPCASE/DUPCAS/ DATA VERIFY/DVRIFY/, INTACT/DINTAC/, DCTRAC/DCDTRC/ DATA EOFBLK/DEOF/, CHECK /DCHECK/, TRMRD /DTRMRD/ DATA FLTRAC/DFLTRC/, LONGF /DLONGF/, IMMED /DIMMED/ DATA COPY /DCOPY /, TEX /DTEX / C-----DEFAULTS FOR COMMAND DECODING. DATA DCDMOD /DCDDON/, DEFNMD /CMODE/, CRITNO/DCRIT/ DATA ERRCNT / 0 / C-----DEFINE TRACES. DATA TRACES/ NTR * DTRVAL / C-----DEFINE SPECIAL CHARACTERS. DATA DCC(CONT :CONT ) /DCONTN/, DCC(DEL :DEL ) /DDLIMT/ DATA DCC(ESC :ESC ) /DESCAP/, DCC(SEP :SEP ) /DSEPAR/ DATA DCC(RADIX :RADIX ) /DRADIX/, DCC(ASSMT :ASSMT ) /DASSMT/ DATA DCC(COM1 :COM1 ) /DCOM1 /, DCC(COM2 :COM2 ) /DCOM2 / DATA DCC(RADPRB:RADPRB) /DRDPRB/, DCC(RADFUN:RADFUN) /DRDFUN/ DATA DCC(RADGRP:RADGRP) /DRDGRP/, DCC(STRNG1:STRNG1) /DSTRG1/ DATA DCC(STRNG2:STRNG2) /DSTRG2/, DCC(LOOPA :LOOPA ) /DLOOPA/ DATA DCC(LOOPG :LOOPG ) /DLOOPG/ C-----SET DEFAULT FOR STANDARD USER PARAMETERS. DATA USERD /NU * DUSVAL/, USERNO/DUSRNO/ DATA USER /NU * DUSVAL/ C-----DEFAULTS PROBLEM LIST. DATA LISTCD /CHON/ C-----DEFAULTS FOR TERMINAL CHARACTERISTICS. DATA SYSCC /CCMISS/ C-----DEFAULTS FOR ZZFNS. DATA ARGNO/DARGNO/ C-----DEFAULTS FOR ZZEVAL. DATA TRF /DTRF/, TRG /DTRG/, EVTRAC/DETRAC/ DATA GEXPNS/DGXPNS/, PEXPNS/DPXPNS/ C-----DEFAULTS FOR ZZPRNT. DATA GRAD /DGRAD/, POINT /DPOINT/, PRINTL/DPRINT/ DATA IGRAD /DIGRAD/, IPOINT/DIPT /, LOCAL /DLOCAL/ C-----DEFAULTS FOR ZZTERM. DATA NORM /DNORM/, QUITS/DQUITS/ DATA TTRACE/DTTRAC/, RELF /DRELF/, RELG/DRELG/ C-----DEFAULTS FOR ZZSTX0. DATA FACTOR /DFACTR/ C-----DEFAULT FOR SUBROUTINE AND COMMUNICATION. DATA SUBR /DSUBR/, REVERS/DREVRS/ C-----DEFAULTS FOR SORT. DATA ASC/DASC/ C-----FOR CRITERIA. DATA LL/NL*BLANK/ C-----DEFAULTS FOR TITLE AND TITLE REQUIREMENT FOR PHASE 1. DATA TITLE /BLANK / DATA TITREQ /DTITLR/ C-----CREATION OF STANDARD PART OF COMMAND DICTIONARY AND PARAMETERS. DATA DEFNS /DEFN/ DATA CMDS /CCMDS/ DATA CPARS /CPAR/ DATA DPARS /DPAR/ C # OF PARAMETERS TYPE OF PARAMETER DATA - CINF(XABORT,1)/ 0 /, CINF(XABORT,2)/TYNONE/, - CINF(XACCUR,1)/MXPARS/, CINF(XACCUR,2)/TYREAL/, - CINF(XADD ,1)/MXPARS/, CINF(XADD ,2)/TINTLT/, - CINF(XARITH,1)/ 1 /, CINF(XARITH,2)/TYCHAR/, - CINF(XASC ,1)/ 0 /, CINF(XASC ,2)/TLOGIC/, - CINF(XASSMT,1)/ 1 /, CINF(XASSMT,2)/TYCHAR/, - CINF(XBRIEF,1)/ 0 /, CINF(XBRIEF,2)/TLOGIC/, - CINF(XBYE ,1)/ 0 /, CINF(XBYE ,2)/TYNONE/, - CINF(XCC ,1)/ 1 /, CINF(XCC ,2)/TINTPW/ DATA - CINF(XCHECK,1)/ 1 /, CINF(XCHECK,2)/TINTPW/, - CINF(XCOMME,1)/ 2 /, CINF(XCOMME,2)/TYCHAR/, - CINF(XCONTI,1)/ 1 /, CINF(XCONTI,2)/TYCHAR/, - CINF(XCOPY ,1)/ 0 /, CINF(XCOPY ,2)/TLOGIC/, - CINF(XCRIT ,1)/ 2 /, CINF(XCRIT ,2)/TINTLT/, - CINF(XDECOD,1)/ 0 /, CINF(XDECOD,2)/TLOGIC/, - CINF(XDEFAU,1)/ 0 /, CINF(XDEFAU,2)/TYNONE/, - CINF(XDEFIN,1)/ 0 /, CINF(XDEFIN,2)/TYNONE/, - CINF(XDELIM,1)/ 1 /, CINF(XDELIM,2)/TYCHAR/, - CINF(XDERIV,1)/ 1 /, CINF(XDERIV,2)/TINTPW/, - CINF(XDESC ,1)/ 0 /, CINF(XDESC ,2)/TLOGIC/, - CINF(XDOSUM,1)/ 0 /, CINF(XDOSUM,2)/TYNONE/ DATA - CINF(XDROP ,1)/MXPARS/, CINF(XDROP ,2)/TINTLT/, - CINF(XEND ,1)/ 0 /, CINF(XEND ,2)/TYNONE/, - CINF(XEOF ,1)/ 1 /, CINF(XEOF ,2)/TINTPW/, - CINF(XESCAP,1)/ 1 /, CINF(XESCAP,2)/TYCHAR/, - CINF(XEVTRC,1)/ 0 /, CINF(XEVTRC,2)/TLOGIC/, - CINF(XEXPNS,1)/MXPARS/, CINF(XEXPNS,2)/TINTGR/, - CINF(XFABS ,1)/ 0 /, CINF(XFABS ,2)/TLOGIC/, - CINF(XFACTO,1)/MXPARS/, CINF(XFACTO,2)/TYREAL/, - CINF(XFORWO,1)/ 0 /, CINF(XFORWO,2)/TLOGIC/ DATA - CINF(XFREE ,1)/ 1 /, CINF(XFREE ,2)/TINTGR/, - CINF(XFREL ,1)/ 0 /, CINF(XFREL ,2)/TLOGIC/, - CINF(XFTRAC,1)/ 0 /, CINF(XFTRAC,2)/TLOGIC/, - CINF(XGABS ,1)/ 0 /, CINF(XGABS ,2)/TLOGIC/, - CINF(XGEOME,1)/ 1 /, CINF(XGEOME,2)/TYCHAR/, - CINF(XGREL ,1)/ 0 /, CINF(XGREL ,2)/TLOGIC/, - CINF(XGTRAC,1)/ 0 /, CINF(XGTRAC,2)/TLOGIC/, - CINF(XIMMED,1)/ 0 /, CINF(XIMMED,2)/TLOGIC/, - CINF(XINPUT,1)/ 1 /, CINF(XINPUT,2)/TINTLT/ DATA - CINF(XLIST ,1)/ 2 /, CINF(XLIST ,2)/TINTGR/, - CINF(XLONGF,1)/ 0 /, CINF(XLONGF,2)/TLOGIC/, - CINF(XMEMOR,1)/ 1 /, CINF(XMEMOR,2)/TINTGR/, - CINF(XMODE ,1)/ 1 /, CINF(XMODE ,2)/TINTPW/, - CINF(XNORM ,1)/ 1 /, CINF(XNORM ,2)/TINTPW/, - CINF(XPGRAD,1)/ 0 /, CINF(XPGRAD,2)/TLOGIC/, - CINF(XPOINT,1)/ 0 /, CINF(XPOINT,2)/TLOGIC/, - CINF(XPRINT,1)/ 1 /, CINF(XPRINT,2)/TINTGR/, - CINF(XQUIT ,1)/ 0 /, CINF(XQUIT ,2)/TYNONE/, - CINF(XRADIX,1)/ 1 /, CINF(XRADIX,2)/TYCHAR/, - CINF(XRENAM,1)/ 2 /, CINF(XRENAM,2)/TINTLT/, - CINF(XREQUI,1)/ 0 /, CINF(XREQUI,2)/TLOGIC/ DATA - CINF(XRESET,1)/ 0 /, CINF(XRESET,2)/TYNONE/, - CINF(XRESUL,1)/ 1 /, CINF(XRESUL,2)/TSTRNG/, - CINF(XREVER,1)/ 0 /, CINF(XREVER,2)/TLOGIC/, - CINF(XSEE ,1)/ 1 /, CINF(XSEE ,2)/TINTPW/, - CINF(XSELCT,1)/ 1 /, CINF(XSELCT,2)/TINTGR/, - CINF(XSEPAR,1)/ 1 /, CINF(XSEPAR,2)/TYCHAR/, - CINF(XSORT ,1)/ 1 /, CINF(XSORT ,2)/TINTPW/, - CINF(XSTART,1)/ 1 /, CINF(XSTART,2)/TINTPW/, - CINF(XSTRIN,1)/ 2 /, CINF(XSTRIN,2)/TYCHAR/, - CINF(XSUBRO,1)/ 2 /, CINF(XSUBRO,2)/TINTLT/, - CINF(XSUMMA,1)/ 0 /, CINF(XSUMMA,2)/TLOGIC/ DATA - CINF(XTERM ,1)/NQUITS/, CINF(XTERM ,2)/TYCHAR/, - CINF(XTEX ,1)/ 0 /, CINF(XTEX ,2)/TLOGIC/, - CINF(XTITLE,1)/ 1 /, CINF(XTITLE,2)/TSTRNG/, - CINF(XTRACE,1)/ NTR /, CINF(XTRACE,2)/TYCHAR/, - CINF(XTRCUN,1)/ 1 /, CINF(XTRCUN,2)/TSTRNG/, - CINF(XTTRAC,1)/ 0 /, CINF(XTTRAC,2)/TLOGIC/, - CINF(XUPPER,1)/ 0 /, CINF(XUPPER,2)/TLOGIC/, - CINF(XUSER ,1)/MXPARS/, CINF(XUSER ,2)/TYREAL/, - CINF(XVALUE,1)/ 1 /, CINF(XVALUE,2)/TINTPW/, - CINF(XVERIF,1)/ 0 /, CINF(XVERIF,2)/TLOGIC/, - CINF(XWATCH,1)/ 0 /, CINF(XWATCH,2)/TLOGIC/, - CINF(XWITH ,1)/MXPARS/, CINF(XWITH ,2)/TINTPW/ C-----PARAMETER KEYWORDS FOR COMMAND DICTIONARY. C KEYWORD INDEX INTEGER VALUE DATA - CPINF(ZABSSU,1)/XNORM /, CPINF(ZABSSU,2)/NL1 /, - CPINF(ZACTIV,1)/XEOF /, CPINF(ZACTIV,2)/CEOFAC/, - CPINF(ZALL ,1)/XVALUE/, CPINF(ZALL ,2)/CALL /, - CPINF(ZANALY,1)/XDERIV/, CPINF(ZANALY,2)/CANAL /, - CPINF(ZASIS ,1)/XSORT /, CPINF(ZASIS ,2)/SASIS /, - CPINF(ZBATCH,1)/XMODE /, CPINF(ZBATCH,2)/CBATCH/, - CPINF(ZCONTR,1)/XVALUE/, CPINF(ZCONTR,2)/CCONTR/, - CPINF(ZDIFFE,1)/XDERIV/, CPINF(ZDIFFE,2)/CDIFF /, - CPINF(ZDIMEN,1)/XSORT /, CPINF(ZDIMEN,2)/SDIMN / DATA - CPINF(ZEUCLI,1)/XNORM /, CPINF(ZEUCLI,2)/NL2 /, - CPINF(ZFIRST,1)/XDERIV/, CPINF(ZFIRST,2)/CFIRST/, - CPINF(ZFNAME,1)/XSORT /, CPINF(ZFNAME,2)/SFNNAM/, - CPINF(ZFNO ,1)/XSORT /, CPINF(ZFNO ,2)/SFNNUM/, - CPINF(ZFNUMB,1)/XSORT /, CPINF(ZFNUMB,2)/SFNNUM/, - CPINF(ZFROBE,1)/XNORM /, CPINF(ZFROBE,2)/NL2 /, - CPINF(ZFULL ,1)/XSEE /, CPINF(ZFULL ,2)/CFULL /, - CPINF(ZGO ,1)/XSTART/, CPINF(ZGO ,2)/CGOGO /, - CPINF(ZIGNOR,1)/XEOF /, CPINF(ZIGNOR,2)/CEOFIG/ DATA - CPINF(ZINFIN,1)/XNORM /, CPINF(ZINFIN,2)/NLINF /, - CPINF(ZINPUT,1)/XVALUE/, CPINF(ZINPUT,2)/CINPUT/, - CPINF(ZINTER,1)/XMODE /, CPINF(ZINTER,2)/CINTAC/, - CPINF(ZLOOPS,1)/XVALUE/, CPINF(ZLOOPS,2)/CLOOPS/, - CPINF(ZL1 ,1)/XNORM /, CPINF(ZL1 ,2)/NL1 /, - CPINF(ZL2 ,1)/XNORM /, CPINF(ZL2, 2)/NL2 /, - CPINF(ZMAXIM,1)/XNORM /, CPINF(ZMAXIM,2)/NLINF /, - CPINF(ZMEDIM,1)/XSEE /, CPINF(ZMEDIM,2)/CMED /, - CPINF(ZMINIM,1)/XSEE /, CPINF(ZMINIM,2)/CMIN /, - CPINF(ZMISSI,1)/XCC /, CPINF(ZMISSI,2)/CCMISS/ DATA - CPINF(ZNAMES,1)/XCHECK/, CPINF(ZNAMES,2)/CHNAM /, - CPINF(ZNO ,1)/XSTART/, CPINF(ZNO ,2)/CNOGO /, - CPINF(ZNONE ,1)/XSEE /, CPINF(ZNONE ,2)/CNONE /, - CPINF(ZNULL ,1)/XEOF /, CPINF(ZNULL ,2)/CEOFIG/, - CPINF(ZNUMBE,1)/XCHECK/, CPINF(ZNUMBE,2)/CHNUM /, - CPINF(ZOFF ,1)/XCHECK/, CPINF(ZOFF ,2)/CHOFF /, - CPINF(ZOK ,1)/XSTART/, CPINF(ZOK ,2)/CGOGO /, - CPINF(ZON ,1)/XCHECK/, CPINF(ZON ,2)/CHON /, - CPINF(ZPNAME,1)/XSORT /, CPINF(ZPNAME,2)/SPRNAM/, - CPINF(ZPNO ,1)/XSORT /, CPINF(ZPNO ,2)/SPRNUM/, - CPINF(ZPNUMB,1)/XSORT /, CPINF(ZPNUMB,2)/SPRNUM/ DATA - CPINF(ZPRESE,1)/XCC /, CPINF(ZPRESE,2)/CCPRSN/, - CPINF(ZPROLG,1)/XSORT /, CPINF(ZPROLG,2)/SRECNO/, - CPINF(ZRECNO,1)/XSORT /, CPINF(ZRECNO,2)/SRECNO/, - CPINF(ZRUN ,1)/XSTART/, CPINF(ZRUN ,2)/CGOGO /, - CPINF(ZSUPRE,1)/XNORM /, CPINF(ZSUPRE,2)/NLINF /, - CPINF(ZTESTM,1)/XDERIV/, CPINF(ZTESTM,2)/CTEST /, - CPINF(ZYES ,1)/XSTART/, CPINF(ZYES ,2)/CGOGO / C-----CREATION OF CONTROL PART OF THE DEFINITION DICTIONARY. C # OF PARAMETERS TYPE OF PARAMETER DATA - DINF(QADD ,1)/MXPARS/, DINF(QADD ,2)/TINTLT/, - DINF(QARG ,1)/MXPARS/, DINF(QARG ,2)/TYREAL/, - DINF(QDEFN ,1)/ 0 /, DINF(QDEFN ,2)/TYNONE/, - DINF(QDESCR,1)/ 1 /, DINF(QDESCR,2)/TSTRNG/, - DINF(QDIMEN,1)/MXPARS/, DINF(QDIMEN,2)/TINTGR/, - DINF(QDROP ,1)/MXPARS/, DINF(QDROP ,2)/TINTLT/, - DINF(QEND ,1)/ 0 /, DINF(QEND ,2)/TYNONE/, - DINF(QEXPNS,1)/MXPARS/, DINF(QEXPNS,2)/TINTGR/, - DINF(QFUNCT,1)/ 2 /, DINF(QFUNCT,2)/TINTLT/, - DINF(QGROUP,1)/ 2 /, DINF(QGROUP,2)/TINTLT/ DATA - DINF(QLIMIT,1)/ 1 /, DINF(QLIMIT,2)/TINTGR/, - DINF(QMAX ,1)/ 1 /, DINF(QMAX ,2)/TINTGR/, - DINF(QN ,1)/MXPARS/, DINF(QN ,2)/TINTGR/, - DINF(QPERMA,1)/ 0 /, DINF(QPERMA,2)/TYNONE/, - DINF(QPROBL,1)/ 2 /, DINF(QPROBL,2)/TINTLT/, - DINF(QSCALE,1)/ 1 /, DINF(QSCALE,2)/TINTGR/, - DINF(QSELCT,1)/ 1 /, DINF(QSELCT,2)/TINTGR/, - DINF(QSOLN ,1)/MXPARS/, DINF(QSOLN ,2)/TYREAL/, - DINF(QSTART,1)/MXPARS/, DINF(QSTART,2)/TYREAL/, - DINF(QTEMP ,1)/ 0 /, DINF(QTEMP ,2)/TYNONE/, - DINF(QUSE ,1)/ 1 /, DINF(QUSE ,2)/TINTLT/, - DINF(QX ,1)/MXPARS/, DINF(QX ,2)/TYREAL/ DATA - DPINF(1,1)/ 0 /, DPINF( 1,2)/ 9/ C-----DECLARE HEADINGS FOR PROMPTS. DATA PROMPT(1) / ' (1) TITLE LINE? (OR "END")' / DATA PROMPT(2) / ' (2) CONTROL INFORMATION?' / DATA PROMPT(3) / ' (3) USER PARAMETERS?' / DATA PROMPT(4) / ' (4) WHICH PROBLEMS?' / DATA PROMPT(5) / ' (5) READY?' / DATA PROMPT(6) / ' ERROR CORRECTION IS :' / DATA PROMPT(7) / ' ENTER MORE:' / DATA PROMPT(8) / ' COMMANDS, THEN "RUN":' / DATA PROMPT(9) / ' COMMANDS, IMMEDIATE RUN:' / C-----STRINGS FOR OUTPUT. DATA CNORM(NL1) /'ABS SUM '/, CTYPE(PGRAD)/'GRADIENT '/ DATA CNORM(NL2) /'EUCLIDEAN '/, CTYPE(PSTEP)/'STEPSIZE '/ DATA CNORM(NLINF)/'MAXIMUM '/, CTYPE(PSHXG)/'SHANNOXG '/ DATA CTYPE(PFUNC)/'FUNCTION '/ DATA CDERV(CANAL)/'ANALYTIC '/, VSORT(SPRNAM)/'PROB NAME '/ DATA CDERV(CDIFF)/'DIFFERENCE'/, VSORT(SPRNUM)/'PROB NUMB '/ DATA CDERV(CTEST)/'TESTMODE '/, VSORT(SASIS )/'AS IS '/ DATA CDERV(CFIRST)/'FIRSTSTEP'/, VSORT(SRECNO)/'RECORD NO.'/ DATA VSORT(SFNNAM)/'FUNC NAME '/ DATA VSORT(SFNNUM)/'FUNC NUMB '/ DATA VSORT(SDIMN )/'DIMENSION '/ DATA VCC (CCPRSN)/'PRESENT '/ VCC (CCMISS)/'MISSING '/ DATA VCHEC(CHOFF)/'OFF '/, VSEE (CNONE )/'NONE '/ DATA VCHEC(CHON )/'ON '/, VSEE (CMIN )/'MINIMAL '/ DATA VCHEC(CHNAM)/'NAMES '/, VSEE (CMED )/'MEDIUM '/ DATA VCHEC(CHNUM)/'NUMBERS '/, VSEE (CFULL )/'FULL '/ C## E X E C U T I O N C## E X E C U T I O N C----- FUNCTION STATEMENT. RD(I) = REAL(I) C!!!! RD(I) = DBLE(I) C----- TIME THE WHOLE RUN. CALL ZZSECS (TIMEIT) TODO(CCOLD) = F TODO(CDOFLE) = F TODO(CDOTRM) = F C----- DEFINE 'PARAMETER' ARRAYS I.E. ARRAYS OF CONSTANTS. DO 110 I = 1, NU PTUSER(I) = NOUTER + I 110 CONTINUE DO 120 I = 1, FNO PTFARG(I) = NINNER + I 120 CONTINUE C-- POINTERS FOR SORTING DO 130 I = 1, NCMDS INVMP1(I) = I 130 CONTINUE CALL ZZDSRT(CMDS,CINF,NCMDS,KEYLEN,MAP1,INVMP1,1,T,S1,S2) DO 140 I = 1, NDEFS INVMP2(I) = I 140 CONTINUE CALL ZZDSRT(DEFNS,DINF,NDEFS,KEYLEN,MAP2,INVMP2,1,T,S1,S2) DO 150 I = 1, NCPARS INVMP3(I) = I 150 CONTINUE CALL ZZDSRT(CPARS,CPINF,NCPARS,KEYLEN,MAP3,INVMP3,1,T,S1,S2) C----- DEFINE REMOTE BLOCKS. ASSIGN 81000 TO REMOT1 ASSIGN 82000 TO REMOT2 ASSIGN 84000 TO REMOT4 ASSIGN 85000 TO REMOT5 ASSIGN 87000 TO REMOT7 ASSIGN 2900 TO RETRN4 ASSIGN 2900 TO RETRN7 C--- SET DEFAULTS FOR BASIC VALUES. ASSIGN 600 TO RETRN1 GOTO REMOT1 600 CONTINUE C INITIALIZE OUTER LOOPS AND USER PARAMETERS ASSIGN 700 TO RETRN2 GOTO REMOT2 700 CONTINUE C----- EXISTENCE OF A BATCH FILE? CALL ZZOPEN ( PREPRC, T, NMBATC, *160, RECL ) C SUCCESS: SET MODE TO BATCH AND PROCEED C WITH INPUT TO BE FROM THE BATCH FILE. CALL ZZCLSE ( PREPRC, *91000 ) INTACT = F BRIEF = T IMMED = T RPSOUT = COPYUN NMTRMO = NMCOPY NEXTUN = PREPRC NMNEXT = NMBATC GOTO 180 C FAILED: ASSUME INTERACTIVE SESSION. 160 CONTINUE INTACT = T BRIEF = F IMMED = F RPSOUT = TRMOUT NMTRMO = DNTRMO NEXTUN = STDIN NMNEXT = NMTRMI 180 CONTINUE CALL ZZOPEN ( RPSOUT, T, NMTRMO, *91000, RECL ) CALL ZZETRM ( INTACT, RPSOUT ) C----- INITIALIZE SUBROUTINES. C ZZADDP CALL ZZASET ( DCC(RADIX: RADIX ), DCC(RADPRB:RADPRB), - DCC(RADFUN:RADFUN), DCC(RADGRP:RADGRP)) C ZZDCOD CALL ZZDSET (DCC) C START BY READING PROLOG FILE. TITREQ = T NMCURR = NMPRLG READUN = PREPRC CALL ZZOPEN ( PREPRC, T, NMPRLG, *900, RECL ) NOPRLG = F GOTO 950 900 CALL ZZERRM ( TM, *91000,'NT WARNING: THERE IS NO PROLOG FILE.') NOPRLG = T 950 TRMRD = F C >==================================>>COMMAND INPUT SECTION 1000 CONTINUE PHASE = 0 TITLE = BLANK LASTLN = NULLIN LNO = RGL IF ( NOPRLG ) THEN FAKEIT = T ELSE FAKEIT = F ENDIF C OBTAIN ANOTHER LINE OF INPUT FROM READUN 2000 IF ( DCDMOD .NE. DCDBAD ) THEN C GET NEW LINE IF ( FAKEIT ) THEN C A KLUDGE TO AVOID JUMP INTO LOOP WHEN C THERE IS NO INITIAL PROLOG FILE. FAKEIT = F GOTO 2060 ENDIF RDERCT = 0 IF ( DCDMOD .EQ. DCDCON ) THEN SVPHAS = PHASE PHASE = 7 ELSE IF (DCDMOD .EQ. DCDERR ) THEN ERRCNT = ERRCNT + 1 IF ( ERRCNT .LT. MAXERR ) THEN CALL ZZERRM ( TM, *91000, - 'NS STRING IN ERROR IS :'//LL(ERL)) CALL ZZOPEN ( STDIN, T, NMTRMI, *91000, RECL ) SAVUNT = READUN READUN = STDIN SVPHAS = PHASE PHASE = 6 LL(ERL) = LL(LNO) II = MIN( INLINE, INLINE-(ZZLENG(LL(ERL))-LINELN)) KK = LINELN ELSE WRITE (RPSOUT,'(A)')' STRING IN ERROR WILL BE IGNORED' IF ( COPY ) THEN WRITE (COPYUN,'(A)')' STRING IN ERROR WILL BE IGNORED' ENDIF IF ( LINELN .LT. INLINE ) THEN CALL ZZSHFT ( LL(LNO), LINELN+1, 1, INLINE ) LINELN = ZZLENG( LL(LNO) ) ELSE LL(LNO) = BLANK LINELN = 0 ENDIF GOTO 2100 ENDIF ENDIF 2020 IF ( TRMRD ) THEN IF ( DCDMOD .EQ. DCDCON .OR. - DCDMOD .EQ. DCDERR ) THEN WRITE ( RPSOUT, '(A)' ) PROMPT(PHASE) IF ( COPY ) WRITE ( COPYUN, '(1X,A)' ) PROMPT(PHASE) ELSE IF ( BRIEF ) THEN IF ( IMMED ) THEN WRITE ( RPSOUT, '(A)' ) PROMPT(9) IF ( COPY ) WRITE ( COPYUN, '(1X,A)' ) PROMPT(9) ELSE WRITE ( RPSOUT, '(A)' ) PROMPT(8) IF ( COPY ) WRITE ( COPYUN, '(1X,A)' ) PROMPT(8) ENDIF PHASE = 5 ELSE IF ( TITREQ .AND. TITLE .EQ. BLANK ) THEN PHASE = 1 ELSE IF ( PHASE .EQ. 5 ) THEN IF ( CHECK ) THEN C PRINT THE CURRENT LIST IF ( TRMRD .AND. NPROBS .NE. 0 ) THEN C SORT IF NECESSARY. IF ( SORTFL .AND. SORT .NE. SASIS ) THEN SORTFL = F CALL ZZSORT (SORT,LIST,NPROBS,PRECNO, - NAMES,PNAMLN,ASC) ENDIF WRITE ( RPSOUT, * ) IF ( COPY ) WRITE ( COPYUN, * ) IF ( LISTCD .EQ. CHNUM ) THEN WRITE(RPSOUT,'(1X,I3,A,16I4/,(14X,16I4))') - NPROBS,' PROBLEMS:',(LIST(I),I=1,NPROBS) IF ( COPY ) THEN WRITE(COPYUN,'(1X,I3,A,16I4/,(14X,16I4))') - NPROBS,' PROBLEMS:',(LIST(I),I=1,NPROBS) ENDIF ELSE IF ( LISTCD .EQ. CHNAM ) THEN J = PNAMLN + FNAMLN WRITE(RPSOUT,'(1X,I3,A,2X,7A9/(16X,7A9))') - NPROBS,' PROBLEMS:',(NAMES((LIST(I)-1)*J+1 - : LIST(I)*J-FNAMLN), I=1,NPROBS) IF ( COPY ) THEN WRITE(COPYUN,'(1X,I3,A,2X,7A9/(16X,7A9))') - NPROBS,' PROBLEMS:',(NAMES((LIST(I)-1)*J+1 - : LIST(I)*J-FNAMLN), I=1,NPROBS) ENDIF ENDIF ENDIF ENDIF ENDIF WRITE ( RPSOUT, '(A)' ) PROMPT(PHASE) IF (COPY) WRITE ( COPYUN, '(A)' ) PROMPT(PHASE) ENDIF ENDIF 2025 IF ( DCDMOD .EQ. DCDCON .OR. DCDMOD .EQ. DCDERR ) THEN PHASE = SVPHAS ENDIF READ ( READUN, '(A)' , END=2060, ERR=2030 ) LL(LNO) IF ( UPCASE ) THEN CALL ZZCASE ( LL(LNO), CTOUPP ) ENDIF LINELN = ZZLENG (LL(LNO)) IF (COPY .AND. TRMRD) WRITE (COPYUN,'(A)') LL(LNO)(1:LINELN) EOPH = F IF ( DCDMOD .EQ. DCDERR ) THEN READUN = SAVUNT JJ = MIN ( II, LINELN ) IF ( JJ .NE. LINELN ) THEN CALL ZZERRM ( RD(II), *91000, 'NS DROPPED CHARACTERS : ' - //LL(LNO)(II+1:LINELN) ) ENDIF IF ( II .NE. INLINE ) THEN LL(LNO)(JJ+1:INLINE) = LL(ERL)(KK+1:INLINE) LINELN = JJ + (INLINE - II) ENDIF ENDIF IF ( DCDMOD .NE. DCDCON .AND. DCDMOD .NE. DCDERR ) THEN DCDMOD = DCDNEW ENDIF GOTO 2100 C---- HANDLE READ ERRORS 2030 CALL ZZERRM ( RD(READUN), *91000, 'IS READ ERROR ON UNIT ') RDERCT = RDERCT + 1 IF (RDERCT .LE. RDERMX ) THEN GOTO 2020 ELSE GOTO 91000 ENDIF C---- END OF FILE 2060 CONTINUE IF ( TRMRD ) THEN IF ( EOFBLK ) THEN CALL ZZCLSE ( STDIN , *91000 ) CALL ZZOPEN ( STDIN , T, NMTRMI, *91000, RECL ) LINELN = 0 ELSE WRITE ( RPSOUT, '(A)' )' TERMINATING ON EOF ' IF ( COPY ) WRITE(COPYUN,'(A)')' TERMINATING ON EOF ' GOTO 90000 ENDIF ELSE IF ( DCDMOD .EQ. DCDCON ) THEN CALL ZZERRM(RD(READUN),*90000,'IT END OF FILE, UNIT ') CALL ZZERRM(RD(READUN), *91000, - 'IS MISSING CONTINUATION LINE ON UNIT ' ) ENDIF IF ( NMCURR .EQ. NMPRLG ) THEN WRITFL = PRINTL .NE. 0 CHECK = LISTCD .NE. CHOFF C INITIALIZE SUBR'S. C ZZEVAL CALL ZZESET ( TRF, TRG, TRG, TRCOUT ) C ZZTERM CALL ZZTSET ( NORM, QUITS, TTRACE, TRCOUT ) C ZZPUTP, ZZGETP, ZZPUTG, ZZGETG C RECORD LENGTH OF DAUF FILE RECLEN = ZZRECL ( CPERLN, IPERLN, LPERLN, RPERLN) CALL ZZPDEF ( CPERLN, IPERLN, RPERLN, PTNDIM ) CALL ZZDEFP ( IPERLN ) CALL ZZGDEF ( CPERLN, IPERLN, RPERLN ) CALL ZZDEFG ( IPERLN ) DO 2061 I = 1,MXGRPS GROUPS(I) = -1 2061 CONTINUE C CHECK FOR EXISTENCE OF DAUF. CALL ZZOPEN ( DAUF, T, NMDAUF, *2063, RECLEN ) GOTDAF = T GOTO 2064 2063 CONTINUE GOTDAF = F 2064 CONTINUE IF (GOTDAF) THEN C RESTORE DATA AND PROCEED. RECNO = 1 CALL ZZRDIN ( DAUF, IW, 2, IPERLN, RECNO ) RECNO = IW(1) RECP = IW(2) FREEPT = RECP CALL ZZRDIN ( DAUF, PRECNO,3*DFPRBS,IPERLN,RECNO) CALL ZZRDCH ( DAUF, NAMES,(PNAMLN+FNAMLN)*DFPRBS, - CPERLN, RECNO ) PRMISS = T DO 2067 I = 1, DFPRBS IF ( PRECNO(1,I) .NE. -1 ) PRMISS = F 2067 CONTINUE NMCURR = NMGRPS CALL ZZCLSE( PREPRC, *2068) GOTO 2070 2068 CALL ZZERRM(RD(PREPRC),*91000,'NS SOMETHING IS WRONG:' - //' CAN NOT CLOSE '//NMPRLG) 2070 IF ( .NOT. PRMISS ) THEN CALL ZZOPEN ( PREPRC, T, NMGRPS, *2080, RECL ) GOTO 2083 2080 CALL ZZERRM(RD(PREPRC),*90000, - 'NT NO GROUPS DEFINED') ELSE CALL ZZERRM(RD(I),*2082,'NT NO PROBLEMS DEFINED' - //' SO IGNORING GROUPS FILE.') 2082 CONTINUE ENDIF NPROBS = 0 READUN = NEXTUN TRMRD = READUN .EQ. STDIN C OPEN THE NEXT INPUT UNIT. CALL ZZOPEN ( READUN, T, NMNEXT, *91000, RECL ) 2083 CONTINUE ELSE C DETERMINE THE RECORD NUMBER FOR THE FIRST PROBLEM C PROBLEMS START IN RECORD 2. THE OTHER DATA FOLLOWS. C RECORD 1 CONTAINS NUMBER WHERE OTHER DATA STARTS. RECP = 2 C INITIALIZE THE PRECNO ARRAY. DO 2084 I=1,DFPRBS PRECNO(RECN,I) = -1 2084 CONTINUE NMCURR = NMPROB CALL ZZCLSE( PREPRC, *2085 ) GOTO 2086 2085 CALL ZZERRM(RD(PREPRC),*91000,'NS SOMETHING IS WRONG:' - //' CAN NOT CLOSE '//NMPRLG) 2086 CALL ZZOPEN ( PREPRC, T, NMPROB, *2087, RECL ) IF (INTACT) THEN WRITE(RPSOUT,'(A)') ' ************************' WRITE(RPSOUT,'(A)') ' * READING PROBLEM DATA *' WRITE(RPSOUT,'(A)') ' ************************' ENDIF GOTO 2089 2087 CALL ZZERRM(RD(PREPRC),*90000,'NT WARNING: NO ' - //'PROBLEMS ARE DEFINED IN FILE '//NMPROB) PRMISS = T GOTO 2060 2089 CONTINUE ENDIF ELSE IF ( NMCURR .EQ. NMPROB ) THEN RECNO = 1 IW(1) = RECP IW(2) = 0 CALL ZZWRIN ( DAUF, IW, 2, IPERLN, RECNO ) RECNO = RECP CALL ZZWRIN ( DAUF, PRECNO,3*DFPRBS,IPERLN,RECNO) CALL ZZWRCH ( DAUF, NAMES, (PNAMLN+FNAMLN)*DFPRBS, - CPERLN,RECNO) RECP = RECNO FREEPT = RECP NMCURR = NMGRPS CALL ZZCLSE( PREPRC, *2090 ) GOTO 2091 2090 CALL ZZERRM(RD(PREPRC),*91000,'NS SOMETHING IS WRONG:' - //' CAN NOT CLOSE '//NMPROB) 2091 IF ( .NOT. PRMISS ) THEN CALL ZZOPEN ( PREPRC, T, NMGRPS, *2092, RECL ) GOTO 2093 2092 CALL ZZERRM(RD(PREPRC),*90000,'NT NO GROUPS') ELSE CALL ZZERRM(RD(I),*2093,'NT NO PROBLEMS DEFINED' - //' SO IGNORING GROUPS FILE.') ENDIF 2093 CONTINUE NPROBS = 0 READUN = NEXTUN TRMRD = READUN .EQ. STDIN C OPEN THE NEXT INPUT UNIT. CALL ZZOPEN ( READUN, T, NMNEXT, *91000, RECL ) ELSE IF ( NMCURR .EQ. NMGRPS ) THEN NPROBS = 0 NMCURR = NMNEXT READUN = NEXTUN TRMRD = READUN .EQ. STDIN C OPEN THE NEXT INPUT UNIT. CALL ZZCLSE( PREPRC, *2094 ) GOTO 2095 2094 CALL ZZERRM(RD(PREPRC),*91000,'NS SOMETHING IS WRONG:' - //' CAN NOT CLOSE '//NMGRPS) 2095 CALL ZZOPEN ( READUN, T, NMNEXT, *91000, RECL ) ELSE CALL ZZERRM(RD(READUN),*90000,'IT END OF FILE, UNIT ') CALL ZZCLSE( PREPRC, *2096 ) GOTO 2097 2096 CALL ZZERRM(RD(PREPRC),*91000,'NS SOMETHING IS WRONG:' - //' CAN NOT CLOSE '//NMCURR) 2097 READUN = NEXTUN NMCURR = NMNEXT TRMRD = READUN .EQ. STDIN CALL ZZOPEN ( READUN, T, NMNEXT, *91000, RECL ) ENDIF CONTINUE ENDIF LL(LNO) = BLANK LINELN = 0 GOTO 2000 ENDIF C---- NOW DECODE TO GET NEXT PARAMETER. 2100 IF ( DCDMOD .NE. DCDCON ) THEN C SET DEFAULT KEYWORDS PARCT = MXPARS IF ( DEFNMD .EQ. CMODE ) THEN IF ( PHASE .EQ. 1 ) THEN KEYNO = MAP1( XTITLE ) ELSE IF ( PHASE .EQ. 2 ) THEN KEYNO = MAP1( XACCUR ) ELSE IF ( PHASE .EQ. 3 ) THEN KEYNO = MAP1( XXLAST+1 ) ELSE IF ( PHASE .EQ. 4 ) THEN KEYNO = MAP1( XADD ) ELSE IF ( PHASE .EQ. 5 ) THEN KEYNO = MAP1( XSTART ) ENDIF ELSE KEYNO = MAP2(QUSE) ENDIF ENDIF IF ( DEFNMD .EQ. CMODE ) THEN CALL ZZDCOD ( DCDMOD, LL, LINELN, LNO, EOPH, VERIFY, RPSOUT, - KEYNO, CMDS, CINF, NCMDS, CPARS, CPINF, NCPARS, - KEYSTR, PARS, PARCT, LASTDL, INTACT, DCTRAC, TRCOUT, - MAP1, UPCASE, *90000 ) ELSE CALL ZZDCOD ( DCDMOD, LL, LINELN, LNO, EOPH, VERIFY, RPSOUT, - KEYNO, DEFNS, DINF, NDEFS, DPARS, DPINF, NDPARS, - KEYSTR, PARS, PARCT, LASTDL, INTACT, DCTRAC, TRCOUT, - MAP2, UPCASE, *90000 ) ENDIF IF ( DCTRAC ) THEN IF ( KEYNO .GT. 0 ) THEN I=(KEYNO-1)*KEYLEN ELSE I = 1 ENDIF IF ( DEFNMD .EQ. CMODE) THEN WRITE(RPSOUT,*)'RETURN FROM DCOD:'// - ' KEYNO=',KEYNO,'<',CMDS(I+1:I+KEYLEN),'>' ELSE WRITE(RPSOUT,*)'RETURN FROM DCOD:'// - ' KEYNO=',KEYNO,'<',DEFNS(I+1:I+KEYLEN),'>' ENDIF WRITE(RPSOUT,*)'PARCT=',PARCT,' PARS=<',(PARS(I),I=1,PARCT),'>' WRITE(RPSOUT,*)' KEYSTR=',('<',KEYSTR(I),'>',I=1,PARCT) ENDIF C DETERMINE RESPONSE FROM DECODE. IF ( DCDMOD .EQ. DCDERR ) THEN C REQUEST ERROR CORRECTION. GOTO 2000 ELSE ERRCNT = 0 ENDIF IF ( DCDMOD .EQ. DCDCON ) THEN C GET LINE CONTINUATION. GOTO 2000 ELSEIF ( KEYNO .EQ. 0 ) THEN C BLANK LINE ENCOUNTERED - IGNORE. GOTO 2900 ENDIF C ALL IS OK, SO CONTINUE WITH PROCESSING. C --EXTRACT FIRST PARAMETER. IF ( DEFNMD .EQ. CMODE ) THEN IPTYPE = CINF( KEYNO,2 ) KEYNO = INVMP1( KEYNO ) ELSE IPTYPE = DINF( KEYNO,2 ) KEYNO = INVMP2( KEYNO ) ENDIF IF ( PARCT .GT. 0 ) THEN PAR1 = PARS (1) S1 = KEYSTR(1) ELSE S1 = BLANK IF ( IPTYPE .EQ. TYREAL .OR. IPTYPE .EQ. TINTGR .OR. - IPTYPE .EQ. TINTPW .OR. IPTYPE .EQ. TINTLT ) THEN PAR1 = DFLT ELSEIF ( IPTYPE.EQ.TYCHAR ) THEN IF ( KEYNO .NE. XCOMME ) THEN CALL ZZERRM ( RD(I), *91000, - 'NS MISSING PARAMETER ON DECODE RETURN' ) DCDMOD = DCDERR GOTO 2000 ENDIF ENDIF ENDIF IF ( DEFNMD .NE. CMODE ) THEN C PROCESS THE PROBLEM OR GROUP INFORMATION IF ( KEYNO .EQ. QADD .OR. KEYNO .EQ. QDROP ) THEN C ADD OR DROP PROBLEM. IF ( PARCT .GT. 0 ) THEN CALL ZZADDP ( KEYNO .EQ. QADD, KEYSTR, PARS, PARCT, - GMEMBS, GRPSZ, MXGSZ, PRECNO, NAMES, DFPRBS, - GROUPS, GNAMES, MXGRPS, G1, *91000 ) ELSE CALL ZZERRM ( TM, *91000, - 'NT ADD OR DROP WITH NO PROBLEMS GIVEN' ) ENDIF ELSE IF ( KEYNO .EQ. QARG ) THEN C SET FUNCTION PARAMETER OUTER = F OSCAL = 0 IF ( ARGNO .NE. 0 ) THEN SEPART = F OINDEX = PTFARG(ARGNO) ELSE SEPART = T OINDEX = PTFARG(1) ENDIF ASSIGN 2900 TO RETRN5 GOTO REMOT5 ELSE IF ( KEYNO .EQ. QDEFN ) THEN C SAVE THE OLD PROBLEM OR GROUP, DEFINE A NEW ONE IF ( DEFNMD .EQ. PMODE ) THEN C STORE THE PROBLEM CALL ZZPUTP( DAUF, PPNUM, PFNUM, PPNAM, PFNAM, PDESC, - SOLNS, PINTS, IORDER, ILOOPX, ILOOPC, - X, NAMES, PRECNO, RECP, ERRFLG, *91000 ) ELSE C STORE THE GROUP CALL ZZPUTG( DAUF, PGNUM, PGNAM, GRPSZ, GMEMBS, GNAMES, - GROUPS, RECP, ERRFLG, *91000 ) ENDIF DEFNMD = PMODE C SET PROBLEM DEFAULT VALUES GOTO REMOT4 ELSE IF ( KEYNO .EQ. QDESCR ) THEN C SET PROBLEM DESCRIPTON PDESC = LL(SVL) LDESC = ZZLENG( PDESC ) ELSE IF ( KEYNO .EQ. QDIMEN .OR. KEYNO .EQ. QN ) THEN C SET THE DIMENSION(S) IF ( PARCT .EQ. 0 ) THEN PAR1 = DNDIM ENDIF OUTER = F OSCAL = 2 OINDEX = PTNDIM ASSIGN 2900 TO RETRN5 GOTO REMOT5 ELSE IF ( KEYNO .EQ. QEND ) THEN C SAVE THE PROBLEM OR GROUP IF ( DEFNMD .EQ. PMODE ) THEN C STORE THE PROBLEM CALL ZZPUTP( DAUF, PPNUM, PFNUM, PPNAM, PFNAM, PDESC, - SOLNS, PINTS, IORDER, ILOOPX, ILOOPC, - X, NAMES, PRECNO, RECP, ERRFLG, *91000 ) ELSE C STORE THE GROUP CALL ZZPUTG( DAUF, PGNUM, PGNAM, GRPSZ, GMEMBS, GNAMES, - GROUPS, RECP, ERRFLG, *91000 ) ENDIF DEFNMD = CMODE ELSE IF ( KEYNO .EQ. QEXPNS ) THEN C SET EXPENSE FACTOR IF ( PARCT .EQ. 0 ) THEN PAR1 = DPXPNS ENDIF OUTER = F OSCAL = 0 OINDEX = PTPXPN ASSIGN 2900 TO RETRN5 GOTO REMOT5 ELSE IF ( KEYNO .EQ. QFUNCT ) THEN C SET FUNCTION NAME IF ( S1 .NE. BLANK ) THEN PFNAM = S1 CALL ZZCASE(PFNAM,CTOUPP) ELSE PFNUM = NINT(PAR1) ENDIF ELSE IF ( KEYNO .EQ. QGROUP ) THEN C DEFINE A GROUP DEFNMD = GMODE GRPSZ = 0 IF ( PARCT .EQ. 2 ) THEN IF ( S1 .NE. BLANK ) THEN PGNAM = S1 PGNUM = NINT(PARS(2)) ELSE PGNAM = KEYSTR(2) PGNUM = NINT(PAR1) ENDIF ELSE IF ( PARCT .EQ. 1 ) THEN IF ( S1 .NE. BLANK ) THEN PGNAM = S1 ELSE PGNUM = NINT(PAR1) ENDIF ENDIF ELSE IF ( KEYNO .EQ. QMAX .OR. KEYNO .EQ. QLIMIT ) THEN C SET THE MAXIMUM NUMBER OF ITERATIONS. IF ( PARCT .EQ. 0 ) THEN PMAX = DMAXF ELSE PMAX = NINT( PAR1 ) ENDIF ELSE IF ( KEYNO .EQ. QPERMA ) THEN C SET PERM FLAG PPERM = T ELSE IF ( KEYNO .EQ. QPROBL ) THEN C SET PROBLEM NAME AND NUMBER IF ( PARCT .EQ. 2 ) THEN IF ( S1 .NE. BLANK ) THEN PPNAM = S1 PPNUM = NINT(PARS(2)) ELSE PPNAM = KEYSTR(2) PPNUM = NINT(PAR1) ENDIF CALL ZZCASE(PPNAM,CTOUPP) ELSE IF ( PARCT .EQ. 1 ) THEN IF ( S1 .NE. BLANK ) THEN PPNAM = S1 ELSE PPNUM = NINT(PAR1) ENDIF ENDIF ELSE IF ( KEYNO .EQ. QSCALE ) THEN C SET SCALE CODE IF ( PARCT .EQ. 0 ) THEN PAR1 = DSCAL ENDIF OUTER = F OSCAL = 2 OINDEX = PTSCAL ASSIGN 2900 TO RETRN5 GOTO REMOT5 ELSE IF ( KEYNO .EQ. QSELCT ) THEN C SET SCALE CODE ARGNO = NINT(PAR1) ELSE IF ( KEYNO .EQ. QSOLN ) THEN C STORE THE SOLUTIONS. PTSOLN = PTSOLN + 1 IF ( PTSOLN + PARCT .GT. MXSOLN ) THEN CALL ZZERRM(RD(I),*91000,'NT NO MORE ROOM FOR SOLUTIONS') ELSE SOLNS(1) = SOLNS(1) + 1 SOLNS(PTSOLN) = PARCT - 2 DO 2330 I = 1, PARCT SOLNS(PTSOLN+I) = PARS(I) 2330 CONTINUE PTSOLN = PTSOLN + PARCT ENDIF ELSE IF ( KEYNO .EQ. QSTART .OR. KEYNO .EQ. QX ) THEN C SET THE STARTING POINT IF ( PARCT .EQ. 1 ) THEN IX0 = -NINT( ABS(PAR1) ) ELSE IX0 = PARCT DO 2340 I=1,PARCT X(I) = PARS(I) 2340 CONTINUE ENDIF ELSE IF ( KEYNO .EQ. QTEMP ) THEN C CANCEL PERM FLAG PPERM = F ELSE IF ( KEYNO .EQ. QUSE ) THEN C DEFINE PROBLEM TO MODIFY IF ( PARCT .EQ. 2 ) THEN IF ( S1 .NE. BLANK ) THEN TPPNAM = S1 TPPNUM = NINT(PARS(2)) ELSE TPPNAM = KEYSTR(2) TPPNUM = NINT(PAR1) ENDIF ELSE IF ( PARCT .EQ. 1 ) THEN IF ( S1 .NE. BLANK ) THEN TPPNAM = S1 TPPNUM = -1 ELSE TPPNAM = BLANK TPPNUM = NINT(PAR1) ENDIF ENDIF CALL ZZGETP( DAUF, TPPNUM, PFNUM, TPPNAM, PFNAM, PDESC, - SOLNS, PINTS, IORDER, ILOOPX, ILOOPC, - X , NAMES, PRECNO, ERRFLG, *91000 ) ENDIF ELSE C PROCESS THE COMMAND IF ( KEYNO .EQ. XABORT ) THEN C ABORT. IF ( INTACT ) THEN WRITE ( RPSOUT, '(A)' ) 'FOR SURE(Y)?' IF ( COPY ) WRITE ( COPYUN, '(A)' ) 'FOR SURE(Y)?' READ ( STDIN , '(A)' ) S1 IF (COPY) WRITE (COPYUN,*) S1 CALL ZZCASE (S1, CTOUPP) IF ( S1(1:1) .EQ. 'Y' ) THEN GOTO 94000 ELSE WRITE (RPSOUT, '(A)' ) ' ABORT IGNORED.' IF (COPY) WRITE (COPYUN, '(A)' ) ' ABORT IGNORED.' ENDIF ELSE GOTO 94000 ENDIF ELSE IF ( KEYNO .EQ. XACCUR ) THEN C RESET ACCURACY. TODO(CCOLD) = T SEPART = F OUTER = T OSCAL = 0 OINDEX = PTACC ASSIGN 2900 TO RETRN5 GOTO REMOT5 ELSE IF ( KEYNO .EQ. XADD .OR. KEYNO .EQ. XDROP ) THEN C ADD OR DROP PROBLEM. IF ( PARCT .GT. 0 ) THEN CALL ZZADDP ( KEYNO .EQ. XADD, KEYSTR, PARS, PARCT, - LIST, NPROBS, MXPRBS, PRECNO, NAMES, - DFPRBS, GROUPS, GNAMES, MXGRPS, G1, *91000 ) SORTFL = SORTFL .OR. KEYNO .EQ. XADD IF ( KEYNO .EQ. XADD ) THEN TODO(CCOLD) = T ENDIF ELSE CALL ZZERRM ( TM, *91000, - 'NT ADD OR DROP WITH NO PROBLEMS GIVEN' ) ENDIF ELSE IF ( KEYNO .EQ. XARITH ) THEN C REDEFINE ARITHMETIC LOOP CHARACTER. DCC(LOOPA:LOOPA) = S1(1:1) CALL ZZDSET (DCC) ELSE IF ( KEYNO .EQ. XASC ) THEN C SET TO ASCENDING SORT ASC = S1 .EQ. TRUE SORTFL = T TODO(CCOLD) = T ELSE IF ( KEYNO .EQ. XASSMT ) THEN C REDEFINE ASSIGNMENT CHARACTER. DCC(ASSMT:ASSMT) = S1(1:1) CALL ZZDSET (DCC) ELSE IF ( KEYNO .EQ. XBRIEF ) THEN C SET UP BRIEF COMMAND INPUT BRIEF = S1 .EQ. TRUE ELSE IF ( KEYNO .EQ. XBYE .OR. KEYNO .EQ. XEND - .OR. KEYNO .EQ. XQUIT ) THEN C EXIT COMMAND INPUT SECTION IF ( INTACT ) THEN WRITE ( RPSOUT, '(A)' ) ' FOR SURE(Y)?' IF (COPY) WRITE ( COPYUN, '(A)' ) ' FOR SURE(Y)?' READ ( STDIN , '(A)' ) S1 IF (COPY) WRITE(COPYUN,*) S1 CALL ZZCASE (S1, CTOUPP) IF ( S1(1:1) .EQ. 'Y' ) THEN GOTO 90000 ELSE WRITE ( RPSOUT, '(A)' ) ' QUIT IGNORED.' IF(COPY) WRITE ( COPYUN, '(A)' ) ' QUIT IGNORED.' ENDIF ELSE GOTO 90000 ENDIF ELSE IF ( KEYNO .EQ. XCC ) THEN C SET SYSTEM CARRIAGE CONTROL. SYSCC = NINT(PAR1) ELSE IF ( KEYNO .EQ. XCHECK ) THEN C SET CHECK BEGORE GO. LISTCD = NINT(PAR1) CHECK = LISTCD .NE. CHOFF ELSE IF ( KEYNO .EQ. XCOMME ) THEN C REDEFINE COMMENT CHARACTERS. IF ( PARCT .EQ. 0 ) THEN DCDMOD = DCDDON ELSE DCC(COM1:COM1) = S1(1:1) IF ( PARCT .GE. 2 ) THEN DCC(COM2:COM2) = KEYSTR(2)(1:1) ELSE DCC(COM2:COM2) = DCC(COM1:COM1) ENDIF ENDIF CALL ZZDSET (DCC) ELSE IF ( KEYNO .EQ. XCONTI ) THEN C REDEFINE CONTINUATION CHARACTER DCC(CONT:CONT) = S1 (1:1) CALL ZZDSET (DCC) ELSE IF ( KEYNO .EQ. XCOPY ) THEN C SET COPY FLAG COPY = T CALL ZZOPEN ( COPYUN, COPY , NMCOPY, *91000, RECL ) ELSE IF ( KEYNO .EQ. XCRIT ) THEN C SET CRITERION IF ( PARCT .EQ. 1 ) THEN CRITNO = NINT(PAR1) IF ( CRITNO .LT. 1 .OR. CRITNO .GT. MXCRIT ) THEN CALL ZZERRM( RD(I), *91000,'IS NOT VALID CRITERION') CRITNO = 0 ELSE LASTLN = LNO LNO = CRITNO CRITLN = T LL(CPL) = LL(LNO) LINELN = ZZLENG(LL(LNO)) GOTO 2100 ENDIF ELSE IF ( S1 .EQ. BLANK ) THEN I = NINT(PAR1) ELSE I = NINT (PARS(2)) ENDIF IF ( I .LT. 1 .OR. I .GT. MXCRIT ) THEN CALL ZZERRM( RD(I), *91000, - 'IS NOT VALID CRITERION ' ) ELSE LL(I) = LL(SVL) ENDIF ENDIF ELSE IF ( KEYNO .EQ. XDECOD ) THEN C SET TRACE IN DECODE. DCTRAC = S1 .EQ. TRUE CALL ZZOPEN(TRCOUT,DCTRAC,NMTRAC,*91000,RECL) ELSE IF ( KEYNO .EQ. XDEFAU ) THEN C SET TO DEFAULT VALUES. ASSIGN 82000 TO RETRN1 ASSIGN 2900 TO RETRN2 GOTO REMOT1 ELSE IF ( KEYNO .EQ. XDEFIN ) THEN C ENTER PROB DEFN MODE DEFNMD = PMODE C SET PROBLEM DEFAULT VALUES GOTO REMOT4 ELSE IF ( KEYNO .EQ. XDELIM ) THEN C REDEFINE DELIMITER CHARACTER. DCC(DEL:DEL) = S1 (1:1) CALL ZZDSET (DCC) ELSE IF ( KEYNO .EQ. XDERIV ) THEN C RESET DERIVATIVE MODE. DERVMD = NINT(PAR1) TODO(CCOLD) = T ELSE IF ( KEYNO .EQ. XDESC ) THEN C SET TO DESCENDING SORT ASC = S1 .NE. TRUE SORTFL = T TODO(CCOLD) = T ELSE IF ( KEYNO .EQ. XDOSUM ) THEN C DO A SUMMARY TODO(CDOTRM) = T GOTO 9000 ELSE IF ( KEYNO .EQ. XEOF ) THEN C RESET EOF HANDLING EOFBLK = NINT( PAR1 ) .EQ. CEOFIG ELSE IF ( KEYNO .EQ. XESCAP ) THEN C REDEFINE ESC CHARACTER. DCC(ESC:ESC) = S1 (1:1) CALL ZZDSET (DCC) ELSE IF ( KEYNO .EQ. XEVTRC ) THEN C SET TRACE OF FIN. DIFFS. EVTRAC = S1 .EQ. TRUE CALL ZZESET ( TRF, TRG, EVTRAC, TRCOUT ) CALL ZZOPEN(TRCOUT,EVTRAC,NMTRAC,*91000,RECL) ELSE IF ( KEYNO .EQ. XEXPNS ) THEN C SET UP EXPENSE FACTOR. TODO(CCOLD) = T SEPART = F OUTER = T OSCAL = 0 OINDEX = PTGXPN ASSIGN 2900 TO RETRN5 GOTO REMOT5 ELSE IF ( KEYNO .EQ. XFABS ) THEN C USE ABSOLUTE TESTS ON F. RELF = S1 .NE. TRUE TODO(CCOLD) = T ELSE IF ( KEYNO .EQ. XFACTO ) THEN C RESET FACTOR. TODO(CCOLD) = T SEPART = F OUTER = T OSCAL = 0 OINDEX = PTFACT ASSIGN 2900 TO RETRN5 GOTO REMOT5 ELSE IF ( KEYNO .EQ. XFORWO ) THEN C USE FORWARD COMMUNICATION. REVERS = S1 .NE. TRUE TODO(CCOLD) = T ELSE IF ( KEYNO .EQ. XFREE ) THEN C FIND FREE PROBLEM NUMBERS. K = 0 DO 2420 I = 1,MAX(1,NINT(PAR1)) 2418 K = K+1 IF ( K .GT. DFPRBS) THEN GOTO 2422 ELSE IF (PRECNO(RECN,K) .EQ. -1) THEN WRITE(RPSOUT,'(I4)') K IF ( COPY ) WRITE(COPYUN,'(I4)') K ELSE GOTO 2418 ENDIF 2420 CONTINUE 2422 CONTINUE ELSE IF ( KEYNO .EQ. XFREL ) THEN C USE RELATIVE TESTS ON F. RELF = S1 .EQ. TRUE TODO(CCOLD) = T ELSE IF ( KEYNO .EQ. XFTRAC ) THEN C TURN ON FUNCTION TRACE. TRF = S1 .EQ. TRUE TODO(CCOLD) = T CALL ZZESET ( TRF, TRG, EVTRAC, TRCOUT ) CALL ZZOPEN(TRCOUT,TRF,NMTRAC,*91000,RECL) ELSE IF ( KEYNO .EQ. XGABS ) THEN C USE ABSOLUTE TESTS ON G. RELG = S1 .NE. TRUE TODO(CCOLD) = T ELSE IF ( KEYNO .EQ. XGEOME ) THEN C REDEFINE GEOMETRIC LOOP CHARACTER DCC(LOOPG:LOOPG) = S1(1:1) CALL ZZDSET (DCC) ELSE IF ( KEYNO .EQ. XGREL ) THEN C USE RELATIVE TESTS ON G. RELG = S1 .EQ. TRUE TODO(CCOLD) = T ELSE IF ( KEYNO .EQ. XGTRAC ) THEN C TURN ON GRADIENT TRACE. TRG = S1 .EQ. TRUE TODO(CCOLD) = T CALL ZZESET ( TRF, TRG, EVTRAC, TRCOUT ) CALL ZZOPEN(TRCOUT,TRG,NMTRAC,*91000,RECL) ELSE IF ( KEYNO .EQ. XIMMED ) THEN C SET FOR IMMEDIATE EXECUTION. IMMED = S1 .EQ. TRUE ELSE IF ( KEYNO .EQ. XINPUT ) THEN C REDEFINE INPUT UNIT. IF ( S1 .EQ. BLANK ) THEN NEXTUN = NINT(PAR1) NMNEXT = BLANK ELSE NEXTUN = INPTUN NMNEXT = LL(SVL) ENDIF C IMMEDIATELY OPEN THE INPUT FILE. CALL ZZCLSE ( NEXTUN, *91000 ) CALL ZZOPEN ( NEXTUN, T, NMNEXT, *2430, RECL ) I = READUN READUN = NEXTUN NEXTUN = I TRMRD = F CALL ZZCLSE ( STDIN , *2430 ) GOTO 2440 2430 CALL ZZERRM (I, *91000,'NS OPEN FAILED ON FILE '//NMNEXT) READUN = STDIN 2440 CONTINUE ELSE IF ( KEYNO .EQ. XLIST ) THEN C LIST PROBLEM SET WRITE(RPSOUT,'(A)') 'P# DIMN PROBLEM FUNCTION' IF ( PARCT .GE. 2 ) THEN II = NINT(PARS(2)) J = NINT(PAR1) ELSE IF ( PARCT .EQ. 1 ) THEN II = NINT(PAR1) J = NINT(PAR1) ELSE II = DFPRBS J = 1 ENDIF DO 2445 JJ = J, II IF ( PRECNO(RECN,JJ) .NE. -1 ) THEN KK = (JJ-1)*2*PNAMLN WRITE(RPSOUT,'(I3,'':'',I4,2X,A8,1X,A8)') - JJ,PRECNO(DIMN,JJ), - NAMES(KK+1:KK+PNAMLN), - NAMES(KK+PNAMLN+1:KK+2*PNAMLN) ENDIF 2445 CONTINUE ELSE IF ( KEYNO .EQ. XLONGF ) THEN C SET FOR LONG PRINT OF F. LONGF = S1 .EQ. TRUE ELSE IF ( KEYNO .EQ. XMEMOR ) THEN C DEFINE ALLOWABLE MEMORY USAGE. TODO(CCOLD) = T MEMORY = MIN( NINT(PAR1),LR ) IF ( MEMORY .LE. 0 ) THEN MEMORY = LR ENDIF ELSE IF ( KEYNO .EQ. XMODE ) THEN C SET RUN MODE. INTACT = NINT(PAR1) .EQ. CINTAC CALL ZZETRM ( INTACT, RPSOUT ) CALL ZZOPEN ( RPSOUT, INTACT, NMTRMO, *91000, RECL ) ELSE IF ( KEYNO .EQ. XNORM ) THEN C RESET NORM. TODO(CCOLD) = T NORM = NINT(PAR1) CALL ZZTSET ( NORM, QUITS, TTRACE, TRCOUT ) ELSE IF ( KEYNO .EQ. XPGRAD ) THEN C GRADIENT PRINT FLAG SET. IF ( LOCAL ) THEN IGRAD = S1 .EQ. TRUE ELSE GRAD = S1 .EQ. TRUE ENDIF TODO(CCOLD) = T ELSE IF ( KEYNO .EQ. XPOINT ) THEN C POINT PRINT FLAG SET. IF ( LOCAL ) THEN IPOINT = S1 .EQ. TRUE ELSE POINT = S1 .EQ. TRUE ENDIF TODO(CCOLD) = T ELSE IF ( KEYNO .EQ. XPRINT ) THEN C RESET PRINT FREQUENCY IF ( LOCAL ) THEN IPRL = NINT(PAR1) CALL ZZOPEN ( RPSOUT, T, BLANK, *91000, RECL ) ELSE PRINTL = NINT(PAR1) WRITFL = PRINTL .NE. 0 CALL ZZOPEN ( RESOUT, WRITFL, NMWRIT, *91000, RECL ) ENDIF TODO(CCOLD) = T ELSE IF ( KEYNO .EQ. XRADIX ) THEN C RESET RADIX CHARACTER. DCC(RADIX:RADIX) = S1(1:1) CALL ZZASET ( DCC(RADIX: RADIX ), DCC(RADPRB:RADPRB), - DCC(RADFUN:RADFUN), DCC(RADGRP:RADGRP)) CALL ZZDSET (DCC) ELSEIF ( KEYNO .EQ. XRENAM ) THEN C PROCESS SYNONYM; MUST REPLACE KEYWORD AND RESORT DICTIONARY. J = NINT(PAR1) MAPKEY = MAP1( XXLAST+J ) S1 = KEYSTR(2) I = (MAPKEY-1) * KEYLEN + 1 J = MAPKEY*KEYLEN CINF(MAPKEY,1) = MXPARS CINF(MAPKEY,2) = TYREAL IF ( LLT( S1, CMDS(I:J) ) ) THEN C ADJUST DOWN FROM MAPKEY. MAPKEY = -MAPKEY ELSE C ADJUST UP FROM MAPKEY. ENDIF CMDS( I : J ) = S1 2470 CALL ZZDSRT ( CMDS, CINF, NCMDS, KEYLEN, MAP1, INVMP1, - MAPKEY, T, S1, S2 ) ELSE IF ( KEYNO .EQ. XREQUI ) THEN C SET TITLE FLAG TITREQ = S1 .EQ. TRUE ELSE IF ( KEYNO .EQ. XRESET ) THEN C RESET THE PROBLEM SET. NPROBS = 0 ELSE IF ( KEYNO .EQ. XRESUL ) THEN C RENAME RESULT FILE NMWRIT = S1 CALL ZZCASE ( NMWRIT, CTOUPP ) CALL ZZCLSE ( RESOUT, *91000 ) IF (NMWRIT .EQ. NMTRAC ) THEN RESOUT = TRACUN CALL ZZOPEN( RESOUT,T,NMWRIT,*91000,RECL) ELSE IF (NMWRIT .EQ. 'TERMINAL') THEN RESOUT = RPSOUT CALL ZZOPEN( RESOUT,T,BLANK,*91000,RECL) ELSE NMWRIT = S1 RESOUT = WRITUN CALL ZZOPEN( RESOUT,T,NMWRIT,*91000,RECL) ENDIF TODO(CCOLD) = T ELSE IF ( KEYNO .EQ. XREVER ) THEN C SET COMMUNICATION MODE. TODO(CCOLD) = T REVERS = S1 .EQ. TRUE ELSE IF ( KEYNO .EQ. XSEE ) THEN C SET TERMINAL SUMMARY LEVEL. SEELEV = NINT(PAR1) TODO(CDOTRM) = T CALL ZZOPEN ( RPSOUT, SEELEV .NE. CNONE, NMTRMO, - *91000, RECL ) ELSE IF ( KEYNO .EQ. XSELCT ) THEN C SELECT USER ARGUMENT. USERNO = NINT(PAR1) ELSE IF ( KEYNO .EQ. XSEPAR ) THEN C REDEFINE SEPARATOR CHARACTER. DCC(SEP:SEP) = S1 (1:1) CALL ZZDSET (DCC) ELSE IF ( KEYNO .EQ. XSORT ) THEN C SET SORT ORDER. SORT = NINT(PAR1) SORTFL = SORT .NE. SASIS TODO(CCOLD) = T ELSE IF ( KEYNO .EQ. XSTART ) THEN C START MINIMIZATION IF ( PARCT .EQ. 0 ) THEN GOTO 3000 ELSE IF ( INT(PAR1) .EQ. CNOGO ) THEN C DO NOTHING ELSE GOTO 3000 ENDIF ELSE IF ( KEYNO .EQ. XSTRIN ) THEN C REDEFINE STRING CHARACTER DCC(STRNG1:STRNG1) = S1(1:1) IF ( PARCT .GE. 2 ) THEN DCC(STRNG2:STRNG2) = KEYSTR(2)(1:1) ENDIF CALL ZZDSET (DCC) ELSE IF ( KEYNO .EQ. XSUBRO ) THEN C DEFINE SUBROUTINE NAME. IF ( PARCT .LT. 2 ) THEN CALL ZZERRM (TM,*91000, - 'NS SUBROUTINE NAME AND/OR NUMBER MISSING' ) ELSE IF ( S1 .EQ. BLANK ) THEN S1 = KEYSTR(2) II = NINT(PAR1) ELSE II = NINT (PARS(2)) ENDIF IF ( II .LT. 1 .OR. II .GT. MXSUBS ) THEN CALL ZZERRM( RD(II), *91000, - 'IS NO VALID SUBROUTINE NUMBER ' ) ELSE C MUST REPLACE KEYWORD AND RESORT DICTIONARY. MAPKEY = MAP3 ( ZZLAST + II ) I = (MAPKEY-1) * KEYLEN + 1 J = MAPKEY*KEYLEN IF ( LLT( S1, CPARS( I : J ) ) ) THEN C ADJUST UP FROM MAPKEY. MAPKEY = -MAPKEY ELSE C ADJUST DOWN FROM MAPKEY. ENDIF CPARS( I : J ) = S1 CPINF(MAPKEY,1) = XWITH CPINF(MAPKEY,2) = II CALL ZZDSRT( CPARS, CPINF, NCPARS, KEYLEN, MAP3, - INVMP3, MAPKEY, T, S1, S2 ) TODO(CCOLD) = T ENDIF ENDIF ELSE IF ( KEYNO .EQ. XSUMMA ) THEN C SUMMARY ON WRITUN. WRTSUM = S1 .EQ. TRUE TODO(CDOFLE) = T ELSE IF ( KEYNO .EQ. XTERM ) THEN C RESET TYPE. DO 2560 I=1,PARCT CALL ZZCASE(KEYSTR(I), CTOUPP) IF ( KEYSTR(I)(1:1) .EQ. QT ) THEN QUITS(I:I) = QT ELSE IF ( KEYSTR(I)(1:1) .EQ. QF ) THEN QUITS(I:I) = QF ENDIF 2560 CONTINUE CALL ZZTSET ( NORM, QUITS, TTRACE, TRCOUT ) TODO(CCOLD) = T ELSE IF ( KEYNO .EQ. XTEX ) THEN C SET TEX FLAG TEX = T C CALL ZZOPEN(TEXUN,T,BLANK,*91000,RECL) ELSE IF ( KEYNO .EQ. XTITLE ) THEN C GET TITLE LINE. IF ( S1 .EQ. BLANK ) THEN TITLE = BLANK ELSE TITLE = LL(SVL) ENDIF S2 = TITLE CALL ZZCASE ( S2, CTOUPP ) IF ( S2 .EQ. ENDIT ) THEN GOTO 90000 ENDIF ELSE IF ( KEYNO .EQ. XTRACE ) THEN C SET TRACE FLAGS. TODO(CCOLD) = T IF ( PARCT .EQ. 0 ) THEN C ALL SET TO TRUE. DO 2520 II = 1, NTR TRACES(II) = T 2520 CONTINUE ELSE DO 2530 II = 1 , PARCT CALL ZZCASE ( KEYSTR(II), CTOUPP ) IF ( KEYSTR(II)(1:1) .EQ. QT ) THEN TRACES(II) = T ELSEIF ( KEYSTR(II)(1:1) .EQ. QF ) THEN TRACES(II) = F ENDIF 2530 CONTINUE ENDIF FLTRAC = F DO 2540 II = 1, NTR IF (TRACES(II) ) THEN FLTRAC = T GOTO 2550 ENDIF 2540 CONTINUE 2550 CALL ZZOPEN(TRCOUT,T,NMTRAC,*91000,RECL) ELSE IF ( KEYNO .EQ. XTRCUN ) THEN C REASSIGN TRACE UNIT CALL ZZCLSE ( TRCOUT, *91000 ) NMTRAC = S1 CALL ZZCASE ( NMTRAC, CTOUPP ) IF (NMTRAC .EQ. NMWRIT ) THEN TRCOUT = WRITUN CALL ZZOPEN ( TRCOUT,T,NMTRAC,*91000,RECL) ELSE IF (NMTRAC .EQ. 'TERMINAL') THEN TRCOUT = RPSOUT CALL ZZOPEN ( RPSOUT,T,BLANK,*91000,RECL) ELSE IF (NMTRAC .EQ. 'TEMP') THEN TRCOUT = TEMPUN CALL ZZOPEN ( TEMPUN,T,BLANK,*91000,RECL) ELSE NMTRAC = S1 TRCOUT = TRACUN CALL ZZOPEN ( TRCOUT,T,NMTRAC,*91000,RECL) ENDIF CALL ZZESET ( TRF, TRG, EVTRAC, TRCOUT ) CALL ZZTSET ( NORM, QUITS, TTRACE, TRCOUT ) TODO(CCOLD) = T ELSE IF ( KEYNO .EQ. XTTRAC ) THEN C TURN ON TERMINATION TRACE. TTRACE = S1 .EQ. TRUE CALL ZZTSET ( NORM, QUITS, TTRACE, TRCOUT ) TODO(CCOLD) = T CALL ZZOPEN(TRCOUT,TTRACE,NMTRAC,*91000,RECL) ELSE IF ( KEYNO .EQ. XUPPER ) THEN C SET UPPER CASE. UPCASE = S1 .EQ. TRUE IF ( UPCASE ) CALL ZZCASE ( LL(LNO), CTOUPP ) ELSE IF ( KEYNO .EQ. XUSER ) THEN C SET THE USER DEFINED ARGUMENT. TODO(CCOLD) = T OUTER = T OSCAL = 0 IF ( USERNO .NE. 0 ) THEN SEPART = F OINDEX = PTUSER(USERNO) ELSE SEPART = T OINDEX = PTUSER(1) ENDIF ASSIGN 2900 TO RETRN5 GOTO REMOT5 ELSE IF ( KEYNO .EQ. XVALUE ) THEN C DISPLAY CURRENT SETTINGS. IF ( PARCT .GT. 0 ) THEN VALS = NINT(PAR1) ELSE VALS = CALL ENDIF GOTO REMOT7 ELSE IF ( KEYNO .EQ. XVERIF ) THEN C RESET DECODING VERIFICATION. VERIFY = S1 .EQ. TRUE ELSE IF ( KEYNO .EQ. XWATCH ) THEN C SET LOCAL ITERATES FLAG. LOCAL = S1 .EQ. TRUE ELSE IF ( KEYNO .EQ. XWITH ) THEN C SET THE SUBROUTINE TO USE. IF ( PAR1 .LT. 1 .OR. PAR1 .GT. MXPARS - .OR. PARCT .EQ. 0 ) THEN CALL ZZERRM ( TM, *91000, 'NS UNDEFINED SUBROUTINE' ) ELSE SUBR = NINT(PAR1) TODO(CCOLD) = T ENDIF ELSE IF ( KEYNO .GT. XXLAST ) THEN C SET THE USER ARGUMENT. TODO(CCOLD) = T OUTER = T OSCAL = 0 OINDEX = PTUSER( KEYNO - XXLAST ) ASSIGN 2900 TO RETRN5 GOTO REMOT5 ENDIF ENDIF 2900 CONTINUE IF ( DCDMOD .EQ. DCDMOR ) THEN GOTO 2100 ELSE IF ( CRITLN ) THEN LL(CRITNO) = LL(CPL) CRITLN = F LNO = LASTLN LINELN = ZZLENG(LL(LNO)) LASTLN = NULLIN GOTO 2100 ELSE IF ( IMMED ) THEN PHASE = 5 GOTO 3000 ELSE IF ( BRIEF ) THEN PHASE = 5 GOTO 2000 ELSE IF ( KEYNO .EQ. 0 .AND. PHASE .EQ. 5 ) THEN IF (CHECK) THEN GOTO 2000 ELSE GOTO 3000 ENDIF ELSE IF ( TRMRD ) THEN PHASE = MIN ( 5 , PHASE + 1 ) GOTO 2000 ELSE GOTO 2000 ENDIF 3000 CONTINUE C >==================================>> EXECUTION BEGINS HERE. C-----PREPARE TO EXECUTE A BLOCK OF TESTS. SAVE THE RESULTS. 6000 REWIND TEMPUN IF ( .NOT. TODO(CCOLD) .OR. NPROBS .EQ. 0 ) THEN GOTO 9000 ENDIF C SAVE INFORMATION DEFINING THE TEST. WRITE ( TEMPUN, 98000 ) TESTCH WRITE ( TEMPUN, * ) NPROBS, NORM, CRITNO, - RELF, RELG, DERVMD, MEMORY,SUBR WRITE ( TEMPUN, '(A)' ) QUITS MAPKEY = MAP3( ZZLAST + SUBR ) J = ( MAPKEY-1 )* KEYLEN + 1 K = MAPKEY * KEYLEN SUBNAM = CPARS(J:K) WRITE ( TEMPUN, '( A, A )' ) SUBNAM, TITLE C SORT LIST IF NECESSARY. IF ( SORTFL .AND. SORT .NE. SASIS ) THEN SORTFL = F CALL ZZSORT ( SORT, LIST, NPROBS, PRECNO, NAMES, PNAMLN, ASC ) ENDIF C !!! TOP OF OUTER LOOP. SEARCH FOR AND SOLVE EACH SPECIFIED PROBLEM C VVV UNTIL THERE ARE NO MORE LEFT. THEN SUMMARIZE. TERMINATE IF C A NONZERO ERROR CODE IS FOUND. 8000 CONTINUE CALL ZZLPCK ( OLOOPC, OLOOPX, OORDER, PTACC, ACC ) GLBLOK = T IF ( ACC .GE. ONE .AND. ACC .EQ. NINT(ACC) ) THEN ACC = TEN**(-NINT(ACC)) ENDIF CALL ZZLPCK ( OLOOPC, OLOOPX, OORDER, PTFACT, FACTOR ) CALL ZZLPCK ( OLOOPC, OLOOPX, OORDER, PTGXPN, VALUE ) GEXPNS = NINT(VALUE) DO 8050 I = 1, NU CALL ZZLPCK ( OLOOPC, OLOOPX, OORDER, PTUSER(I), USER(I) ) 8050 CONTINUE WRITE ( TEMPUN, '(3E24.18)' ) ACC, FACTOR, USER WRITE ( TEMPUN, * ) ' ' C !!! TOP OF MIDDLE (PROBLEM) LOOP C VVV DO 8800 PROBCT = 1, NPROBS PROB = LIST( PROBCT ) CALL ZZGETP ( DAUF, PROB , PFNUM , PPNAM , PFNAM, PDESC, - SOLNS, PINTS, IORDER, ILOOPX, ILOOPC, X0 , - NAMES, PRECNO, ERRFLG, *91000 ) IF (ERRFLG .NE. 0) THEN CALL ZZERRM(RD(PROB), *91000, - 'IFUNEXPECTED ERROR IN ACCESSING PROBLEM ') GOTO 8800 ENDIF C !!! TOP OF INNER LOOP C VVV 8100 CALL ZZLPCK ( ILOOPC, ILOOPX, IORDER, PTNDIM, VALUE ) N = NINT(VALUE) CALL ZZLPCK ( ILOOPC, ILOOPX, IORDER, PTSCAL, VALUE ) SCAL = NINT(VALUE) CALL ZZLPCK ( ILOOPC, ILOOPX, IORDER, PTPXPN, VALUE ) PEXPNS = NINT(VALUE) IF ( PEXPNS .EQ. 0 ) THEN EXPENS = GEXPNS ELSE EXPENS = PEXPNS ENDIF DO 8150 I= 1, FNO CALL ZZLPCK ( ILOOPC, ILOOPX, IORDER, PTFARG(I), FARG(I) ) 8150 CONTINUE C ---PREPARE ZZEVAL AND ZZFNS. IF ( N .GT. MAXN ) THEN CALL ZZERRM(RD(N),*91000,'ITIGNORE PROBLEM; TOO LARGE N=') GOTO 8700 ENDIF CALL ZZESRT ( SCAL, DERVMD, PMAX, EXPENS ) CALL ZZFPAR ( FARG ) IF ( PFNUM .EQ. -1 ) THEN CALL ZZFSET ( PFNAM, EXTRA, PFNUM, I ) ENDIF DO 8170 I = 1,N X(I) = X0(I) 8170 CONTINUE CALL ZZSTX0( IX0, X, N, FACTOR, G, RWORK ) WRITE ( TEMPUN, '(A1)' ) TESTCH WRITE ( TEMPUN, '(A,A)' ) PPNAM, PFNAM WRITE ( TEMPUN, * ) PROB, PFNUM, N, SCAL, EXPENS, FARG WRITE ( TEMPUN, * ) ' ' WRITE ( TEMPUN, * ) (X(I), I = 1,N ) WRITE ( TEMPUN, * ) ' ' C ---PREPARE ZZPRNT. CALL ZZP1ST( TEMPUN, GRAD, POINT, PRINTL ) CALL ZZP2ST( RPSOUT, IGRAD, IPOINT, IPRL, COPY, COPYUN ) C CALL A USER ROUTINE JUST BEFORE SOLVING PROBLEM. CALL ZZBFOR( TESTCH, STATUS, SUBR, WRTSUM, SEELEV, WRITFL, - IW, RW, DW ) C ---CALL ZZLINK TO DO MINIMIZATION. CALL ZZSECS ( TMIN ) IF ( REVERS ) THEN STATUS = RCSTRT CASE = BOTH CALL ZZEVAL( ZZFNS,N,X,FNC,G,CASE,IW,RW,DW) ELSE STATUS = NORMAL ENDIF 8200 CALL ZZLINK ( N, X, FNC, G, ACC, RELF, RELG, STATUS, SUBR, - TRCOUT, TRACES, - NTR, PRINTL, PMAX, DERVMD, USER, - NU, RWORK, MEMORY, IWORK, LI, IW, RW, DW ) C CHECK FOR REVERSE COMMUNICATION. IF ( REVERS .AND. ( STATUS .EQ. RCF .OR. STATUS .EQ. RCFG - .OR. STATUS .EQ. RCG ) ) THEN CASE = BOTH CALL ZZEVAL( ZZFNS,N,X,FNC,G,CASE,IW,RW,DW) STATUS = RCRPT GOTO 8200 ENDIF CALL ZZSECS ( TM ) TMIN = TM - TMIN C DO SUMMARY PROCESSING C UPDATE CUMULATIVES AND OUTPUT STATISTICS. CALL ZZEGET ( FUNCCT, GRADCT, TFUNC ) CALL ZZPGET ( PRTIME, ITCT ) IF ( DERVMD .EQ. CTEST .OR. DERVMD .EQ. CFIRST ) THEN CALL ZZECHK ( MXERR, DIGS, INDX, GCNT ) ENDIF IF ( STATUS .GT. USERV ) THEN C OUTPUT THE SOLUTION. GSQ = ZZNRM2 ( N, G ) C OUTPUT DISTANCE TO TRUE SOLUTION. FSTAR = FNC CALL ZZDSOL(N, FSTAR, X, RWORK, SOLNS, DF, DX, SOLNF, SOLNX) IF ( WRITFL ) THEN CALL ZZPRNT(N,X,FNC,G,GSQ,0) ENDIF IF ( FUNCCT .EQ. 1 ) THEN STATUS = IPMIN ENDIF ELSE GSQ = -ONE DF = -ONE DX = -ONE SOLNX = 0 SOLNF = 0 ENDIF TMIN = TMIN - PRTIME WRITE ( TEMPUN, '(A1,A)' ) TESTCH MING = ABS(G(1)) MAXG = MING DO 8400 I=1,N MING = MIN ( MING, ABS(G(I)) ) MAXG = MAX ( MAXG, ABS(G(I)) ) 8400 CONTINUE WRITE ( TEMPUN, * ) ITCT, FUNCCT, GRADCT, DF, DX, SOLNX, - SOLNF,FNC, GSQ, MING, MAXG, TMIN,TFUNC,PRTIME,STATUS IF ( DERVMD .EQ. CTEST .OR. DERVMD .EQ. CFIRST ) THEN WRITE ( TEMPUN, * ) MXERR, INDX, GCNT, DIGS ENDIF C CALL USER ROUTINE AFTER SOLVING THE PROBLEM. CALL ZZAFTR( TESTCH, STATUS, SUBR, WRTSUM, SEELEV, WRITFL, - IW, RW, DW ) IF ( TEX ) THEN I = -NINT(LOG10(ACC)) CALL ZZTEX(TEXUN, PFNAM, PROB ,FUNCCT, ITCT, FNC, DF, - FSTAR, I, GSQ, MING, DX, CRITNO, STATUS,TFUNC,TMIN ) ENDIF C------------- 8700 CALL ZZLADV ( ILOOPC, ILOOPX, ILPXSZ, OVER ) GLBLOK = GLBLOK .AND. STATUS .EQ. CDONE .AND. GSQ .NE. ZERO IF ( .NOT. OVER ) GOTO 8100 C^^^^^ C-------------END INNER LOOP 8800 CONTINUE C^^^^^ C-------------END MIDDLE (PROBLEM) LOOP WRITE ( TEMPUN, '(A,A)' ) TESTCH,'END OF SET ' CALL ZZLADV ( OLOOPC, OLOOPX, OLPXSZ, OVER ) IF ( GLBLOK .AND. .NOT. OVER ) THEN GOTO 8000 ENDIF C^^^^^ C-------------END OUTER LOOP. C >==================================>> SECTION (7) BEGINS HERE. C-----WRITE SUMMARY OF STATISTICS FOR THE SET OF TESTS. 9000 IF ( (TODO(CCOLD) .OR. TODO(CDOTRM) .OR. TODO(CDOFLE)) - .AND. NPROBS .NE. 0 ) THEN CALL ZZSMRY ( TODO, X, SYSCC, WRTSUM, WRITFL, NMWRIT, - COPY, LL, MXCRIT, NL, RPSOUT, - TESTCH, XXLAST, SEELEV, LONGF, CMDS, MAP1, *91000 ) ENDIF TODO(CCOLD ) = F TODO(CDOFLE) = F TODO(CDOTRM) = F GOTO 1000 C## R E M O T E B L O C K 1: C SET DEFAULTS FOR BASIC VARIABLES. 81000 CONTINUE C-----INITIALIZE MEMORY AND SORT. MEMORY = LR SORT = DSORT SORTFL = SORT .NE. SASIS C-----INITIALIZE ZZPRNT. PRINTL = DPRINT POINT = DPOINT GRAD = DGRAD IPRL = DIPR IPOINT = DIPT IGRAD = DIGRAD LOCAL = DLOCAL C-----INITIALIZE ZZEVAL. DERVMD = DDERV REVERS = DREVRS C-----INITIALIZE ZZTERM AND ACCURACY. ACC = DACC RELF = DRELF RELG = DRELG NORM = DNORM QUITS = DQUITS CALL ZZTSET ( NORM, QUITS, TTRACE, TRCOUT ) GOTO RETRN1 C## R E M O T E B L O C K 2: C SET OUTER LOOP DATA TO DEFAULTS 82000 CONTINUE DO 82100 I = 1, OLPXSZ OORDER(I) = I OLOOPX(I) = 3*I-2 82100 CONTINUE OLOOPX( OLPXSZ+1 ) = 3*OLPXSZ+1 OLOOPC( OLOOPX( OORDER( PTACC ) ) ) = ONE OLOOPC( OLOOPX( OORDER( PTACC ) ) + 1 ) = ONE OLOOPC( OLOOPX( OORDER( PTACC ) ) + 2 ) = DACC OLOOPC( OLOOPX( OORDER( PTGXPN ) ) ) = ONE OLOOPC( OLOOPX( OORDER( PTGXPN ) ) + 1 ) = ONE OLOOPC( OLOOPX( OORDER( PTGXPN ) ) + 2 ) = DGXPNS OLOOPC( OLOOPX( OORDER( PTFACT ) ) ) = ONE OLOOPC( OLOOPX( OORDER( PTFACT ) ) + 1 ) = ONE OLOOPC( OLOOPX( OORDER( PTFACT ) ) + 2 ) = DFACTR DO 82300 I = 1, NU OLOOPC( OLOOPX( OORDER( PTUSER(I) ) ) ) = ONE OLOOPC( OLOOPX( OORDER( PTUSER(I) ) ) + 1 ) = ONE OLOOPC( OLOOPX( OORDER( PTUSER(I) ) ) + 2 ) = USERD(I) USER(I) = USERD(I) 82300 CONTINUE GOTO RETRN2 C## R E M O T E B L O C K 4: C C SET PROBLEM DEFAULT VALUES 84000 PTSOLN = 1 SOLNS(1) = 0 PPNAM = UNDEFN PPNUM = -1 PFNAM = BLANK PFNUM = -1 PGNAM = BLANK PGNUM = -1 PMAX = DMAXF PDESC = BLANK PPERM = DPERM IX0 = DIX0 X(1) = DX1 X(2) = DX2 LDESC = ZZLENG( PDESC ) LORDER = ILPXSZ LLOOPX = ILPXSZ+1 LLOOPC = ILPXSZ*3 C INITIALIZE LOOPS DO 84100 I=1,ILPXSZ IORDER(I) = I ILOOPX(I) = 3*I-2 84100 CONTINUE ILOOPC(ILOOPX(IORDER(PTNDIM))) = ONE ILOOPC(ILOOPX(IORDER(PTNDIM))+1) = ONE ILOOPC(ILOOPX(IORDER(PTNDIM))+2) = RD(DNDIM) ILOOPC(ILOOPX(IORDER(PTSCAL))) = ONE ILOOPC(ILOOPX(IORDER(PTSCAL))+1) = ONE ILOOPC(ILOOPX(IORDER(PTSCAL))+2) = RD(DSCAL) ILOOPC(ILOOPX(IORDER(PTPXPN))) = ONE ILOOPC(ILOOPX(IORDER(PTPXPN))+1) = ONE ILOOPC(ILOOPX(IORDER(PTPXPN))+2) = DPXPNS DO 84300 I=1,FNO ILOOPC(ILOOPX(IORDER(PTFARG(I)))) = ONE ILOOPC(ILOOPX(IORDER(PTFARG(I)))+1) = ONE ILOOPC(ILOOPX(IORDER(PTFARG(I)))+2) = DFARG 84300 CONTINUE C---- RECORD NEXT FREE SPOT IN ILOOPC ILOOPX( LLOOPX ) = LLOOPC+1 GOTO RETRN4 C## R E M O T E B L O C K 5: C INSERT INFO INTO THE INNER OR OUTER LOOPS C ON ENTRY TO THIS BLOCK : C C LASTDL DETERMINES WHETHER THE VALUES CONSTITUTE A LOOP C OR A LIST. C OSCAL DETERMINES WHETHER THE VALUES SHOULD BE TREATED C AS INTEGERS OR REALS ( 2 FOR INTEGER, 0 FOR REAL ). C PARS CONTAINS THE ACTUAL LIST OR LOOP DATA. C OINDEX THIS IS A POINTER INTO THE ORDER ARRAY ( IORDER C OR OORDER ). C OUTER THIS IS TRUE ONLY IF THE OUTER LOOPS ARE TO BE C MODIFIED. 85000 CONTINUE C SET THE CODE AND THE STARTING VALUE CNEXT = 1 IF (SEPART) THEN TCT = PARCT LPDATA ( CNEXT ) = ONE LPDATA ( CNEXT+1 ) = ONE LPTYPE = LLIST ELSE IF ( LASTDL .EQ. DCC(LOOPA:LOOPA) ) THEN LPDATA ( CNEXT ) = RD ( 0 - OSCAL ) LPDATA ( CNEXT+1 ) = PAR1 LPTYPE = LARITH ELSE IF ( LASTDL .EQ. DCC(LOOPG:LOOPG) ) THEN LPDATA ( CNEXT ) = RD ( -1 - OSCAL ) LPDATA ( CNEXT+1 ) = PAR1 LPTYPE = LGEOMT ELSE LPDATA ( CNEXT ) = RD ( PARCT ) LPDATA ( CNEXT+1 ) = ONE LPTYPE = LLIST ENDIF TCT = 1 ENDIF DO 85100 II=1,TCT CNEXT = 3 C STORE THE LOOP OR LIST VALUES DO 85010 I=1,PARCT/TCT LPDATA ( CNEXT ) = PARS (II-1+I ) CNEXT = CNEXT + 1 85010 CONTINUE C SET DEFAULT LOOP INCREMENTS WHEN THERE ARE ONLY TWO PARAMETERS. IF ( PARCT .EQ. 2 ) THEN IF ( LPTYPE .EQ. LARITH ) THEN LPDATA(CNEXT) = ONE ELSE IF ( LPTYPE .EQ. LGEOMT ) THEN LPDATA(CNEXT) = TEN END IF END IF C FILL IN THE CONTROL ARRAY IF ( OUTER ) THEN C MODIFY OUTER LOOP CALL ZZLMOD ( OLOOPC, OLPCSZ, OLOOPX, OORDER, - OLPXSZ, LPDATA, OINDEX+II-1,LPTYPE, *91000 ) ELSE C MODIFY INNER LOOP CALL ZZLMOD ( ILOOPC, ILPCSZ, ILOOPX, IORDER, - ILPXSZ, LPDATA, OINDEX+II-1,LPTYPE, *91000 ) LLOOPC = ILOOPX( LLOOPX ) - 1 ENDIF 85100 CONTINUE SEPART = .FALSE. GOTO RETRN5 C## R E M O T E B L O C K 7: C C DISPLAY USER CONTROLLABLE SETTINGS. 87000 CONTINUE TMPUN = RPSOUT 87005 CONTINUE IF ( VALS .EQ. CALL .OR. VALS .EQ. CINPUT ) THEN C DISPLAY COMMAND CONTROL SETTINGS WRITE ( TMPUN, 98050 ) 'CONTROL SETTINGS' WRITE ( TMPUN, * ) WRITE ( TMPUN, 98101 ) 'TITLE REQ.',TITREQ, - 'BRIEF',BRIEF,'TO UPPER',UPCASE WRITE ( TMPUN, 98101 ) 'TRACE',DCTRAC,'VERIFY',VERIFY, - 'EOFBLK',EOFBLK WRITE ( TMPUN, 98150 ) 'ARITHMETIC',DCC(LOOPA:LOOPA), - 'ASSIGNMENT',DCC(ASSMT:ASSMT) WRITE ( TMPUN, 98150 ) 'COMMENT1',DCC(COM1:COM1), - 'COMMENT2',DCC(COM2:COM2), - 'CONTINUATION', DCC(CONT:CONT) WRITE ( TMPUN, 98150 ) 'DELIMITER',DCC(DEL:DEL), - 'ESCAPE',DCC(ESC:ESC), - 'GEOMETRIC',DCC(LOOPG:LOOPG) WRITE ( TMPUN, 98150 ) 'RADIX',DCC(RADIX:RADIX), - 'SEPARATOR',DCC(SEP:SEP), - 'STRING1',DCC(STRNG1:STRNG1) WRITE ( TMPUN, 98150 ) 'STRING2',DCC(STRNG2:STRNG2) WRITE ( TMPUN, 98201 ) 'PHASE 5 CHECK IS:', VCHEC(LISTCD) WRITE ( TMPUN, 98201 ) 'CARRIAGE CONTROL:', VCC (SYSCC) ENDIF IF ( VALS .EQ. CALL .OR. VALS .EQ. CLOOPS ) THEN C DISPLAY NUMERIC CONTROL VALUES WRITE ( TMPUN, * ) WRITE ( TMPUN, 98050 ) 'NUMERIC CONTROL DATA' J = OLOOPX( OORDER(PTACC) ) K = OLOOPX( OORDER(PTACC) + 1 ) - 1 WRITE ( TMPUN, 98400 ) 'ACCURACY', NINT(OLOOPC(J)), - (OLOOPC(I), I = J+2, K ) J = OLOOPX( OORDER(PTFACT) ) K = OLOOPX( OORDER(PTFACT) + 1 ) - 1 WRITE ( TMPUN, 98400 ) 'FACTOR', NINT(OLOOPC(J)), - (OLOOPC(I), I = J+2, K ) J = OLOOPX( OORDER(PTGXPN) ) K = OLOOPX( OORDER(PTGXPN) + 1 ) - 1 WRITE ( TMPUN, 98400 ) 'EXPENSE', NINT(OLOOPC(J)), - (OLOOPC(I), I = J+2, K ) DO 87100 II = 1, NU J = OLOOPX( OORDER(PTUSER(II)) ) K = OLOOPX( OORDER(PTUSER(II)) + 1 ) - 1 N = NINT( OLOOPC(J) ) JJ = MAP1( XXLAST+II ) * 8 S2 = CMDS( JJ-7 : JJ ) IF ( S2 .NE. BLANK ) THEN WRITE(TMPUN,98500) II, S2, N, ( OLOOPC(I), I= J+2, K) C!!!! WRITE(TMPUN,98450) II, S2, N, ( OLOOPC(I), I= J+2, K) ENDIF 87100 CONTINUE ENDIF IF ( VALS .EQ. CALL .OR. VALS .EQ. CCONTR ) THEN C DISPLAY RUN CONTROL SETTINGS WRITE ( TMPUN, * ) WRITE ( TMPUN, 98050 ) 'RUN CONTROL' WRITE ( TMPUN, 98050 ) ' '// - 'CRITERIA DEFINITIONS' NONE = T DO 87200 I = 1, MXCRIT IF (LL(I) .NE. BLANK) THEN WRITE ( TMPUN, 98040 ) I, LL(I)(1:74) NONE = F ENDIF 87200 CONTINUE IF ( NONE ) THEN WRITE ( TMPUN, 98050 ) ' '// - 'THERE ARE NONE KNOWN.' ENDIF WRITE ( TMPUN, * ) WRITE ( TMPUN, 98101 ) 'REVERSE',REVERS,'FUNC TRACE', - TRF,'GRAD TRACE',TRG WRITE ( TMPUN, 98101 ) 'PRINT GRAD',GRAD,'WRITE SUMM', - WRTSUM WRITE ( TMPUN, 98101 ) 'COPY',COPY,'TEX',TEX WRITE ( TMPUN, 98120 ) 'TRACES',TRACES WRITE ( TMPUN, * ) WRITE ( TMPUN, 98200 ) 'DERV MODE',CDERV(DERVMD), - 'TERM TYPE',QUITS,'NORM TYPE',CNORM(NORM) WRITE ( TMPUN, 98100 ) 'F-RELATIVE',RELF, - 'G-RELATIVE',RELG WRITE ( TMPUN, 98200 ) 'SEE LEVEL',VSEE(SEELEV),'SORT', - VSORT(SORT) WRITE ( TMPUN, 98220 ) 'MEMORY',MEMORY,'SUB NUMBER',SUBR, - 'PRINT FREQ',PRINTL WRITE ( TMPUN, * ) WRITE ( TMPUN, 98250 ) 'WRITE FILE',NMWRIT WRITE ( TMPUN, 98050 ) ' SUBROUTINE NAMES' NONE = T DO 87300 I=1,MXSUBS MAPKEY = MAP3( ZZLAST+I ) J = (MAPKEY-1)*KEYLEN+1 K = MAPKEY*KEYLEN IF ( CPARS(J:K) .NE. BLANK ) THEN NONE = F WRITE ( TMPUN, 98350 ) I, CPARS(J:K) ENDIF 87300 CONTINUE IF ( NONE ) WRITE ( TMPUN, * ) ' NONE DEFINED.' WRITE ( TMPUN, * ) ENDIF IF ( COPY .AND. TMPUN .NE. COPYUN ) THEN TMPUN = COPYUN GOTO 87005 ENDIF GOTO RETRN7 C## E X I T 90000 ASSIGN 95000 TO RETERR GOTO 92000 91000 ASSIGN 94000 TO RETERR GOTO 92000 C-----CLOSE ALMOST ALL FILES. 92000 CALL ZZCLSE ( SUMMUN, *92500 ) CALL ZZCLSE ( STDIN , *92500 ) CALL ZZCLSE ( TEMPUN, *92500 ) CALL ZZCLSE ( PREPRC, *92500 ) IF ( TEX ) THEN I = -NINT(LOG10(ACC)) CALL ZZTEX(TEXUN, BLANK, -1 ,FUNCCT, ITCT, FNC, DF, - FSTAR, I, GSQ, MING, DX, CRITNO, -1,TFUNC,TMIN ) ENDIF GOTO 93000 92500 ASSIGN 94000 TO RETERR C-----PRINT FINAL TIME SUMMARY. 93000 CALL ZZSECS ( TIMEIT ) IF ( WRITFL ) THEN WRITE ( RESOUT, 99999 ) TIMEIT ENDIF WRITE ( RPSOUT, 99999 ) TIMEIT IF (COPY) WRITE ( COPYUN, 99999 ) TIMEIT C-----CLOSE LAST THREE FILES. CALL ZZCLSE ( RESOUT, *94000 ) CALL ZZCLSE ( TRCOUT, *92500 ) CALL ZZCLSE ( RPSOUT, *94000 ) CALL ZZCLSE ( COPYUN, *94000 ) GOTO RETERR 94000 RECNO = 1 CALL ZZRDIN(DAUF,IW,1,IPERLN,RECNO) IW(2) = FREEPT RECNO = 1 CALL ZZWRIN(DAUF,IW,2,IPERLN,RECNO) CALL ZZCLSE(DAUF,*94500) 94500 STOP 'ABORTED' 95000 RECNO = 1 CALL ZZRDIN(DAUF,IW,2,IPERLN,RECNO) IW(2) = FREEPT RECNO = 1 CALL ZZWRIN(DAUF,IW,2,IPERLN,RECNO) CALL ZZCLSE(DAUF,*94500) STOP 'RUN OK' C## F O R M A T S: 98000 FORMAT ( A1 ) 98040 FORMAT ( 1X, I3,':',1X, A ) 98050 FORMAT ( 1X, A ) 98100 FORMAT ( 5X,A,T20,L1,T28,'!',T30,A,T40,L1,T51,'!') 98101 FORMAT ( 5X, A, T20, L1,T28, A, T40, L1, T48, A, T61,L1) 98120 FORMAT ( 5X, A, 6X, 15 ( L3 ) ) 98150 FORMAT ( 5X,A,T20,A1,T28, A, T40, A1, T48, A, T61, A1 ) 98200 FORMAT ( 5X,A,T17,A,T28,'!',T30,A,T40,A,T51,'!',T53,A,T64, A ) 98201 FORMAT ( 5X, A, T28, A ) 98220 FORMAT ( 5X,A,T17,I7,T28,'!',T30,A,T41,I5,T51,'!',T53,A, T64,I5) 98250 FORMAT ( 5X, A, T17, ' : ', A40 ) 98350 FORMAT ( 5X, I5, A10 ) 98400 FORMAT ( 5X, A, T29, I3, 5D12.3 ) 98450 FORMAT ( 5X, ' USER(', I2, ') =', T17, A8, T29, I3, 5D12.3 ) 98500 FORMAT ( 5X, ' USER(', I2, ') =', T17, A8, T29, I3, 5G12.3 ) 99999 FORMAT ( // ' TOTAL TIME TAKEN WAS ', F12.4, ' SECONDS.' ) C## E N D OF ZZMT. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> casesg.brk SUBROUTINE ZZCASE (STRING, TYPE ) C## A R G U M E N T S: CHARACTER *(*) STRING INTEGER TYPE C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NOT REQUIRED. C C SYSTEM DEPENDENCE: SYSTEM ROUTINE FOR CASE C CONVERSION OF LETTERS. C C THIS IS A VERSION FOR VAX/BERK4.2(3) C>RCS $HEADER: CASE.GL,V 2.0 90/07/05 12:44:20 BUCKLEY EXP $ C>RCS $LOG: CASE.GL,V $ C>RCS REVISION 2.0 90/07/05 12:44:20 BUCKLEY C>RCS COMMON VERSION FOR TOMS AND GL C>RCS C>RCS REVISION 1.9.1.1 89/06/30 14:59:19 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.9 89/06/30 13:30:11 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 16:07:53 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/20 13:48:39 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C## D E S C R I P T I O N: C THIS CONVERTS EACH LOWER CASE ALPHABETIC LETTER TO C UPPER CASE, OR VICE VERSA. C IF TYPE = CTOUPP, CONVERSION IS LOWER TO UPPER C IF TYPE = CTOLOW, CONVERSION IS UPPER TO LOWER C IF TYPE = CTOCAP, USE UPPER FOR FIRST LETTER; LOWER FOR REST C ALL OTHER CHARACTERS ARE LEFT UNCHANGED. C## E N T R Y P O I N T S: THE NATURAL ENTRY TTOUPPR. C## S U B R O U T I N E S: LEN (INTRINSIC). C## P A R A M E T E R S: INTEGER CTOUPP, CTOLOW, CTOCAP PARAMETER ( CTOUPP = 1, CTOLOW = 2, CTOCAP = 3 ) CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) CHARACTER*(*) PERIOD, COMMA, SEMICN PARAMETER ( PERIOD = '.', COMMA = ',', SEMICN = ';' ) CHARACTER*(*) COLON, DASH, EQUALS PARAMETER ( COLON = ':', DASH = '-', EQUALS = '=' ) CHARACTER*(*) OBRACE, CBRACE, UNDERS PARAMETER ( OBRACE = '{', CBRACE = '}', UNDERS = '_' ) CHARACTER*(*) PLUS, MINUS, EXCLAM PARAMETER ( PLUS = '+', MINUS = '-', EXCLAM = '!' ) CHARACTER*(*) GTHAN, LTHAN, QUESMK PARAMETER ( GTHAN = '>', LTHAN = '<', QUESMK = '?' ) CHARACTER*(*) SLASH, BSLASH, PERCNT PARAMETER ( SLASH = '/', BSLASH = '\\',PERCNT = '%' ) CHARACTER*(*) CARAT, ATSIGN, TILDE PARAMETER ( CARAT = '^', ATSIGN = '@', TILDE = '~' ) C## L O C A L D E C L: INTEGER I, SHIFT LOGICAL FIRST CHARACTER *1 CH C## S A V E: SAVE FIRST, SHIFT C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA FIRST/.TRUE./ C## E X E C U T I O N C## E X E C U T I O N IF (FIRST) THEN FIRST = .FALSE. SHIFT = ICHAR('A') - ICHAR('a') ENDIF I = 0 100 I = I + 1 IF ( I .LE. LEN(STRING) ) THEN IF ( TYPE .EQ. CTOUPP ) THEN IF ('a' .LE. STRING(I:I) .AND. STRING(I:I) .LE. 'z') THEN CH = CHAR( ICHAR(STRING(I:I)) + SHIFT ) ELSE CH = STRING(I:I) ENDIF ELSE IF ( TYPE .EQ. CTOLOW .OR. TYPE .EQ. CTOCAP ) THEN IF ('A' .LE. STRING(I:I) .AND. STRING(I:I) .LE. 'Z') THEN CH = CHAR( ICHAR(STRING(I:I)) - SHIFT ) ELSE CH = STRING(I:I) ENDIF ENDIF STRING(I:I) = CH GOTO 100 ENDIF IF ( TYPE .EQ. CTOCAP .and. - 'a' .LE. STRING(1:1) .AND. STRING(1:1) .LE. 'z') THEN CH = CHAR( ICHAR(STRING(1:1)) + SHIFT ) STRING(1:1) = CH ENDIF C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF TOUPPR. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> datesg.brk SUBROUTINE ZZdate (CHDATE) C## A R G U M E N T S: CHARACTER *(*) CHDATE C## S T A T U S: C SINGLE/DOUBLE Conversion: NOT required. C SYSTEM DEPENDENCE: System routine for date. C C THIS VERSION IS FOR VAX/BERK4.2(3) C C>RCS $Header: date.gl,v 2.1 91/11/22 11:45:18 buckley Exp $ C>RCS $Log: date.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:18 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/05 12:50:05 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9 89/06/30 13:30:12 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:26 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:12:13 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:33:41 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:30 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C THIS ROUTINE MUST CALL A SYSTEM ROUTINE TO GET THE CURRENT DATE. C ZZDATE MUST RETURN THIS DATE IN THE CHARACTER VARIABLE CHDATE C IN THE FORM C C (YY+MM+DD) C C AS REQUIRED BY THE ROUTINE ZZDTTM. CHDATE MUST OF LENGTH 10. C ONLY THE 6 CHARACTERS YY MM DD ARE ACTUALLY USED. THE OTHERS C CAN BE ANYTHING, I.E. ONLY THE POSITION OF THE YY MM DD MATTERS. C C THIS MUST CALL A SYSTEM ROUTINE TO GET THE DATE. C TO IMPLEMENT THIS ON ANOTHER SYSTEM, ONE MAY EITHER C C (A) INCORPORATE AN ALTERNATE VERSION OF ZZDATE; C C (B) USE THE "DUMMY" VERSION OF THIS ROUTINE WITH THE SINGLE C EXECUTABLE STATEMENT CHDATE='( + + )', IN WHICH CASE NO C DATE INFORMATION WILL APPEAR IN THE OUTPUT. C## E N T R Y P O I N T S: The natural entry ZZdate. C## S U B R O U T I N E S: System date routine. C## P A R A M E T E R S: INTEGER CTOUPP, CTOLOW, CTOCAP PARAMETER ( CTOUPP = 1, CTOLOW = 2, CTOCAP = 3 ) C## L O C A L D E C L: CHARACTER * 24 UNXDAT CHARACTER * 3 NAME (12), TEMP INTEGER I C## S A V E: SAVE NAME C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C## D A T A: DATA NAME /'JAN','FEB','MAR','APR','MAY','JUN', - 'JUL','AUG','SEP','OCT','NOV','DEC' / C## E X E C U T I O N C## E X E C U T I O N C---- INITIALIZE CHDATE CHDATE = '( + + )' CALL FDATE(UNXDAT) CHDATE(2:3) = UNXDAT(23:24) CHDATE(8:9) = UNXDAT(9:10) TEMP = UNXDAT(5:7) CALL ZZCASE(TEMP, CTOUPP) DO 100 I = 1,12 IF ( TEMP .EQ. NAME(I) ) THEN WRITE ( CHDATE(5:6), '(I2.2)' ) I GOTO 90000 ENDIF 100 CONTINUE C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZdate. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> mparsg.brk REAL FUNCTION ZZMPAR(I) C!!!! DOUBLE PRECISION FUNCTION ZZMPAR(I) C## A R G U M E N T S: INTEGER I C## S T A T U S: C IGNORE LINES BEGINNING WITH "C!!!!" . C C SYSTEM DEPENDENCE: THE CODE IS VERY DEFINITELY MACHINE DEPENDENT C FOR IT CONTAINS MACHINE PRECISION CONSTANTS C FOR MANY MACHINES, AS DESCRIBED BELOW. C C SINGLE/DOUBLE Conversion: NEEDED (SEE CONVRT). C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C>RCS $Header: mpar.gl,v 2.3 91/11/22 11:45:19 buckley Exp $ C>RCS $Log: mpar.gl,v $ C>RCS Revision 2.3 91/11/22 11:45:19 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.2 91/06/12 14:07:08 buckley C>RCS Added stardent C>RCS C>RCS Revision 2.1 90/07/31 10:57:40 buckley C>RCS Added constants for ieee for pc's C>RCS C>RCS Revision 2.0 90/07/06 10:39:26 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9.1.2 90/06/26 14:24:24 buckley C>RCS Fixed single/double precision constants for sun4 C>RCS C>RCS Revision 1.9.1.1 89/07/01 11:36:48 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.9 89/06/30 13:30:15 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:28 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:23 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:34:59 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:31 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C C THIS IS A MODIFICATION OF THE TWO ROUTINES DPMPAR AND SPMPAR C OBTAINED FROM JORGE MORE. IT HAS BEEN CHANGED ONLY TO CONFORM C WITH MY CONVENTIONS, AND TO ADD STATEMENTS FOR THE CDC C CYBERS WHICH ARE ACCEPTABLE TO FTN5 (FORTRAN '77). THE C OTHER CHANGES ARE: C C 1. THE SINGLE NAME ZZMPAR HAS BEEN USED. IT IS DOUBLE OR SINGLE C PRECISION ACCORDING TO CONVERSION BY CONVRT, JUST AS FOR ALL C OF MY OTHER PROGRAMS. C C 2. THE ROUTINES HAVE BEEN MERGED SO THAT SINGLE AND DOUBLE C PRECISION STATEMENTS WHICH CORRESPOND APPEAR IN PAIRS. C C OTHERWISE ALL OF THE COMMENTS OF THE ORIGINAL AUTHORS APPLY. C THEIR ORIGINAL COMMENTS (UNALTERED) FOR THE DOUBLE PRECISION C VERSION FOLLOW IMMEDIATELY. C C FUNCTION DPMPAR C C THIS FUNCTION PROVIDES DOUBLE PRECISION MACHINE PARAMETERS C WHEN THE APPROPRIATE SET OF DATA STATEMENTS IS ACTIVATED (BY C REMOVING THE C FROM COLUMN 1) AND ALL OTHER DATA STATEMENTS ARE C RENDERED INACTIVE. MOST OF THE PARAMETER VALUES WERE OBTAINED C FROM THE CORRESPONDING BELL LABORATORIES PORT LIBRARY FUNCTION. C C THE FUNCTION STATEMENT IS C C DOUBLE PRECISION FUNCTION DPMPAR(I) C C WHERE C C I IS AN INTEGER INPUT VARIABLE SET TO 1, 2, OR 3 WHICH C SELECTS THE DESIRED MACHINE PARAMETER. IF THE MACHINE HAS C T BASE B DIGITS AND ITS SMALLEST AND LARGEST EXPONENTS ARE C EMIN AND EMAX, RESPECTIVELY, THEN THESE PARAMETERS ARE C C DPMPAR(1) B**(1 - T), THE MACHINE PRECISION, C C DPMPAR(2) B**(EMIN - 1), THE SMALLEST MAGNITUDE, C C DPMPAR(3) B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE C C## E N T R Y P O I N T S: The natural entry ZZmpar. C## S U B R O U T I N E S: NONE are called. C## P A R A M E T E R S: NONE are defined. C C## L O C A L D E C L: C NOTE THAT THESE ARRAYS MUST HAVE DIMENSIONS 2 AND 4, RATHER C THAN 1 AND 2 AS ONE MIGHT EXPECT, BECAUSE OF THE PDP-11 C DEFINITIONS. INTEGER MCHEPS(2) C!!!! INTEGER MCHEPS(4) INTEGER MINMAG(2) C!!!! INTEGER MINMAG(4) INTEGER MAXMAG(2) C!!!! INTEGER MAXMAG(4) REAL RMACH(3) C!!!! DOUBLE PRECISION DMACH(3) INTEGER EMIN, EMAX, IMACH(10) REAL B, BINV, BM1, ONE, W, Z C!!!! DOUBLE PRECISION B, BINV, BM1, ONE, W, Z C## S A V E: SAVE RMACH C!!!! SAVE DMACH SAVE IMACH C## E Q U I V A L E N C E S: EQUIVALENCE (RMACH(1),MCHEPS(1)) C!!!! EQUIVALENCE (DMACH(1),MCHEPS(1)) EQUIVALENCE (RMACH(2),MINMAG(1)) C!!!! EQUIVALENCE (DMACH(2),MINMAG(1)) EQUIVALENCE (RMACH(3),MAXMAG(1)) C!!!! EQUIVALENCE (DMACH(3),MAXMAG(1)) C## C O M M O N: NONE is defined. C## D A T A: C-----MACHINE CONSTANTS FOR THE VAX-11. DATA MCHEPS(1) / 13568 / C!!!! DATA MCHEPS(1),MCHEPS(2) / 9472, 0 / DATA MINMAG(1) / 128 / C!!!! DATA MINMAG(1),MINMAG(2) / 128, 0 / DATA MAXMAG(1) / -32769 / C!!!! DATA MAXMAG(1),MAXMAG(2) / -32769, -1 / C## E X E C U T I O N C## E X E C U T I O N ZZMPAR = RMACH(I) C!!!! ZZMPAR = DMACH(I) C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZmpar. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> opensg.brk SUBROUTINE ZZOPEN ( IUNIT, FLAG, INAME, * , RECLEN ) C## A R G U M E N T S: INTEGER IUNIT, RECLEN LOGICAL FLAG CHARACTER *(*) INAME C## S T A T U S: C IGNORE LINES BEGINNING WITH "C!!!!" . C C SINGLE/DOUBLE Conversion: NEEDED (SEE CONVRT). C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR C OPENING AND CLOSING FILES. C C THIS VERSION IS FOR VAX/BERK4.2(3) C C>RCS $Header: open.gl,v 2.1 91/11/22 11:45:21 buckley Exp $ C>RCS $Log: open.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:21 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/06 10:43:19 buckley C>RCS Common version for TOMS and MT C>RCS C>RCS Revision 1.9.1.2 89/07/01 11:51:41 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.9.1.1 89/07/01 11:36:50 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.9 89/06/30 13:30:16 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:29 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:26 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:02 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:31 buckley C>RCS Initial revision C>RCS C## D E S C R I P T I O N: C C THIS OPENS THE FILES NEEDED FOR TESTPACK AND KEEPS TRACK OF C WHICH ARE OPEN AND WHICH ARE NOT. IT ALSO SUPPLIES THE APPRO- C PRIATE ARGUMENTS FOR EACH FILE. C C IF NAME IS NOT BLANK ON ENTRY, THEN THE FILE IS OPENED C WITH THE NAME GIVEN. OTHERWISE, NO NAME IS SPECIFIED WHEN C OPENING THE FILE. C C THE OPEN IS ONLY DONE IF "FLAG" IS TRUE. C C IF RECLEN IS NOT EQUAL TO ZERO, THEN THE FILE IS OPENED C AS DIRECT ACCESS UNFORMATTED. C C IF RECLEN IS EQUAL TO ZERO, THEN THE FILE IS OPENED C FOR FORMATTED SEQUENTIAL ACCESS. C C## E N T R Y P O I N T S: The natural entry ZZopen and ZZclse C## S U B R O U T I N E S: OPEN, CLOSE, REAL ...INTRINSIC C ZZERRM ...FOR ERROR MESSAGES. C## P A R A M E T E R S: INTEGER FILENL, NFILES PARAMETER ( FILENL = 80, NFILES = 15 ) CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) CHARACTER*(*) PERIOD, COMMA, SEMICN PARAMETER ( PERIOD = '.', COMMA = ',', SEMICN = ';' ) CHARACTER*(*) COLON, DASH, EQUALS PARAMETER ( COLON = ':', DASH = '-', EQUALS = '=' ) CHARACTER*(*) OBRACE, CBRACE, UNDERS PARAMETER ( OBRACE = '{', CBRACE = '}', UNDERS = '_' ) CHARACTER*(*) PLUS, MINUS, EXCLAM PARAMETER ( PLUS = '+', MINUS = '-', EXCLAM = '!' ) CHARACTER*(*) GTHAN, LTHAN, QUESMK PARAMETER ( GTHAN = '>', LTHAN = '<', QUESMK = '?' ) CHARACTER*(*) SLASH, BSLASH, PERCNT PARAMETER ( SLASH = '/', BSLASH = '\\',PERCNT = '%' ) CHARACTER*(*) CARAT, ATSIGN, TILDE PARAMETER ( CARAT = '^', ATSIGN = '@', TILDE = '~' ) LOGICAL T, F PARAMETER ( T = .TRUE., F = .FALSE. ) CHARACTER*(*) TRUE, QT, FALSE, QF PARAMETER ( TRUE = 'TRUE', QT = 'T', FALSE = 'FALSE', QF = 'F' ) INTEGER ITRUE, IFALSE PARAMETER ( ITRUE = 1, IFALSE = 0 ) REAL RTRUE, RFALSE C!!!! DOUBLE PRECISION RTRUE, RFALSE PARAMETER ( RTRUE = 1.D0, RFALSE = 0.D0 ) INTEGER CTOUPP, CTOLOW, CTOCAP PARAMETER ( CTOUPP = 1, CTOLOW = 2, CTOCAP = 3 ) INTEGER PREPRC, DAUF, INPTUN PARAMETER ( PREPRC = 1, DAUF = 2, INPTUN = 3 ) INTEGER TEMPUN, STDIN, TRMOUT PARAMETER ( TEMPUN = 4, STDIN = 5, TRMOUT = 6 ) INTEGER WRITUN, TRACUN, SUMMUN PARAMETER ( WRITUN = 7, TRACUN = 8, SUMMUN = 9 ) INTEGER COPYUN, TEXUN PARAMETER ( COPYUN =10, TEXUN =11 ) CHARACTER *(*) SEQ , DIR PARAMETER ( SEQ = 'SEQUENTIAL', DIR = 'DIRECT' ) CHARACTER *(*) UNKN , NEW PARAMETER ( UNKN = 'UNKNOWN' , NEW = 'NEW' ) CHARACTER *(*) OLD , SCR PARAMETER ( OLD = 'OLD' , SCR = 'SCRATCH' ) CHARACTER *(*) DEL , KEEP PARAMETER ( DEL = 'DELETE' , KEEP = 'KEEP' ) CHARACTER *(*) FMT , UNFRMT PARAMETER ( FMT = 'FORMATTED' , UNFRMT = 'UNFORMATTED' ) C## L O C A L D E C L: INTEGER ERRINT, UNIT LOGICAL OPENFS(NFILES), REW, OPENIT, COPY CHARACTER STAT*7, ACCS*10, FRMT*11 CHARACTER *(FILENL) COPYNM, NAME REAL RD C!!!! DOUBLE PRECISION RD C## S A V E: SAVE OPENFS, COPY, COPYNM C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA OPENFS / NFILES * .FALSE. / DATA COPY/F/, COPYNM/BLANK/ C## E X E C U T I O N C## E X E C U T I O N C----- DEFINE A STATEMENT FUNCTION. RD(UNIT) = REAL(UNIT) C!!!! RD(UNIT) = DBLE(UNIT) IF ( FLAG ) THEN IF ( RECLEN .EQ. 0 ) THEN ACCS = SEQ FRMT = FMT ELSE ACCS = DIR FRMT = UNFRMT ENDIF UNIT = IUNIT NAME = INAME 100 CONTINUE OPENIT = .NOT. OPENFS(UNIT) REW = .FALSE. IF ( UNIT .EQ. SUMMUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. TRMOUT ) THEN OPENIT = .FALSE. ELSE IF ( UNIT .EQ. STDIN ) THEN OPENIT = .FALSE. ELSE IF ( UNIT .EQ. PREPRC) THEN STAT = OLD REW = .TRUE. ELSE IF ( UNIT .EQ. TEMPUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. WRITUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. TRACUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. DAUF ) THEN STAT = OLD ELSE IF ( UNIT .EQ. COPYUN ) THEN STAT = UNKN COPY = T ELSE IF ( UNIT .EQ. INPTUN ) THEN STAT = OLD REW = .TRUE. ELSE CALL ZZERRM ( RD(UNIT), *91000, - 'IS REQUEST TO OPEN UNKNOWN UNIT # ' ) ENDIF C FOR THE "CHOICE OF UNIT..." 500 IF ( OPENIT ) THEN CALL ZZCASE ( STAT, CTOLOW ) CALL ZZCASE ( ACCS, CTOLOW ) CALL ZZCASE ( FRMT, CTOLOW ) IF ( NAME .EQ. BLANK ) THEN C PRINT*,'OPENING ',UNIT,'NAME=' IF ( RECLEN .EQ. 0 ) THEN OPEN ( UNIT = UNIT, - ERR = 1000, - IOSTAT = ERRINT, - STATUS = STAT, - ACCESS = ACCS, - FORM = FRMT ) ELSE OPEN ( UNIT = UNIT, - ERR = 1000, - IOSTAT = ERRINT, - STATUS = STAT, - ACCESS = ACCS, - RECL = RECLEN, - FORM = FRMT ) ENDIF ELSE C NAMED FILE IF ( RECLEN .EQ. 0 ) THEN C PRINT*,'OPENING ',UNIT,'NAME=',NAME(1:20) OPEN ( UNIT = UNIT, - ERR = 1000, - IOSTAT = ERRINT, - FILE = NAME, - STATUS = STAT, - ACCESS = ACCS, - FORM = FRMT ) C PRINT*,'OK' ELSE OPEN ( UNIT = UNIT, - ERR = 1000, - FILE = NAME, - IOSTAT = ERRINT, - STATUS = STAT, - ACCESS = ACCS, - RECL = RECLEN, - FORM = FRMT ) ENDIF ENDIF ENDIF C FOR EACH UNIT FROM 1 TO NFILES WE NEED TO KEEP A RECORD OF C WHETHER IT IS CURRENTLY OPEN. OPENFS(UNIT) = .TRUE. IF ( REW .AND. RECLEN .EQ. 0 ) THEN REWIND UNIT ENDIF GOTO 1025 1000 IF ( UNIT .EQ. DAUF ) THEN C CREATE THE DAUF. STAT = NEW GOTO 500 ELSE GOTO 1050 ENDIF 1025 CONTINUE IF ( COPY .AND. UNIT .EQ. STDIN ) THEN UNIT = COPYUN NAME = COPYNM GOTO 100 ENDIF ENDIF C FOR THE "IF FLAG..." GOTO 90000 1050 CONTINUE GOTO 91000 C## E N T R Y ZZCLSE: ENTRY ZZCLSE ( IUNIT, * ) STAT = KEEP IF ( IUNIT .EQ. SUMMUN ) THEN STAT = KEEP ELSE IF ( IUNIT .EQ. TRMOUT ) THEN OPENFS(TRMOUT) = .FALSE. ELSE IF ( IUNIT .EQ. STDIN ) THEN OPENFS(STDIN ) = .FALSE. ELSE IF ( IUNIT .EQ. TEMPUN ) THEN STAT = KEEP ELSE IF ( IUNIT .EQ. WRITUN ) THEN ELSE IF ( IUNIT .EQ. TRACUN ) THEN ELSE IF ( IUNIT .EQ. COPYUN ) THEN STAT = KEEP COPY = F ELSE IF ( IUNIT .EQ. DAUF ) THEN ELSE IF ( IUNIT .EQ. PREPRC ) THEN ELSE IF ( IUNIT .EQ. INPTUN ) THEN ELSE CALL ZZERRM ( RD(IUNIT), *91000, - 'IS IGNORING REQUEST TO CLOSE UNKNOWN UNIT #' ) ENDIF IF ( OPENFS(IUNIT) ) THEN CALL ZZCASE ( STAT, CTOLOW ) C PRINT*,'CLOSING ',IUNIT CLOSE ( UNIT = IUNIT, STATUS = STAT ) OPENFS(IUNIT) = .FALSE. ENDIF RETURN C## E X I T 90000 CONTINUE CALL ZZCASE (STAT,CTOUPP) IF ( IUNIT .EQ. DAUF .AND. STAT .EQ. NEW ) THEN GOTO 91000 ELSE RETURN ENDIF 91000 RETURN 1 C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZOPEN. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> reclsg.brk INTEGER FUNCTION ZZRECL ( CPERLN, IPERLN, LPERLN, RPERLN ) C## A R G U M E N T S: INTEGER CPERLN, IPERLN, LPERLN, RPERLN C## S T A T U S: C SINGLE/DOUBLE Conversion: Needed (See CONVRT). C C Ignore lines beginning with "C!!!!" . C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C System Dependence: System routine for direct C access unformatted record length C C THIS VERSION IS FOR VAX/BERK4.2(3) C C>RCS $Header: recl.gl,v 2.1 91/11/22 11:45:23 buckley Exp $ C>RCS $Log: recl.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:23 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/16 14:39:15 buckley C>RCS Added Lahey C>RCS C>RCS Revision 1.9 89/06/30 13:30:18 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:30 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:29 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:07 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:32 buckley C>RCS Initial revision C>RCS C## D E S C R I P T I O N: C C THIS ROUTINE USES FOUR INTEGER CONSTANTS NEEDED TO DETERMINE C THE LENGTH OF AN UNFORMATTED RECORD FOR READING AND WRITING C DIRECT ACCESS FILES. THE PROCESSOR IS ASSUMED, ACCORDING C TO THE FORTRAN STANDARD, TO WRITE UNFORMATTED RECORDS C IN "PROCESSOR DEFINED UNITS", I.E. IN PDU'S. C C HERE WE MUST DEFINE FOUR CONSTANTS: C C CHARS THE NUMBER OF PDU'S NEEDED TO WRITE ONE CHARACTER; C INTS THE NUMBER OF PDU'S NEEDED TO WRITE ONE INTEGER VALUE; C LOGS THE NUMBER OF PDU'S NEEDED TO WRITE ONE LOGICAL VALUE; C REALS THE NUMBER OF PDU'S NEEDED TO WRITE ONE REAL(DP) VALUE. C C NOTE THAT IT MAY HAPPEN (PARTICULARLY WITH CHARACTER OR LOGICAL C DATA) THAT SEVERAL VALUES MAY FIT INTO ONE PDU. IN THIS CASE, SET C THE CONSTANT TO A NEGATIVE VALUE. FOR EXAMPLE, ON A CYBER, A PDU C IS ONE WORD AND 10 CHARACTERS FIT PER WORD. IN THIS CASE, CHARS C IS SET TO -10. BUT ON A VAX, A PDU IS ONE BYTE AND AN INTEGER C OCCUPIES 4 BYTES, SO INTS IS SET TO 4. NOTE THAT THE VALUES FOR C 'REALS' WILL GENERALLY BE DIFFERENT FOR THE SINGLE AND DOUBLE C PRECISION VERSIONS ON THE SAME MACHINE. C C ON ENTRY, THE FOUR ARGUMENTS INDICATE HOW MANY VALUES OF EACH OF C THE FOUR BASIC TYPES ARE REQUIRED TO FIT IN ONE DIRECT ACCESS C UNFORMATTED RECORD. THIS ROUTINE WILL DETERMINE THE MINIMUM RECORD C LENGTH NEEDED TO SATISFY ALL FOUR REQUIREMENTS. THAT VALUE WILL BE C RETURNED AS THE VALUE OF THE FUNCTION ZZRECL. C C IT WILL THEN *RETURN* IN EACH OF THE FOUR ARGUMENTS THE *ACTUAL* C NUMBER OF EACH OF THESE WHICH CAN FIT IN THE RECORD OF THE SIZE C DETERMINED. C C N.B. **** THIS ROUTINE ASSUMES *NO MIXING* OF DATA TYPES ON C ANY ONE RECORD WHEN USING DIRECT ACCESS UNFORMATTED I/O. C THUS EACH TIME A RECORD IS WRITTEN, IT CONTAINS *ONLY* C CHARACTER DATA, OR *ONLY* INTEGER DATA, OR *ONLY* REAL C DATA, OR *ONLY* LOGICAL DATA. ANY MIXING WOULD C TOTALLY DESTROY ANY HOPE OF PORTABILITY TO SOME SYSTEMS. C C## E N T R Y P O I N T S: The natural entry ZZRECL. C## S U B R O U T I N E S: ABS, MAX ... INTRINSIC C C## P A R A M E T E R S: INTEGER CHARS, INTS, LOGS, REALS PARAMETER ( CHARS = 1, INTS = 4, LOGS = 4, REALS = 4 ) C!!!! PARAMETER ( CHARS = 1, INTS = 4, LOGS = 4, REALS = 8 ) C## L O C A L D E C L: INTEGER N C## S A V E: NONE selected. C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C## D A T A: NONE are set. C## E X E C U T I O N C## E X E C U T I O N ZZRECL = 1 IF ( CHARS .LT. 0 ) THEN N = ABS(CHARS) N = ( CPERLN + N - 1 ) / N ELSE N = CPERLN * CHARS ENDIF ZZRECL = MAX ( ZZRECL, N ) IF ( INTS .LT. 0 ) THEN N = ABS(INTS) N = ( IPERLN + N - 1 ) / N ELSE N = IPERLN * INTS ENDIF ZZRECL = MAX ( ZZRECL, N ) IF ( LOGS .LT. 0 ) THEN N = ABS(LOGS) N = ( LPERLN + N - 1 ) / N ELSE N = LPERLN * LOGS ENDIF ZZRECL = MAX ( ZZRECL, N ) IF ( REALS .LT. 0 ) THEN N = ABS(REALS) N = ( RPERLN + N - 1 ) / N ELSE N = RPERLN * REALS ENDIF ZZRECL = MAX ( ZZRECL, N ) C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZRECL. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> secssg.brk SUBROUTINE ZZSECS(SECS) C## A R G U M E N T S: REAL SECS C!!!! DOUBLE PRECISION SECS C## S T A T U S: C SINGLE/DOUBLE Conversion: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C SYSTEM DEPENDENCE: System routine for CPU usage. C This version is for VAX/BERK4.2(3) C C>RCS $Header: secs.gl,v 2.1 91/11/22 11:45:25 buckley Exp $ C>RCS $Log: secs.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:25 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/06 10:48:10 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9 89/06/30 13:30:19 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:31 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:31 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:12 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:33 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C THIS SUBROUTINE SHOULD OBTAIN (FROM THE OPERATING SYSTEM) THE C AMOUNT OF CPU TIME USED BY THE CALLING PROGRAM SINCE THE C EXECUTION BEGAN. IF DESIRABLE, "SECS" CAN ALSO BE CONVERTED C TO DOUBLE PRECISION (SEE CONVRT). HOWEVER, THE ROUTINE ACTUALLY C WORKS TOTALLY AS A SINGLE PRECISION ROUTINE, EXCEPT THAT THE C VALUE WHICH IS PASSED BACK MAY BE IN EITHER PRECISION AS C APPROPRIATE. C TIME IS MEASURED FROM THE FIRST CALL TO ZZSECS. THUS C ON THE FIRST CALL TO ZZSECS, A TIME OF 0.0 SECONDS IS ALWAYS C RETURNED. C## E N T R Y P O I N T S: The natural entry ZZSECS. C## S U B R O U T I N E S: A SYSTEM CLOCK. C## P A R A M E T E R S: REAL ZERO PARAMETER ( ZERO = 0.0E0 ) C## L O C A L D E C L: LOGICAL FIRST REAL ETIME, DUMMY(2) REAL STTIME, SEC C## S A V E: SAVE FIRST, STTIME C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C## D A T A: DATA FIRST/.TRUE./ C## E X E C U T I O N C## E X E C U T I O N IF ( FIRST ) THEN FIRST = .FALSE. STTIME = ETIME(DUMMY) SEC = ZERO ELSE SEC = ETIME(DUMMY) - STTIME ENDIF SECS = SEC C!!!! SECS = DBLE(SEC) C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZSECS. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> timesg.brk SUBROUTINE ZZTIME ( CHTIME ) C## A R G U M E N T S: CHARACTER *(*) CHTIME C## S T A T U S: C SINGLE/DOUBLE Conversion: NOT required. C C System Dependence: System routine for Time. C C THIS VERSION IS FOR VAX/BERK4.2(3) C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C>RCS $Header: time.gl,v 2.1 91/11/22 11:45:26 buckley Exp $ C>RCS $Log: time.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:26 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/06 10:52:37 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9 89/06/30 13:30:20 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:32 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:33 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:16 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:33 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE MUST CALL A SYSTEM ROUTINE TO GET THE CURRENT TIME. C IT MUST RETURN THIS TIME IN THE CHARACTER VARIABLE CHTIME C IN THE FORM C C (HH+MM+SS) C C AS REQUIRED BY THE ROUTINE ZZDTTM. CHTIME MUST BE OF LENGTH 10. C ONLY THE SIX CHARACTERS HH MM SS ARE ACTUALLY USED. THE OTHERS C CAN BE ANYTHING, BUT THE HH, MM AND SS MUST BE IN THE CORRECT C POSITION. HH SHOULD BE BETWEEN 0 AND 23, I.E. BASED ON THE 24 HOUR C CLOCK. OF COURSE MM AND SS MUST BE IN THE RANGE 0 TO 59. C C THIS VERSION CALLS A SYSTEM DEPENDENT ROUTINE. C TO IMPLEMENT THIS ON ANOTHER SYSTEM, ONE MAY EITHER C C (A) INCORPORATE AN ALTERNATE VERSION OF ZZTIME; C C (B) USE THE "DUMMY" VERSION OF THIS ROUTINE WITH THE SINGLE C EXECUTABLE STATEMENT CHTIME=' ', IN WHICH CASE NO C TIME INFORMATION WILL APPEAR IN THE OUTPUT. C C## E N T R Y P O I N T S: The natural entry ZZTIME. C## S U B R O U T I N E S: SYSTEM ROUTINE TO GET TIME OF DAY. C## P A R A M E T E R S: NONE are defined. C## L O C A L D E C L: CHARACTER * 24 UNXTIM C## S A V E: NONE selected. C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C## D A T A: NONE are set. C## E X E C U T I O N C## E X E C U T I O N CALL FDATE (UNXTIM) CHTIME(2:9) = UNXTIM(12:19) C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZTIME. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> casesg.f7l SUBROUTINE ZZCASE (STRING, TYPE ) C## A R G U M E N T S: CHARACTER *(*) STRING INTEGER TYPE C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NOT REQUIRED. C C SYSTEM DEPENDENCE: SYSTEM ROUTINE FOR CASE C CONVERSION OF LETTERS. C C THIS VERSION IS FOR LAHEY'S F77L FOR PC'S C>RCS $HEADER: CASE.GL,V 2.0 90/07/05 12:44:20 BUCKLEY EXP $ C>RCS $LOG: CASE.GL,V $ C>RCS REVISION 2.0 90/07/05 12:44:20 BUCKLEY C>RCS COMMON VERSION FOR TOMS AND GL C>RCS C>RCS REVISION 1.9.1.1 89/06/30 14:59:19 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.9 89/06/30 13:30:11 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 16:07:53 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/20 13:48:39 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C## D E S C R I P T I O N: C THIS CONVERTS EACH LOWER CASE ALPHABETIC LETTER TO C UPPER CASE, OR VICE VERSA. C IF TYPE = CTOUPP, CONVERSION IS LOWER TO UPPER C IF TYPE = CTOLOW, CONVERSION IS UPPER TO LOWER C IF TYPE = CTOCAP, USE UPPER FOR FIRST LETTER; LOWER FOR REST C ALL OTHER CHARACTERS ARE LEFT UNCHANGED. C## E N T R Y P O I N T S: THE NATURAL ENTRY TTOUPPR. C## S U B R O U T I N E S: LEN (INTRINSIC). C## P A R A M E T E R S: INTEGER CTOUPP, CTOLOW, CTOCAP PARAMETER ( CTOUPP = 1, CTOLOW = 2, CTOCAP = 3 ) CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) CHARACTER*(*) PERIOD, COMMA, SEMICN PARAMETER ( PERIOD = '.', COMMA = ',', SEMICN = ';' ) CHARACTER*(*) COLON, DASH, EQUALS PARAMETER ( COLON = ':', DASH = '-', EQUALS = '=' ) CHARACTER*(*) OBRACE, CBRACE, UNDERS PARAMETER ( OBRACE = '{', CBRACE = '}', UNDERS = '_' ) CHARACTER*(*) PLUS, MINUS, EXCLAM PARAMETER ( PLUS = '+', MINUS = '-', EXCLAM = '!' ) CHARACTER*(*) GTHAN, LTHAN, QUESMK PARAMETER ( GTHAN = '>', LTHAN = '<', QUESMK = '?' ) CHARACTER*(*) SLASH, BSLASH, PERCNT PARAMETER ( SLASH = '/', BSLASH = '\\',PERCNT = '%' ) CHARACTER*(*) CARAT, ATSIGN, TILDE PARAMETER ( CARAT = '^', ATSIGN = '@', TILDE = '~' ) C## L O C A L D E C L: INTEGER I, SHIFT LOGICAL FIRST CHARACTER *1 CH C## S A V E: SAVE FIRST, SHIFT C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA FIRST/.TRUE./ C## E X E C U T I O N C## E X E C U T I O N IF (FIRST) THEN FIRST = .FALSE. SHIFT = ICHAR('A') - ICHAR('a') ENDIF I = 0 100 I = I + 1 IF ( I .LE. LEN(STRING) ) THEN IF ( TYPE .EQ. CTOUPP ) THEN IF ('a' .LE. STRING(I:I) .AND. STRING(I:I) .LE. 'z') THEN CH = CHAR( ICHAR(STRING(I:I)) + SHIFT ) ELSE CH = STRING(I:I) ENDIF ELSE IF ( TYPE .EQ. CTOLOW .OR. TYPE .EQ. CTOCAP ) THEN IF ('A' .LE. STRING(I:I) .AND. STRING(I:I) .LE. 'Z') THEN CH = CHAR( ICHAR(STRING(I:I)) - SHIFT ) ELSE CH = STRING(I:I) ENDIF ENDIF STRING(I:I) = CH GOTO 100 ENDIF IF ( TYPE .EQ. CTOCAP .and. - 'a' .LE. STRING(1:1) .AND. STRING(1:1) .LE. 'z') THEN CH = CHAR( ICHAR(STRING(1:1)) + SHIFT ) STRING(1:1) = CH ENDIF C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF TOUPPR. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> datesg.f7l SUBROUTINE ZZdate (CHDATE) C## A R G U M E N T S: CHARACTER *(*) CHDATE C## S T A T U S: C SINGLE/DOUBLE Conversion: NOT required. C SYSTEM DEPENDENCE: System routine for date. C C THIS VERSION IS FOR Lahey's F77L for PC's C C>RCS $Header: date.gl,v 2.1 91/11/22 11:45:18 buckley Exp $ C>RCS $Log: date.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:18 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/05 12:50:05 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9 89/06/30 13:30:12 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:26 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:12:13 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:33:41 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:30 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C THIS ROUTINE MUST CALL A SYSTEM ROUTINE TO GET THE CURRENT DATE. C ZZDATE MUST RETURN THIS DATE IN THE CHARACTER VARIABLE CHDATE C IN THE FORM C C (YY+MM+DD) C C AS REQUIRED BY THE ROUTINE ZZDTTM. CHDATE MUST OF LENGTH 10. C ONLY THE 6 CHARACTERS YY MM DD ARE ACTUALLY USED. THE OTHERS C CAN BE ANYTHING, I.E. ONLY THE POSITION OF THE YY MM DD MATTERS. C C THIS MUST CALL A SYSTEM ROUTINE TO GET THE DATE. C TO IMPLEMENT THIS ON ANOTHER SYSTEM, ONE MAY EITHER C C (A) INCORPORATE AN ALTERNATE VERSION OF ZZDATE; C C (B) USE THE "DUMMY" VERSION OF THIS ROUTINE WITH THE SINGLE C EXECUTABLE STATEMENT CHDATE='( + + )', IN WHICH CASE NO C DATE INFORMATION WILL APPEAR IN THE OUTPUT. C## E N T R Y P O I N T S: The natural entry ZZdate. C## S U B R O U T I N E S: System date routine. C## P A R A M E T E R S: NONE are defined. C## L O C A L D E C L: CHARACTER * 8 TODAY C## S A V E: NONE selected. C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C## D A T A: NO DATA VALUES SET. C## E X E C U T I O N C## E X E C U T I O N C---- INITIALIZE CHDATE CHDATE = '( + + )' C Lahey's routine DATE returns an 8-character string containing C MM / DD / YY CALL DATE ( TODAY ) CHDATE(2:3) = TODAY(7:8) CHDATE(5:6) = TODAY(1:2) CHDATE(8:9) = TODAY(4:5) C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZdate. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> mparsg.f7l REAL FUNCTION ZZMPAR(I) C!!!! DOUBLE PRECISION FUNCTION ZZMPAR(I) C## A R G U M E N T S: INTEGER I C## S T A T U S: C IGNORE LINES BEGINNING WITH "C!!!!" . C C SYSTEM DEPENDENCE: THE CODE IS VERY DEFINITELY MACHINE DEPENDENT C FOR IT CONTAINS MACHINE PRECISION CONSTANTS C FOR MANY MACHINES, AS DESCRIBED BELOW. C C SINGLE/DOUBLE Conversion: NEEDED (SEE CONVRT). C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C>RCS $Header: mpar.gl,v 2.3 91/11/22 11:45:19 buckley Exp $ C>RCS $Log: mpar.gl,v $ C>RCS Revision 2.3 91/11/22 11:45:19 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.2 91/06/12 14:07:08 buckley C>RCS Added stardent C>RCS C>RCS Revision 2.1 90/07/31 10:57:40 buckley C>RCS Added constants for ieee for pc's C>RCS C>RCS Revision 2.0 90/07/06 10:39:26 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9.1.2 90/06/26 14:24:24 buckley C>RCS Fixed single/double precision constants for sun4 C>RCS C>RCS Revision 1.9.1.1 89/07/01 11:36:48 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.9 89/06/30 13:30:15 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:28 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:23 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:34:59 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:31 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C C THIS IS A MODIFICATION OF THE TWO ROUTINES DPMPAR AND SPMPAR C OBTAINED FROM JORGE MORE. IT HAS BEEN CHANGED ONLY TO CONFORM C WITH MY CONVENTIONS, AND TO ADD STATEMENTS FOR THE CDC C CYBERS WHICH ARE ACCEPTABLE TO FTN5 (FORTRAN '77). THE C OTHER CHANGES ARE: C C 1. THE SINGLE NAME ZZMPAR HAS BEEN USED. IT IS DOUBLE OR SINGLE C PRECISION ACCORDING TO CONVERSION BY CONVRT, JUST AS FOR ALL C OF MY OTHER PROGRAMS. C C 2. THE ROUTINES HAVE BEEN MERGED SO THAT SINGLE AND DOUBLE C PRECISION STATEMENTS WHICH CORRESPOND APPEAR IN PAIRS. C C OTHERWISE ALL OF THE COMMENTS OF THE ORIGINAL AUTHORS APPLY. C THEIR ORIGINAL COMMENTS (UNALTERED) FOR THE DOUBLE PRECISION C VERSION FOLLOW IMMEDIATELY. C C FUNCTION DPMPAR C C THIS FUNCTION PROVIDES DOUBLE PRECISION MACHINE PARAMETERS C WHEN THE APPROPRIATE SET OF DATA STATEMENTS IS ACTIVATED (BY C REMOVING THE C FROM COLUMN 1) AND ALL OTHER DATA STATEMENTS ARE C RENDERED INACTIVE. MOST OF THE PARAMETER VALUES WERE OBTAINED C FROM THE CORRESPONDING BELL LABORATORIES PORT LIBRARY FUNCTION. C C THE FUNCTION STATEMENT IS C C DOUBLE PRECISION FUNCTION DPMPAR(I) C C WHERE C C I IS AN INTEGER INPUT VARIABLE SET TO 1, 2, OR 3 WHICH C SELECTS THE DESIRED MACHINE PARAMETER. IF THE MACHINE HAS C T BASE B DIGITS AND ITS SMALLEST AND LARGEST EXPONENTS ARE C EMIN AND EMAX, RESPECTIVELY, THEN THESE PARAMETERS ARE C C DPMPAR(1) B**(1 - T), THE MACHINE PRECISION, C C DPMPAR(2) B**(EMIN - 1), THE SMALLEST MAGNITUDE, C C DPMPAR(3) B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE C C## E N T R Y P O I N T S: The natural entry ZZmpar. C## S U B R O U T I N E S: NONE are called. C## P A R A M E T E R S: NONE are defined. C C## L O C A L D E C L: C NOTE THAT THESE ARRAYS MUST HAVE DIMENSIONS 2 AND 4, RATHER C THAN 1 AND 2 AS ONE MIGHT EXPECT, BECAUSE OF THE PDP-11 C DEFINITIONS. INTEGER MCHEPS(2) C!!!! INTEGER MCHEPS(4) INTEGER MINMAG(2) C!!!! INTEGER MINMAG(4) INTEGER MAXMAG(2) C!!!! INTEGER MAXMAG(4) REAL RMACH(3) C!!!! DOUBLE PRECISION DMACH(3) INTEGER EMIN, EMAX, IMACH(10) REAL B, BINV, BM1, ONE, W, Z C!!!! DOUBLE PRECISION B, BINV, BM1, ONE, W, Z C## S A V E: SAVE RMACH C!!!! SAVE DMACH SAVE IMACH C## E Q U I V A L E N C E S: EQUIVALENCE (RMACH(1),MCHEPS(1)) C!!!! EQUIVALENCE (DMACH(1),MCHEPS(1)) EQUIVALENCE (RMACH(2),MINMAG(1)) C!!!! EQUIVALENCE (DMACH(2),MINMAG(1)) EQUIVALENCE (RMACH(3),MAXMAG(1)) C!!!! EQUIVALENCE (DMACH(3),MAXMAG(1)) C## C O M M O N: NONE is defined. C## D A T A: C-----MACHINE CONSTANTS FOR machines conforming to the IEEE standard C FOR IBM PC WITH Laheyf77l, Microsoft Fortran, Professional C Fortran, or Ryan MacFarland. DATA RMACH(1) /5.96045E-08 / C!!!! DATA DMACH(1) /1.11022302D-16 / DATA RMACH(2) /1.17549E-38/ C!!!! DATA DMACH(2) /2.23D-308/ DATA RMACH(3) /3.40282E+38 / C!!!! DATA DMACH(3) /1.79769313D+308 / C## E X E C U T I O N C## E X E C U T I O N ZZMPAR = RMACH(I) C!!!! ZZMPAR = DMACH(I) C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZmpar. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> opensg.f7l SUBROUTINE ZZOPEN ( IUNIT, FLAG, INAME, * , RECLEN ) C## A R G U M E N T S: INTEGER IUNIT, RECLEN LOGICAL FLAG CHARACTER *(*) INAME C## S T A T U S: C IGNORE LINES BEGINNING WITH "C!!!!" . C C SINGLE/DOUBLE Conversion: NEEDED (SEE CONVRT). C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR C OPENING AND CLOSING FILES. C C THIS VERSION IS FOR Lahey's F77L for PC's C C C>RCS $Header: open.gl,v 2.1 91/11/22 11:45:21 buckley Exp $ C>RCS $Log: open.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:21 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/06 10:43:19 buckley C>RCS Common version for TOMS and MT C>RCS C>RCS Revision 1.9.1.2 89/07/01 11:51:41 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.9.1.1 89/07/01 11:36:50 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.9 89/06/30 13:30:16 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:29 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:26 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:02 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:31 buckley C>RCS Initial revision C>RCS C## D E S C R I P T I O N: C C THIS OPENS THE FILES NEEDED FOR TESTPACK AND KEEPS TRACK OF C WHICH ARE OPEN AND WHICH ARE NOT. IT ALSO SUPPLIES THE APPRO- C PRIATE ARGUMENTS FOR EACH FILE. C C IF NAME IS NOT BLANK ON ENTRY, THEN THE FILE IS OPENED C WITH THE NAME GIVEN. OTHERWISE, NO NAME IS SPECIFIED WHEN C OPENING THE FILE. C C THE OPEN IS ONLY DONE IF "FLAG" IS TRUE. C C IF RECLEN IS NOT EQUAL TO ZERO, THEN THE FILE IS OPENED C AS DIRECT ACCESS UNFORMATTED. C C IF RECLEN IS EQUAL TO ZERO, THEN THE FILE IS OPENED C FOR FORMATTED SEQUENTIAL ACCESS. C C## E N T R Y P O I N T S: The natural entry ZZopen and ZZclse C## S U B R O U T I N E S: OPEN, CLOSE, REAL ...INTRINSIC C ZZERRM ...FOR ERROR MESSAGES. C## P A R A M E T E R S: INTEGER FILENL, NFILES PARAMETER ( FILENL = 80, NFILES = 15 ) CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) CHARACTER*(*) PERIOD, COMMA, SEMICN PARAMETER ( PERIOD = '.', COMMA = ',', SEMICN = ';' ) CHARACTER*(*) COLON, DASH, EQUALS PARAMETER ( COLON = ':', DASH = '-', EQUALS = '=' ) CHARACTER*(*) OBRACE, CBRACE, UNDERS PARAMETER ( OBRACE = '{', CBRACE = '}', UNDERS = '_' ) CHARACTER*(*) PLUS, MINUS, EXCLAM PARAMETER ( PLUS = '+', MINUS = '-', EXCLAM = '!' ) CHARACTER*(*) GTHAN, LTHAN, QUESMK PARAMETER ( GTHAN = '>', LTHAN = '<', QUESMK = '?' ) CHARACTER*(*) SLASH, BSLASH, PERCNT PARAMETER ( SLASH = '/', BSLASH = '\\',PERCNT = '%' ) CHARACTER*(*) CARAT, ATSIGN, TILDE PARAMETER ( CARAT = '^', ATSIGN = '@', TILDE = '~' ) LOGICAL T, F PARAMETER ( T = .TRUE., F = .FALSE. ) CHARACTER*(*) TRUE, QT, FALSE, QF PARAMETER ( TRUE = 'TRUE', QT = 'T', FALSE = 'FALSE', QF = 'F' ) INTEGER ITRUE, IFALSE PARAMETER ( ITRUE = 1, IFALSE = 0 ) REAL RTRUE, RFALSE C!!!! DOUBLE PRECISION RTRUE, RFALSE PARAMETER ( RTRUE = 1.D0, RFALSE = 0.D0 ) INTEGER CTOUPP, CTOLOW, CTOCAP PARAMETER ( CTOUPP = 1, CTOLOW = 2, CTOCAP = 3 ) INTEGER PREPRC, DAUF, INPTUN PARAMETER ( PREPRC = 1, DAUF = 2, INPTUN = 3 ) INTEGER TEMPUN, STDIN, TRMOUT PARAMETER ( TEMPUN = 4, STDIN = 5, TRMOUT = 6 ) INTEGER WRITUN, TRACUN, SUMMUN PARAMETER ( WRITUN = 7, TRACUN = 8, SUMMUN = 9 ) INTEGER COPYUN, TEXUN PARAMETER ( COPYUN =10, TEXUN =11 ) CHARACTER *(*) SEQ , DIR PARAMETER ( SEQ = 'SEQUENTIAL', DIR = 'DIRECT' ) CHARACTER *(*) UNKN , NEW PARAMETER ( UNKN = 'UNKNOWN' , NEW = 'NEW' ) CHARACTER *(*) OLD , SCR PARAMETER ( OLD = 'OLD' , SCR = 'SCRATCH' ) CHARACTER *(*) DEL , KEEP PARAMETER ( DEL = 'DELETE' , KEEP = 'KEEP' ) CHARACTER *(*) FMT , UNFRMT PARAMETER ( FMT = 'FORMATTED' , UNFRMT = 'UNFORMATTED' ) C## L O C A L D E C L: INTEGER ERRINT, UNIT LOGICAL OPENFS(NFILES), REW, OPENIT, COPY CHARACTER STAT*7, ACCS*10, FRMT*11 CHARACTER *(FILENL) COPYNM, NAME REAL RD C!!!! DOUBLE PRECISION RD C## S A V E: SAVE OPENFS, COPY, COPYNM C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA OPENFS / NFILES * .FALSE. / DATA COPY/F/, COPYNM/BLANK/ C## E X E C U T I O N C## E X E C U T I O N C----- DEFINE A STATEMENT FUNCTION. RD(UNIT) = REAL(UNIT) C!!!! RD(UNIT) = DBLE(UNIT) IF ( FLAG ) THEN IF ( RECLEN .EQ. 0 ) THEN ACCS = SEQ FRMT = FMT ELSE ACCS = DIR FRMT = UNFRMT ENDIF UNIT = IUNIT NAME = INAME 100 CONTINUE OPENIT = .NOT. OPENFS(UNIT) REW = .FALSE. IF ( UNIT .EQ. SUMMUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. TRMOUT ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. STDIN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. PREPRC) THEN STAT = OLD REW = .TRUE. ELSE IF ( UNIT .EQ. TEMPUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. WRITUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. TRACUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. DAUF ) THEN STAT = OLD ELSE IF ( UNIT .EQ. COPYUN ) THEN STAT = UNKN COPY = T ELSE IF ( UNIT .EQ. INPTUN ) THEN STAT = OLD REW = .TRUE. ELSE CALL ZZERRM ( RD(UNIT), *91000, - 'IS REQUEST TO OPEN UNKNOWN UNIT # ' ) ENDIF C FOR THE "CHOICE OF UNIT..." 500 IF ( OPENIT ) THEN IF ( NAME .EQ. BLANK ) THEN C PRINT*,'OPENING ',UNIT,'NAME=' IF ( RECLEN .EQ. 0 ) THEN OPEN ( UNIT = UNIT, - ERR = 1000, - IOSTAT = ERRINT, - STATUS = STAT, - ACCESS = ACCS, - FORM = FRMT ) ELSE OPEN ( UNIT = UNIT, - ERR = 1000, - IOSTAT = ERRINT, - STATUS = STAT, - ACCESS = ACCS, - RECL = RECLEN, - FORM = FRMT ) ENDIF ELSE C NAMED FILE IF ( RECLEN .EQ. 0 ) THEN C PRINT*,'OPENING ',UNIT,'NAME=',NAME(1:20) OPEN ( UNIT = UNIT, - ERR = 1000, - IOSTAT = ERRINT, - FILE = NAME, - STATUS = STAT, - ACCESS = ACCS, - FORM = FRMT ) C PRINT*,'OK' ELSE OPEN ( UNIT = UNIT, - ERR = 1000, - FILE = NAME, - IOSTAT = ERRINT, - STATUS = STAT, - ACCESS = ACCS, - RECL = RECLEN, - FORM = FRMT ) ENDIF ENDIF ENDIF C FOR EACH UNIT FROM 1 TO NFILES WE NEED TO KEEP A RECORD OF C WHETHER IT IS CURRENTLY OPEN. OPENFS(UNIT) = .TRUE. IF ( REW .AND. RECLEN .EQ. 0 ) THEN REWIND UNIT ENDIF GOTO 1025 1000 IF ( UNIT .EQ. DAUF ) THEN C CREATE THE DAUF. STAT = NEW GOTO 500 ELSE GOTO 1050 ENDIF 1025 CONTINUE IF ( COPY .AND. UNIT .EQ. STDIN ) THEN UNIT = COPYUN NAME = COPYNM GOTO 100 ENDIF ENDIF C FOR THE "IF FLAG..." GOTO 90000 1050 CONTINUE GOTO 91000 C## E N T R Y ZZCLSE: ENTRY ZZCLSE ( IUNIT, * ) STAT = KEEP IF ( IUNIT .EQ. SUMMUN ) THEN STAT = KEEP ELSE IF ( IUNIT .EQ. TRMOUT ) THEN ELSE IF ( IUNIT .EQ. STDIN ) THEN ELSE IF ( IUNIT .EQ. TEMPUN ) THEN STAT = KEEP ELSE IF ( IUNIT .EQ. WRITUN ) THEN ELSE IF ( IUNIT .EQ. TRACUN ) THEN ELSE IF ( IUNIT .EQ. COPYUN ) THEN STAT = KEEP COPY = F ELSE IF ( IUNIT .EQ. DAUF ) THEN ELSE IF ( IUNIT .EQ. PREPRC ) THEN ELSE IF ( IUNIT .EQ. INPTUN ) THEN ELSE CALL ZZERRM ( RD(IUNIT), *91000, - 'IS IGNORING REQUEST TO CLOSE UNKNOWN UNIT #' ) ENDIF IF ( OPENFS(IUNIT) ) THEN C PRINT*,'CLOSING ',IUNIT CLOSE ( UNIT = IUNIT, STATUS = STAT ) OPENFS(IUNIT) = .FALSE. ENDIF RETURN C## E X I T 90000 CONTINUE CALL ZZCASE (STAT,CTOUPP) IF ( IUNIT .EQ. DAUF .AND. STAT .EQ. NEW ) THEN GOTO 91000 ELSE RETURN ENDIF 91000 RETURN 1 C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZOPEN. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> reclsg.f7l INTEGER FUNCTION ZZRECL ( CPERLN, IPERLN, LPERLN, RPERLN ) C## A R G U M E N T S: INTEGER CPERLN, IPERLN, LPERLN, RPERLN C## S T A T U S: C SINGLE/DOUBLE Conversion: Needed (See CONVRT). C C Ignore lines beginning with "C!!!!" . C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C System Dependence: System routine for direct C access unformatted record length C C THIS VERSION IS FOR Lahey's F77L for PC's C C>RCS $Header: recl.gl,v 2.1 91/11/22 11:45:23 buckley Exp $ C>RCS $Log: recl.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:23 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/16 14:39:15 buckley C>RCS Added Lahey C>RCS C>RCS Revision 1.9 89/06/30 13:30:18 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:30 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:29 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:07 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:32 buckley C>RCS Initial revision C>RCS C## D E S C R I P T I O N: C C THIS ROUTINE USES FOUR INTEGER CONSTANTS NEEDED TO DETERMINE C THE LENGTH OF AN UNFORMATTED RECORD FOR READING AND WRITING C DIRECT ACCESS FILES. THE PROCESSOR IS ASSUMED, ACCORDING C TO THE FORTRAN STANDARD, TO WRITE UNFORMATTED RECORDS C IN "PROCESSOR DEFINED UNITS", I.E. IN PDU'S. C C HERE WE MUST DEFINE FOUR CONSTANTS: C C CHARS THE NUMBER OF PDU'S NEEDED TO WRITE ONE CHARACTER; C INTS THE NUMBER OF PDU'S NEEDED TO WRITE ONE INTEGER VALUE; C LOGS THE NUMBER OF PDU'S NEEDED TO WRITE ONE LOGICAL VALUE; C REALS THE NUMBER OF PDU'S NEEDED TO WRITE ONE REAL(DP) VALUE. C C NOTE THAT IT MAY HAPPEN (PARTICULARLY WITH CHARACTER OR LOGICAL C DATA) THAT SEVERAL VALUES MAY FIT INTO ONE PDU. IN THIS CASE, SET C THE CONSTANT TO A NEGATIVE VALUE. FOR EXAMPLE, ON A CYBER, A PDU C IS ONE WORD AND 10 CHARACTERS FIT PER WORD. IN THIS CASE, CHARS C IS SET TO -10. BUT ON A VAX, A PDU IS ONE BYTE AND AN INTEGER C OCCUPIES 4 BYTES, SO INTS IS SET TO 4. NOTE THAT THE VALUES FOR C 'REALS' WILL GENERALLY BE DIFFERENT FOR THE SINGLE AND DOUBLE C PRECISION VERSIONS ON THE SAME MACHINE. C C ON ENTRY, THE FOUR ARGUMENTS INDICATE HOW MANY VALUES OF EACH OF C THE FOUR BASIC TYPES ARE REQUIRED TO FIT IN ONE DIRECT ACCESS C UNFORMATTED RECORD. THIS ROUTINE WILL DETERMINE THE MINIMUM RECORD C LENGTH NEEDED TO SATISFY ALL FOUR REQUIREMENTS. THAT VALUE WILL BE C RETURNED AS THE VALUE OF THE FUNCTION ZZRECL. C C IT WILL THEN *RETURN* IN EACH OF THE FOUR ARGUMENTS THE *ACTUAL* C NUMBER OF EACH OF THESE WHICH CAN FIT IN THE RECORD OF THE SIZE C DETERMINED. C C N.B. **** THIS ROUTINE ASSUMES *NO MIXING* OF DATA TYPES ON C ANY ONE RECORD WHEN USING DIRECT ACCESS UNFORMATTED I/O. C THUS EACH TIME A RECORD IS WRITTEN, IT CONTAINS *ONLY* C CHARACTER DATA, OR *ONLY* INTEGER DATA, OR *ONLY* REAL C DATA, OR *ONLY* LOGICAL DATA. ANY MIXING WOULD C TOTALLY DESTROY ANY HOPE OF PORTABILITY TO SOME SYSTEMS. C C## E N T R Y P O I N T S: The natural entry ZZRECL. C## S U B R O U T I N E S: ABS, MAX ... INTRINSIC C C## P A R A M E T E R S: INTEGER CHARS, INTS, LOGS, REALS PARAMETER ( CHARS = 1, INTS = 4, LOGS = 4, REALS = 4 ) C!!!! PARAMETER ( CHARS = 1, INTS = 4, LOGS = 4, REALS = 8 ) C## L O C A L D E C L: INTEGER N C## S A V E: NONE selected. C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C## D A T A: NONE are set. C## E X E C U T I O N C## E X E C U T I O N ZZRECL = 1 IF ( CHARS .LT. 0 ) THEN N = ABS(CHARS) N = ( CPERLN + N - 1 ) / N ELSE N = CPERLN * CHARS ENDIF ZZRECL = MAX ( ZZRECL, N ) IF ( INTS .LT. 0 ) THEN N = ABS(INTS) N = ( IPERLN + N - 1 ) / N ELSE N = IPERLN * INTS ENDIF ZZRECL = MAX ( ZZRECL, N ) IF ( LOGS .LT. 0 ) THEN N = ABS(LOGS) N = ( LPERLN + N - 1 ) / N ELSE N = LPERLN * LOGS ENDIF ZZRECL = MAX ( ZZRECL, N ) IF ( REALS .LT. 0 ) THEN N = ABS(REALS) N = ( RPERLN + N - 1 ) / N ELSE N = RPERLN * REALS ENDIF ZZRECL = MAX ( ZZRECL, N ) C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZRECL. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> secssg.f7l SUBROUTINE ZZSECS(SECS) C## A R G U M E N T S: REAL SECS C!!!! DOUBLE PRECISION SECS C## S T A T U S: C SINGLE/DOUBLE Conversion: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C SYSTEM DEPENDENCE: System routine for CPU usage. C THIS VERSION IS FOR Lahey's F77L for PC's C C>RCS $Header: secs.gl,v 2.1 91/11/22 11:45:25 buckley Exp $ C>RCS $Log: secs.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:25 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/06 10:48:10 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9 89/06/30 13:30:19 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:31 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:31 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:12 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:33 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C THIS SUBROUTINE SHOULD OBTAIN (FROM THE OPERATING SYSTEM) THE C AMOUNT OF CPU TIME USED BY THE CALLING PROGRAM SINCE THE C EXECUTION BEGAN. IF DESIRABLE, "SECS" CAN ALSO BE CONVERTED C TO DOUBLE PRECISION (SEE CONVRT). HOWEVER, THE ROUTINE ACTUALLY C WORKS TOTALLY AS A SINGLE PRECISION ROUTINE, EXCEPT THAT THE C VALUE WHICH IS PASSED BACK MAY BE IN EITHER PRECISION AS C APPROPRIATE. C TIME IS MEASURED FROM THE FIRST CALL TO ZZSECS. THUS C ON THE FIRST CALL TO ZZSECS, A TIME OF 0.0 SECONDS IS ALWAYS C RETURNED. C## E N T R Y P O I N T S: The natural entry ZZSECS. C## S U B R O U T I N E S: A SYSTEM CLOCK. C## P A R A M E T E R S: INTEGER * 4 ONEDAY PARAMETER ( ONEDAY = 8640000 ) REAL ZERO, R100 PARAMETER ( ZERO = 0.0E0, R100 = 100.0 ) C## L O C A L D E C L: LOGICAL FIRST INTEGER * 4 STTIME, HUNSEC REAL SEC C## S A V E: SAVE FIRST, STTIME C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C## D A T A: DATA FIRST/.TRUE./ C## E X E C U T I O N C## E X E C U T I O N IF ( FIRST ) THEN FIRST = .FALSE. CALL TIMER(STTIME) SEC = ZERO ELSE CALL TIMER(HUNSEC) HUNSEC = HUNSEC - STTIME C C Routine TIMER returns the time in hundredths of a second since C midnight. Hence HUNSEC will be negative if midnight has been C passed. The following code corrects this for any job which has C been running not more than 248 days ! C 10 IF (HUNSEC .LT. 0) THEN HUNSEC = HUNSEC + ONEDAY GO TO 10 END IF SEC = HUNSEC / R100 ENDIF SECS = SEC C!!!! SECS = DBLE(SEC) C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZSECS. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> timesg.f7l SUBROUTINE ZZTIME ( CHTIME ) C## A R G U M E N T S: CHARACTER *(*) CHTIME C## S T A T U S: C SINGLE/DOUBLE Conversion: NOT required. C C System Dependence: System routine for Time. C C THIS VERSION IS FOR Lahey's F77L for PC's C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C>RCS $Header: time.gl,v 2.1 91/11/22 11:45:26 buckley Exp $ C>RCS $Log: time.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:26 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/06 10:52:37 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9 89/06/30 13:30:20 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:32 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:33 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:16 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:33 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE MUST CALL A SYSTEM ROUTINE TO GET THE CURRENT TIME. C IT MUST RETURN THIS TIME IN THE CHARACTER VARIABLE CHTIME C IN THE FORM C C (HH+MM+SS) C C AS REQUIRED BY THE ROUTINE ZZDTTM. CHTIME MUST BE OF LENGTH 10. C ONLY THE SIX CHARACTERS HH MM SS ARE ACTUALLY USED. THE OTHERS C CAN BE ANYTHING, BUT THE HH, MM AND SS MUST BE IN THE CORRECT C POSITION. HH SHOULD BE BETWEEN 0 AND 23, I.E. BASED ON THE 24 HOUR C CLOCK. OF COURSE MM AND SS MUST BE IN THE RANGE 0 TO 59. C C THIS VERSION CALLS A SYSTEM DEPENDENT ROUTINE. C TO IMPLEMENT THIS ON ANOTHER SYSTEM, ONE MAY EITHER C C (A) INCORPORATE AN ALTERNATE VERSION OF ZZTIME; C C (B) USE THE "DUMMY" VERSION OF THIS ROUTINE WITH THE SINGLE C EXECUTABLE STATEMENT CHTIME=' ', IN WHICH CASE NO C TIME INFORMATION WILL APPEAR IN THE OUTPUT. C C## E N T R Y P O I N T S: The natural entry ZZTIME. C## S U B R O U T I N E S: SYSTEM ROUTINE TO GET TIME OF DAY. C## P A R A M E T E R S: NONE are defined. C## L O C A L D E C L: CHARACTER * 11 NOW C## S A V E: NONE selected. C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C## D A T A: NONE are set. C## E X E C U T I O N C## E X E C U T I O N CALL TIME (NOW) CHTIME(2:9) = NOW(1:8) C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZTIME. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> casesg.ft5 SUBROUTINE ZZCASE (STRING, TYPE ) C## A R G U M E N T S: CHARACTER *(*) STRING INTEGER TYPE C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NOT REQUIRED. C C SYSTEM DEPENDENCE: SYSTEM ROUTINE FOR CASE C CONVERSION OF LETTERS. C C THIS IS A VERSION FOR CYBER/FTN5: IT IS SPECIAL. C THIS ONLY WORKS FOR CONVERSION TO UPPER CASE. THE C STRING IS SHORTENED AND BLANK FILLED ON THE RIGHT. C>RCS $HEADER: CASE.GL,V 2.0 90/07/05 12:44:20 BUCKLEY EXP $ C>RCS $LOG: CASE.GL,V $ C>RCS REVISION 2.0 90/07/05 12:44:20 BUCKLEY C>RCS COMMON VERSION FOR TOMS AND GL C>RCS C>RCS REVISION 1.9.1.1 89/06/30 14:59:19 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.9 89/06/30 13:30:11 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 16:07:53 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/20 13:48:39 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C## D E S C R I P T I O N: C THIS CONVERTS EACH LOWER CASE ALPHABETIC LETTER TO C UPPER CASE, OR VICE VERSA. C IF TYPE = CTOUPP, CONVERSION IS LOWER TO UPPER C IF TYPE = CTOLOW, CONVERSION IS UPPER TO LOWER C IF TYPE = CTOCAP, USE UPPER FOR FIRST LETTER; LOWER FOR REST C ALL OTHER CHARACTERS ARE LEFT UNCHANGED. C## E N T R Y P O I N T S: THE NATURAL ENTRY TTOUPPR. C## S U B R O U T I N E S: LEN (INTRINSIC). C## P A R A M E T E R S: INTEGER CTOUPP, CTOLOW, CTOCAP PARAMETER ( CTOUPP = 1, CTOLOW = 2, CTOCAP = 3 ) CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) CHARACTER*(*) PERIOD, COMMA, SEMICN PARAMETER ( PERIOD = '.', COMMA = ',', SEMICN = ';' ) CHARACTER*(*) COLON, DASH, EQUALS PARAMETER ( COLON = ':', DASH = '-', EQUALS = '=' ) CHARACTER*(*) OBRACE, CBRACE, UNDERS PARAMETER ( OBRACE = '{', CBRACE = '}', UNDERS = '_' ) CHARACTER*(*) PLUS, MINUS, EXCLAM PARAMETER ( PLUS = '+', MINUS = '-', EXCLAM = '!' ) CHARACTER*(*) GTHAN, LTHAN, QUESMK PARAMETER ( GTHAN = '>', LTHAN = '<', QUESMK = '?' ) CHARACTER*(*) SLASH, BSLASH, PERCNT PARAMETER ( SLASH = '/', BSLASH = '\\',PERCNT = '%' ) CHARACTER*(*) CARAT, ATSIGN, TILDE PARAMETER ( CARAT = '^', ATSIGN = '@', TILDE = '~' ) C## L O C A L D E C L: INTEGER I, TO CHARACTER *1 CH C## S A V E: NONE ARE SELECTED. C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: NONE IS DEFINED. C## E X E C U T I O N C## E X E C U T I O N TO = 1 I = 0 100 I = I + 1 IF ( I .LE. LEN(STRING) ) THEN IF ( TYPE .EQ. CTOUPP ) THEN CH = STRING(I:I) IF ( CH .EQ. ATSIGN .OR. CH .EQ. CARAT ) THEN I = I + 1 ENDIF STRING(TO:TO) = STRING(I:I) ENDIF TO = TO + 1 GOTO 100 ENDIF C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF TOUPPR. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> datesg.ft5 SUBROUTINE ZZdate (CHDATE) C## A R G U M E N T S: CHARACTER *(*) CHDATE C## S T A T U S: C SINGLE/DOUBLE Conversion: NOT required. C SYSTEM DEPENDENCE: System routine for date. C C THIS VERSION IS FOR CYBER/FTN5 C C>RCS $Header: date.gl,v 2.1 91/11/22 11:45:18 buckley Exp $ C>RCS $Log: date.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:18 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/05 12:50:05 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9 89/06/30 13:30:12 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:26 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:12:13 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:33:41 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:30 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C THIS ROUTINE MUST CALL A SYSTEM ROUTINE TO GET THE CURRENT DATE. C ZZDATE MUST RETURN THIS DATE IN THE CHARACTER VARIABLE CHDATE C IN THE FORM C C (YY+MM+DD) C C AS REQUIRED BY THE ROUTINE ZZDTTM. CHDATE MUST OF LENGTH 10. C ONLY THE 6 CHARACTERS YY MM DD ARE ACTUALLY USED. THE OTHERS C CAN BE ANYTHING, I.E. ONLY THE POSITION OF THE YY MM DD MATTERS. C C THIS MUST CALL A SYSTEM ROUTINE TO GET THE DATE. C TO IMPLEMENT THIS ON ANOTHER SYSTEM, ONE MAY EITHER C C (A) INCORPORATE AN ALTERNATE VERSION OF ZZDATE; C C (B) USE THE "DUMMY" VERSION OF THIS ROUTINE WITH THE SINGLE C EXECUTABLE STATEMENT CHDATE='( + + )', IN WHICH CASE NO C DATE INFORMATION WILL APPEAR IN THE OUTPUT. C## E N T R Y P O I N T S: The natural entry ZZdate. C## S U B R O U T I N E S: System date routine. C## P A R A M E T E R S: NONE are defined. C## L O C A L D E C L: CHARACTER * 10 DATE C## S A V E: NONE selected. C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C## D A T A: NO DATA VALUES SET. C## E X E C U T I O N C## E X E C U T I O N C---- INITIALIZE CHDATE CHDATE = '( + + )' CHDATE = DATE() C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZdate. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> mparsg.ft5 REAL FUNCTION ZZMPAR(I) C!!!! DOUBLE PRECISION FUNCTION ZZMPAR(I) C## A R G U M E N T S: INTEGER I C## S T A T U S: C IGNORE LINES BEGINNING WITH "C!!!!" . C C SYSTEM DEPENDENCE: THE CODE IS VERY DEFINITELY MACHINE DEPENDENT C FOR IT CONTAINS MACHINE PRECISION CONSTANTS C FOR MANY MACHINES, AS DESCRIBED BELOW. C C SINGLE/DOUBLE Conversion: NEEDED (SEE CONVRT). C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C>RCS $Header: mpar.gl,v 2.3 91/11/22 11:45:19 buckley Exp $ C>RCS $Log: mpar.gl,v $ C>RCS Revision 2.3 91/11/22 11:45:19 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.2 91/06/12 14:07:08 buckley C>RCS Added stardent C>RCS C>RCS Revision 2.1 90/07/31 10:57:40 buckley C>RCS Added constants for ieee for pc's C>RCS C>RCS Revision 2.0 90/07/06 10:39:26 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9.1.2 90/06/26 14:24:24 buckley C>RCS Fixed single/double precision constants for sun4 C>RCS C>RCS Revision 1.9.1.1 89/07/01 11:36:48 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.9 89/06/30 13:30:15 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:28 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:23 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:34:59 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:31 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C C THIS IS A MODIFICATION OF THE TWO ROUTINES DPMPAR AND SPMPAR C OBTAINED FROM JORGE MORE. IT HAS BEEN CHANGED ONLY TO CONFORM C WITH MY CONVENTIONS, AND TO ADD STATEMENTS FOR THE CDC C CYBERS WHICH ARE ACCEPTABLE TO FTN5 (FORTRAN '77). THE C OTHER CHANGES ARE: C C 1. THE SINGLE NAME ZZMPAR HAS BEEN USED. IT IS DOUBLE OR SINGLE C PRECISION ACCORDING TO CONVERSION BY CONVRT, JUST AS FOR ALL C OF MY OTHER PROGRAMS. C C 2. THE ROUTINES HAVE BEEN MERGED SO THAT SINGLE AND DOUBLE C PRECISION STATEMENTS WHICH CORRESPOND APPEAR IN PAIRS. C C OTHERWISE ALL OF THE COMMENTS OF THE ORIGINAL AUTHORS APPLY. C THEIR ORIGINAL COMMENTS (UNALTERED) FOR THE DOUBLE PRECISION C VERSION FOLLOW IMMEDIATELY. C C FUNCTION DPMPAR C C THIS FUNCTION PROVIDES DOUBLE PRECISION MACHINE PARAMETERS C WHEN THE APPROPRIATE SET OF DATA STATEMENTS IS ACTIVATED (BY C REMOVING THE C FROM COLUMN 1) AND ALL OTHER DATA STATEMENTS ARE C RENDERED INACTIVE. MOST OF THE PARAMETER VALUES WERE OBTAINED C FROM THE CORRESPONDING BELL LABORATORIES PORT LIBRARY FUNCTION. C C THE FUNCTION STATEMENT IS C C DOUBLE PRECISION FUNCTION DPMPAR(I) C C WHERE C C I IS AN INTEGER INPUT VARIABLE SET TO 1, 2, OR 3 WHICH C SELECTS THE DESIRED MACHINE PARAMETER. IF THE MACHINE HAS C T BASE B DIGITS AND ITS SMALLEST AND LARGEST EXPONENTS ARE C EMIN AND EMAX, RESPECTIVELY, THEN THESE PARAMETERS ARE C C DPMPAR(1) B**(1 - T), THE MACHINE PRECISION, C C DPMPAR(2) B**(EMIN - 1), THE SMALLEST MAGNITUDE, C C DPMPAR(3) B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE C C## E N T R Y P O I N T S: The natural entry ZZmpar. C## S U B R O U T I N E S: NONE are called. C## P A R A M E T E R S: NONE are defined. C C## L O C A L D E C L: C NOTE THAT THESE ARRAYS MUST HAVE DIMENSIONS 2 AND 4, RATHER C THAN 1 AND 2 AS ONE MIGHT EXPECT, BECAUSE OF THE PDP-11 C DEFINITIONS. INTEGER MCHEPS(2) C!!!! INTEGER MCHEPS(4) INTEGER MINMAG(2) C!!!! INTEGER MINMAG(4) INTEGER MAXMAG(2) C!!!! INTEGER MAXMAG(4) REAL RMACH(3) C!!!! DOUBLE PRECISION DMACH(3) INTEGER EMIN, EMAX, IMACH(10) REAL B, BINV, BM1, ONE, W, Z C!!!! DOUBLE PRECISION B, BINV, BM1, ONE, W, Z C## S A V E: SAVE RMACH C!!!! SAVE DMACH SAVE IMACH C## E Q U I V A L E N C E S: EQUIVALENCE (RMACH(1),MCHEPS(1)) C!!!! EQUIVALENCE (DMACH(1),MCHEPS(1)) EQUIVALENCE (RMACH(2),MINMAG(1)) C!!!! EQUIVALENCE (DMACH(2),MINMAG(1)) EQUIVALENCE (RMACH(3),MAXMAG(1)) C!!!! EQUIVALENCE (DMACH(3),MAXMAG(1)) C## C O M M O N: NONE is defined. C## D A T A: C-----MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES (FTN 5). C-----SAME FOR CYBER 800/900 SERIES IN 60 BIT MODE (NOS) C!!!! DATA MCHEPS(1) / O"15614000000000000000" / DATA RMACH(1) / O"16414000000000000000" / C!!!! DATA MCHEPS(2) / O"15010000000000000000" / C!!!! DATA MINMAG(1) / O"00604000000000000000" / DATA RMACH(2) / O"00014000000000000000" / C!!!! DATA MINMAG(2) / O"00000000000000000000" / C!!!! DATA MAXMAG(1) / O"37767777777777777777" / DATA RMACH(3) / O"37767777777777777777" / C!!!! DATA MAXMAG(2) / O"37167777777777777777" / C## E X E C U T I O N C## E X E C U T I O N ZZMPAR = RMACH(I) C!!!! ZZMPAR = DMACH(I) C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZmpar. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> opensg.ft5 SUBROUTINE ZZOPEN ( IUNIT, FLAG, INAME, * , RECLEN ) C## A R G U M E N T S: INTEGER IUNIT, RECLEN LOGICAL FLAG CHARACTER *(*) INAME C## S T A T U S: C IGNORE LINES BEGINNING WITH "C!!!!" . C C SINGLE/DOUBLE Conversion: NEEDED (SEE CONVRT). C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR C OPENING AND CLOSING FILES. C C THIS VERSION IS FOR CYBER/FTN5 C C>RCS $Header: open.gl,v 2.1 91/11/22 11:45:21 buckley Exp $ C>RCS $Log: open.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:21 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/06 10:43:19 buckley C>RCS Common version for TOMS and MT C>RCS C>RCS Revision 1.9.1.2 89/07/01 11:51:41 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.9.1.1 89/07/01 11:36:50 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.9 89/06/30 13:30:16 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:29 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:26 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:02 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:31 buckley C>RCS Initial revision C>RCS C## D E S C R I P T I O N: C C THIS OPENS THE FILES NEEDED FOR TESTPACK AND KEEPS TRACK OF C WHICH ARE OPEN AND WHICH ARE NOT. IT ALSO SUPPLIES THE APPRO- C PRIATE ARGUMENTS FOR EACH FILE. C C IF NAME IS NOT BLANK ON ENTRY, THEN THE FILE IS OPENED C WITH THE NAME GIVEN. OTHERWISE, NO NAME IS SPECIFIED WHEN C OPENING THE FILE. C C THE OPEN IS ONLY DONE IF "FLAG" IS TRUE. C C IF RECLEN IS NOT EQUAL TO ZERO, THEN THE FILE IS OPENED C AS DIRECT ACCESS UNFORMATTED. C C IF RECLEN IS EQUAL TO ZERO, THEN THE FILE IS OPENED C FOR FORMATTED SEQUENTIAL ACCESS. C C## E N T R Y P O I N T S: The natural entry ZZopen and ZZclse C## S U B R O U T I N E S: OPEN, CLOSE, REAL ...INTRINSIC C ZZERRM ...FOR ERROR MESSAGES. C## P A R A M E T E R S: INTEGER FILENL, NFILES PARAMETER ( FILENL = 80, NFILES = 15 ) CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) CHARACTER*(*) PERIOD, COMMA, SEMICN PARAMETER ( PERIOD = '.', COMMA = ',', SEMICN = ';' ) CHARACTER*(*) COLON, DASH, EQUALS PARAMETER ( COLON = ':', DASH = '-', EQUALS = '=' ) CHARACTER*(*) OBRACE, CBRACE, UNDERS PARAMETER ( OBRACE = '{', CBRACE = '}', UNDERS = '_' ) CHARACTER*(*) PLUS, MINUS, EXCLAM PARAMETER ( PLUS = '+', MINUS = '-', EXCLAM = '!' ) CHARACTER*(*) GTHAN, LTHAN, QUESMK PARAMETER ( GTHAN = '>', LTHAN = '<', QUESMK = '?' ) CHARACTER*(*) SLASH, BSLASH, PERCNT PARAMETER ( SLASH = '/', BSLASH = '\\',PERCNT = '%' ) CHARACTER*(*) CARAT, ATSIGN, TILDE PARAMETER ( CARAT = '^', ATSIGN = '@', TILDE = '~' ) LOGICAL T, F PARAMETER ( T = .TRUE., F = .FALSE. ) CHARACTER*(*) TRUE, QT, FALSE, QF PARAMETER ( TRUE = 'TRUE', QT = 'T', FALSE = 'FALSE', QF = 'F' ) INTEGER ITRUE, IFALSE PARAMETER ( ITRUE = 1, IFALSE = 0 ) REAL RTRUE, RFALSE C!!!! DOUBLE PRECISION RTRUE, RFALSE PARAMETER ( RTRUE = 1.D0, RFALSE = 0.D0 ) INTEGER CTOUPP, CTOLOW, CTOCAP PARAMETER ( CTOUPP = 1, CTOLOW = 2, CTOCAP = 3 ) INTEGER PREPRC, DAUF, INPTUN PARAMETER ( PREPRC = 1, DAUF = 2, INPTUN = 3 ) INTEGER TEMPUN, STDIN, TRMOUT PARAMETER ( TEMPUN = 4, STDIN = 5, TRMOUT = 6 ) INTEGER WRITUN, TRACUN, SUMMUN PARAMETER ( WRITUN = 7, TRACUN = 8, SUMMUN = 9 ) INTEGER COPYUN, TEXUN PARAMETER ( COPYUN =10, TEXUN =11 ) C THIS REDUCES I/O BUFFER SIZES FOR THE C CYBER AND HENCE MEMORY REQUIREMENTS. INTEGER BUFLEN PARAMETER ( BUFLEN = 100 ) CHARACTER *(*) SEQ , DIR PARAMETER ( SEQ = 'SEQUENTIAL', DIR = 'DIRECT' ) CHARACTER *(*) UNKN , NEW PARAMETER ( UNKN = 'UNKNOWN' , NEW = 'NEW' ) CHARACTER *(*) OLD , SCR PARAMETER ( OLD = 'OLD' , SCR = 'SCRATCH' ) CHARACTER *(*) DEL , KEEP PARAMETER ( DEL = 'DELETE' , KEEP = 'KEEP' ) CHARACTER *(*) FMT , UNFRMT PARAMETER ( FMT = 'FORMATTED' , UNFRMT = 'UNFORMATTED' ) C## L O C A L D E C L: INTEGER ERRINT, UNIT LOGICAL OPENFS(NFILES), REW, OPENIT, COPY CHARACTER STAT*7, ACCS*10, FRMT*11 CHARACTER *(FILENL) COPYNM, NAME REAL RD C!!!! DOUBLE PRECISION RD C## S A V E: SAVE OPENFS, COPY, COPYNM C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA OPENFS / NFILES * .FALSE. / DATA COPY/F/, COPYNM/BLANK/ C## E X E C U T I O N C## E X E C U T I O N C----- DEFINE A STATEMENT FUNCTION. RD(UNIT) = REAL(UNIT) C!!!! RD(UNIT) = DBLE(UNIT) IF ( FLAG ) THEN IF ( RECLEN .EQ. 0 ) THEN ACCS = SEQ FRMT = FMT ELSE ACCS = DIR FRMT = UNFRMT ENDIF UNIT = IUNIT NAME = INAME 100 CONTINUE OPENIT = .NOT. OPENFS(UNIT) REW = .FALSE. IF ( UNIT .EQ. SUMMUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. TRMOUT ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. STDIN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. PREPRC) THEN STAT = OLD REW = .TRUE. ELSE IF ( UNIT .EQ. TEMPUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. WRITUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. TRACUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. DAUF ) THEN STAT = OLD ELSE IF ( UNIT .EQ. COPYUN ) THEN STAT = UNKN COPY = T ELSE IF ( UNIT .EQ. INPTUN ) THEN STAT = OLD REW = .TRUE. ELSE CALL ZZERRM ( RD(UNIT), *91000, - 'IS REQUEST TO OPEN UNKNOWN UNIT # ' ) ENDIF C FOR THE "CHOICE OF UNIT..." 500 IF ( OPENIT ) THEN IF ( NAME .EQ. BLANK ) THEN C PRINT*,'OPENING ',UNIT,'NAME=' IF ( RECLEN .EQ. 0 ) THEN OPEN ( UNIT = UNIT, - ERR = 1000, - IOSTAT = ERRINT, - STATUS = STAT, - ACCESS = ACCS, - FORM = FRMT, - BUFL = BUFLEN ) ELSE OPEN ( UNIT = UNIT, - ERR = 1000, - IOSTAT = ERRINT, - STATUS = STAT, - ACCESS = ACCS, - RECL = RECLEN, - FORM = FRMT, - BUFL = BUFLEN ) ENDIF ELSE C NAMED FILE IF ( RECLEN .EQ. 0 ) THEN C PRINT*,'OPENING ',UNIT,'NAME=',NAME(1:20) OPEN ( UNIT = UNIT, - ERR = 1000, - IOSTAT = ERRINT, - FILE = NAME, - STATUS = STAT, - ACCESS = ACCS, - FORM = FRMT, - BUFL = BUFLEN ) C PRINT*,'OK' ELSE OPEN ( UNIT = UNIT, - ERR = 1000, - FILE = NAME, - IOSTAT = ERRINT, - STATUS = STAT, - ACCESS = ACCS, - RECL = RECLEN, - FORM = FRMT, - BUFL = BUFLEN ) ENDIF ENDIF ENDIF C FOR EACH UNIT FROM 1 TO NFILES WE NEED TO KEEP A RECORD OF C WHETHER IT IS CURRENTLY OPEN. OPENFS(UNIT) = .TRUE. IF ( REW .AND. RECLEN .EQ. 0 ) THEN REWIND UNIT ENDIF GOTO 1025 1000 IF ( UNIT .EQ. DAUF ) THEN C CREATE THE DAUF. STAT = NEW GOTO 500 ELSE GOTO 1050 ENDIF 1025 CONTINUE IF ( COPY .AND. UNIT .EQ. STDIN ) THEN UNIT = COPYUN NAME = COPYNM GOTO 100 ENDIF ENDIF C FOR THE "IF FLAG..." GOTO 90000 1050 CONTINUE GOTO 91000 C## E N T R Y ZZCLSE: ENTRY ZZCLSE ( IUNIT, * ) STAT = KEEP IF ( IUNIT .EQ. SUMMUN ) THEN STAT = KEEP ELSE IF ( IUNIT .EQ. TRMOUT ) THEN ELSE IF ( IUNIT .EQ. STDIN ) THEN ELSE IF ( IUNIT .EQ. TEMPUN ) THEN STAT = KEEP ELSE IF ( IUNIT .EQ. WRITUN ) THEN ELSE IF ( IUNIT .EQ. TRACUN ) THEN ELSE IF ( IUNIT .EQ. COPYUN ) THEN STAT = KEEP COPY = F ELSE IF ( IUNIT .EQ. DAUF ) THEN ELSE IF ( IUNIT .EQ. PREPRC ) THEN ELSE IF ( IUNIT .EQ. INPTUN ) THEN ELSE CALL ZZERRM ( RD(IUNIT), *91000, - 'IS IGNORING REQUEST TO CLOSE UNKNOWN UNIT #' ) ENDIF IF ( OPENFS(IUNIT) ) THEN C PRINT*,'CLOSING ',IUNIT CLOSE ( UNIT = IUNIT, STATUS = STAT ) OPENFS(IUNIT) = .FALSE. ENDIF RETURN C## E X I T 90000 CONTINUE CALL ZZCASE (STAT,CTOUPP) IF ( IUNIT .EQ. DAUF .AND. STAT .EQ. NEW ) THEN GOTO 91000 ELSE RETURN ENDIF 91000 RETURN 1 C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZOPEN. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> reclsg.ft5 INTEGER FUNCTION ZZRECL ( CPERLN, IPERLN, LPERLN, RPERLN ) C## A R G U M E N T S: INTEGER CPERLN, IPERLN, LPERLN, RPERLN C## S T A T U S: C SINGLE/DOUBLE Conversion: Needed (See CONVRT). C C Ignore lines beginning with "C!!!!" . C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C System Dependence: System routine for direct C access unformatted record length C C THIS VERSION IS FOR CYBER/FTN5 C C>RCS $Header: recl.gl,v 2.1 91/11/22 11:45:23 buckley Exp $ C>RCS $Log: recl.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:23 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/16 14:39:15 buckley C>RCS Added Lahey C>RCS C>RCS Revision 1.9 89/06/30 13:30:18 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:30 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:29 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:07 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:32 buckley C>RCS Initial revision C>RCS C## D E S C R I P T I O N: C C THIS ROUTINE USES FOUR INTEGER CONSTANTS NEEDED TO DETERMINE C THE LENGTH OF AN UNFORMATTED RECORD FOR READING AND WRITING C DIRECT ACCESS FILES. THE PROCESSOR IS ASSUMED, ACCORDING C TO THE FORTRAN STANDARD, TO WRITE UNFORMATTED RECORDS C IN "PROCESSOR DEFINED UNITS", I.E. IN PDU'S. C C HERE WE MUST DEFINE FOUR CONSTANTS: C C CHARS THE NUMBER OF PDU'S NEEDED TO WRITE ONE CHARACTER; C INTS THE NUMBER OF PDU'S NEEDED TO WRITE ONE INTEGER VALUE; C LOGS THE NUMBER OF PDU'S NEEDED TO WRITE ONE LOGICAL VALUE; C REALS THE NUMBER OF PDU'S NEEDED TO WRITE ONE REAL(DP) VALUE. C C NOTE THAT IT MAY HAPPEN (PARTICULARLY WITH CHARACTER OR LOGICAL C DATA) THAT SEVERAL VALUES MAY FIT INTO ONE PDU. IN THIS CASE, SET C THE CONSTANT TO A NEGATIVE VALUE. FOR EXAMPLE, ON A CYBER, A PDU C IS ONE WORD AND 10 CHARACTERS FIT PER WORD. IN THIS CASE, CHARS C IS SET TO -10. BUT ON A VAX, A PDU IS ONE BYTE AND AN INTEGER C OCCUPIES 4 BYTES, SO INTS IS SET TO 4. NOTE THAT THE VALUES FOR C 'REALS' WILL GENERALLY BE DIFFERENT FOR THE SINGLE AND DOUBLE C PRECISION VERSIONS ON THE SAME MACHINE. C C ON ENTRY, THE FOUR ARGUMENTS INDICATE HOW MANY VALUES OF EACH OF C THE FOUR BASIC TYPES ARE REQUIRED TO FIT IN ONE DIRECT ACCESS C UNFORMATTED RECORD. THIS ROUTINE WILL DETERMINE THE MINIMUM RECORD C LENGTH NEEDED TO SATISFY ALL FOUR REQUIREMENTS. THAT VALUE WILL BE C RETURNED AS THE VALUE OF THE FUNCTION ZZRECL. C C IT WILL THEN *RETURN* IN EACH OF THE FOUR ARGUMENTS THE *ACTUAL* C NUMBER OF EACH OF THESE WHICH CAN FIT IN THE RECORD OF THE SIZE C DETERMINED. C C N.B. **** THIS ROUTINE ASSUMES *NO MIXING* OF DATA TYPES ON C ANY ONE RECORD WHEN USING DIRECT ACCESS UNFORMATTED I/O. C THUS EACH TIME A RECORD IS WRITTEN, IT CONTAINS *ONLY* C CHARACTER DATA, OR *ONLY* INTEGER DATA, OR *ONLY* REAL C DATA, OR *ONLY* LOGICAL DATA. ANY MIXING WOULD C TOTALLY DESTROY ANY HOPE OF PORTABILITY TO SOME SYSTEMS. C C## E N T R Y P O I N T S: The natural entry ZZRECL. C## S U B R O U T I N E S: ABS, MAX ... INTRINSIC C C## P A R A M E T E R S: INTEGER CHARS, INTS, LOGS, REALS PARAMETER ( CHARS = -10, INTS = 1, LOGS = 1, REALS = 1 ) C!!!! PARAMETER ( CHARS = -10, INTS = 1, LOGS = 1, REALS = 2 ) C## L O C A L D E C L: INTEGER N C## S A V E: NONE selected. C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C## D A T A: NONE are set. C## E X E C U T I O N C## E X E C U T I O N ZZRECL = 1 IF ( CHARS .LT. 0 ) THEN N = ABS(CHARS) N = ( CPERLN + N - 1 ) / N ELSE N = CPERLN * CHARS ENDIF ZZRECL = MAX ( ZZRECL, N ) IF ( INTS .LT. 0 ) THEN N = ABS(INTS) N = ( IPERLN + N - 1 ) / N ELSE N = IPERLN * INTS ENDIF ZZRECL = MAX ( ZZRECL, N ) IF ( LOGS .LT. 0 ) THEN N = ABS(LOGS) N = ( LPERLN + N - 1 ) / N ELSE N = LPERLN * LOGS ENDIF ZZRECL = MAX ( ZZRECL, N ) IF ( REALS .LT. 0 ) THEN N = ABS(REALS) N = ( RPERLN + N - 1 ) / N ELSE N = RPERLN * REALS ENDIF ZZRECL = MAX ( ZZRECL, N ) C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZRECL. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> secssg.ft5 SUBROUTINE ZZSECS(SECS) C## A R G U M E N T S: REAL SECS C!!!! DOUBLE PRECISION SECS C## S T A T U S: C SINGLE/DOUBLE Conversion: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C SYSTEM DEPENDENCE: System routine for CPU usage. C This version is for CYBER/FTN5 C C>RCS $Header: secs.gl,v 2.1 91/11/22 11:45:25 buckley Exp $ C>RCS $Log: secs.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:25 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/06 10:48:10 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9 89/06/30 13:30:19 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:31 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:31 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:12 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:33 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C THIS SUBROUTINE SHOULD OBTAIN (FROM THE OPERATING SYSTEM) THE C AMOUNT OF CPU TIME USED BY THE CALLING PROGRAM SINCE THE C EXECUTION BEGAN. IF DESIRABLE, "SECS" CAN ALSO BE CONVERTED C TO DOUBLE PRECISION (SEE CONVRT). HOWEVER, THE ROUTINE ACTUALLY C WORKS TOTALLY AS A SINGLE PRECISION ROUTINE, EXCEPT THAT THE C VALUE WHICH IS PASSED BACK MAY BE IN EITHER PRECISION AS C APPROPRIATE. C TIME IS MEASURED FROM THE FIRST CALL TO ZZSECS. THUS C ON THE FIRST CALL TO ZZSECS, A TIME OF 0.0 SECONDS IS ALWAYS C RETURNED. C## E N T R Y P O I N T S: The natural entry ZZSECS. C## S U B R O U T I N E S: A SYSTEM CLOCK. C## P A R A M E T E R S: REAL ZERO PARAMETER ( ZERO = 0.0E0 ) C## L O C A L D E C L: LOGICAL FIRST REAL SECOND REAL STTIME, SEC C## S A V E: SAVE FIRST, STTIME C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C## D A T A: DATA FIRST/.TRUE./ C## E X E C U T I O N C## E X E C U T I O N IF ( FIRST ) THEN FIRST = .FALSE. STTIME = SECOND() SEC = ZERO ELSE SEC = SECOND() - STTIME ENDIF SECS = SEC C!!!! SECS = DBLE(SEC) C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZSECS. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> timesg.ft5 SUBROUTINE ZZTIME ( CHTIME ) C## A R G U M E N T S: CHARACTER *(*) CHTIME C## S T A T U S: C SINGLE/DOUBLE Conversion: NOT required. C C System Dependence: System routine for Time. C C THIS VERSION IS FOR CYBER/FTN5 C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C>RCS $Header: time.gl,v 2.1 91/11/22 11:45:26 buckley Exp $ C>RCS $Log: time.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:26 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/06 10:52:37 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9 89/06/30 13:30:20 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:32 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:33 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:16 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:33 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE MUST CALL A SYSTEM ROUTINE TO GET THE CURRENT TIME. C IT MUST RETURN THIS TIME IN THE CHARACTER VARIABLE CHTIME C IN THE FORM C C (HH+MM+SS) C C AS REQUIRED BY THE ROUTINE ZZDTTM. CHTIME MUST BE OF LENGTH 10. C ONLY THE SIX CHARACTERS HH MM SS ARE ACTUALLY USED. THE OTHERS C CAN BE ANYTHING, BUT THE HH, MM AND SS MUST BE IN THE CORRECT C POSITION. HH SHOULD BE BETWEEN 0 AND 23, I.E. BASED ON THE 24 HOUR C CLOCK. OF COURSE MM AND SS MUST BE IN THE RANGE 0 TO 59. C C THIS VERSION CALLS A SYSTEM DEPENDENT ROUTINE. C TO IMPLEMENT THIS ON ANOTHER SYSTEM, ONE MAY EITHER C C (A) INCORPORATE AN ALTERNATE VERSION OF ZZTIME; C C (B) USE THE "DUMMY" VERSION OF THIS ROUTINE WITH THE SINGLE C EXECUTABLE STATEMENT CHTIME=' ', IN WHICH CASE NO C TIME INFORMATION WILL APPEAR IN THE OUTPUT. C C## E N T R Y P O I N T S: The natural entry ZZTIME. C## S U B R O U T I N E S: SYSTEM ROUTINE TO GET TIME OF DAY. C## P A R A M E T E R S: NONE are defined. C## L O C A L D E C L: CHARACTER * 10 TIME C## S A V E: NONE selected. C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C## D A T A: NONE are set. C## E X E C U T I O N C## E X E C U T I O N CHTIME = TIME() C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZTIME. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> casesg.gnc SUBROUTINE ZZCASE (STRING, TYPE ) C## A R G U M E N T S: CHARACTER *(*) STRING INTEGER TYPE C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NOT REQUIRED. C C SYSTEM DEPENDENCE: SYSTEM ROUTINE FOR CASE C CONVERSION OF LETTERS. C C==>CYBER/FTN5 C THIS IS A VERSION FOR CYBER/FTN5: IT IS SPECIAL. C THIS ONLY WORKS FOR CONVERSION TO UPPER CASE. THE C STRING IS SHORTENED AND BLANK FILLED ON THE RIGHT. C==>VAX/BERK4.2 C THIS IS A VERSION FOR VAX/BERK4.2(3) C==>VAX/VMS C THIS IS A VERSION FOR VAX/VMS C==>HW6 C THIS IS A VERSION FOR HW6 C==>SUN4 C THIS IS A VERSION FOR SUN4 C==>SUN3 C THIS IS A VERSION FOR SUN3 C==>SSYM C THIS IS A VERSION FOR Sequent Symmetry C==>MAC/MS C THIS IS A VERSION FOR MAC/MS C==>LAHEYF77L C THIS VERSION IS FOR LAHEY'S F77L FOR PC'S C==> C>RCS $HEADER: CASE.GL,V 2.0 90/07/05 12:44:20 BUCKLEY EXP $ C>RCS $LOG: CASE.GL,V $ C>RCS REVISION 2.0 90/07/05 12:44:20 BUCKLEY C>RCS COMMON VERSION FOR TOMS AND GL C>RCS C>RCS REVISION 1.9.1.1 89/06/30 14:59:19 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.9 89/06/30 13:30:11 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 16:07:53 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/20 13:48:39 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C## D E S C R I P T I O N: C THIS CONVERTS EACH LOWER CASE ALPHABETIC LETTER TO C UPPER CASE, OR VICE VERSA. C IF TYPE = CTOUPP, CONVERSION IS LOWER TO UPPER C IF TYPE = CTOLOW, CONVERSION IS UPPER TO LOWER C IF TYPE = CTOCAP, USE UPPER FOR FIRST LETTER; LOWER FOR REST C ALL OTHER CHARACTERS ARE LEFT UNCHANGED. C## E N T R Y P O I N T S: THE NATURAL ENTRY TTOUPPR. C## S U B R O U T I N E S: LEN (INTRINSIC). C## P A R A M E T E R S: INTEGER CTOUPP, CTOLOW, CTOCAP PARAMETER ( CTOUPP = 1, CTOLOW = 2, CTOCAP = 3 ) CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) CHARACTER*(*) PERIOD, COMMA, SEMICN PARAMETER ( PERIOD = '.', COMMA = ',', SEMICN = ';' ) CHARACTER*(*) COLON, DASH, EQUALS PARAMETER ( COLON = ':', DASH = '-', EQUALS = '=' ) CHARACTER*(*) OBRACE, CBRACE, UNDERS PARAMETER ( OBRACE = '{', CBRACE = '}', UNDERS = '_' ) CHARACTER*(*) PLUS, MINUS, EXCLAM PARAMETER ( PLUS = '+', MINUS = '-', EXCLAM = '!' ) CHARACTER*(*) GTHAN, LTHAN, QUESMK PARAMETER ( GTHAN = '>', LTHAN = '<', QUESMK = '?' ) CHARACTER*(*) SLASH, BSLASH, PERCNT PARAMETER ( SLASH = '/', BSLASH = '\\',PERCNT = '%' ) CHARACTER*(*) CARAT, ATSIGN, TILDE PARAMETER ( CARAT = '^', ATSIGN = '@', TILDE = '~' ) C## L O C A L D E C L: C==>VAX/BERK4.2 C==>SUN4 C==>SUN3 C==>SSYM C==>VAX/VMS C==>MAC/MS C==>LAHEYF77L C==>HW6 C==>DUMMY INTEGER I, SHIFT LOGICAL FIRST C==>CYBER/FTN5 INTEGER I, TO C==> CHARACTER *1 CH C==>VAX/BERK4.2 C==>SUN4 C==>SUN3 C==>SSYM C==>VAX/VMS C==>MAC/MS C==>LAHEYF77L C==>HW6 C==>DUMMY C## S A V E: SAVE FIRST, SHIFT C==>CYBER/FTN5 C## S A V E: NONE ARE SELECTED. C==> C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C==>CYBER/FTN5 C## D A T A: NONE IS DEFINED. C==>VAX/BERK4.2 C==>SUN4 C==>SUN3 C==>SSYM C==>VAX/VMS C==>MAC/MS C==>LAHEYF77L C==>HW6 C==>DUMMY C## D A T A: DATA FIRST/.TRUE./ C==> C## E X E C U T I O N C## E X E C U T I O N C==>VAX/BERK4.2 C==>SUN4 C==>SUN3 C==>SSYM C==>VAX/VMS C==>MAC/MS C==>LAHEYF77L C==>HW6 C==>DUMMY IF (FIRST) THEN FIRST = .FALSE. SHIFT = ICHAR('A') - ICHAR('a') ENDIF C==> C==> C==>CYBER/FTN5 TO = 1 C==> I = 0 100 I = I + 1 IF ( I .LE. LEN(STRING) ) THEN IF ( TYPE .EQ. CTOUPP ) THEN C==>VAX/BERK4.2 C==>SUN4 C==>SUN3 C==>SSYM C==>VAX/VMS C==>MAC/MS C==>LAHEYF77L C==>HW6 C==>DUMMY IF ('a' .LE. STRING(I:I) .AND. STRING(I:I) .LE. 'z') THEN CH = CHAR( ICHAR(STRING(I:I)) + SHIFT ) ELSE CH = STRING(I:I) ENDIF C==>CYBER/FTN5 CH = STRING(I:I) IF ( CH .EQ. ATSIGN .OR. CH .EQ. CARAT ) THEN I = I + 1 ENDIF STRING(TO:TO) = STRING(I:I) ENDIF TO = TO + 1 GOTO 100 ENDIF C==>VAX/BERK4.2 C==>SUN4 C==>SUN3 C==>SSYM C==>VAX/VMS C==>MAC/MS C==>LAHEYF77L C==>HW6 C==>DUMMY ELSE IF ( TYPE .EQ. CTOLOW .OR. TYPE .EQ. CTOCAP ) THEN IF ('A' .LE. STRING(I:I) .AND. STRING(I:I) .LE. 'Z') THEN CH = CHAR( ICHAR(STRING(I:I)) - SHIFT ) ELSE CH = STRING(I:I) ENDIF ENDIF STRING(I:I) = CH GOTO 100 ENDIF C==>VAX/BERK4.2 C==>SUN4 C==>SUN3 C==>SSYM C==>VAX/VMS C==>MAC/MS C==>LAHEYF77L C==>HW6 C==>DUMMY IF ( TYPE .EQ. CTOCAP .and. - 'a' .LE. STRING(1:1) .AND. STRING(1:1) .LE. 'z') THEN CH = CHAR( ICHAR(STRING(1:1)) + SHIFT ) STRING(1:1) = CH ENDIF C==> C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF TOUPPR. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> datesg.gnc SUBROUTINE ZZdate (CHDATE) C## A R G U M E N T S: CHARACTER *(*) CHDATE C## S T A T U S: C SINGLE/DOUBLE Conversion: NOT required. C SYSTEM DEPENDENCE: System routine for date. C C==>CYBER/FTN5 C THIS VERSION IS FOR CYBER/FTN5 C==>VAX/BERK4.2 C THIS VERSION IS FOR VAX/BERK4.2(3) C==>VAX/VMS C THIS VERSION IS FOR VAX/VMS C==>HW6 C THIS VERSION IS FOR HW6 C==>SUN4 C THIS VERSION IS FOR SUN4 C==>SUN3 C THIS VERSION IS FOR SUN3 C==>SSYM C THIS IS A VERSION FOR Sequent Symmetry C==>MAC/MS C THIS VERSION IS FOR MAC/MS C==>LAHEYF77L C THIS VERSION IS FOR Lahey's F77L for PC's C==> C C>RCS $Header: date.gl,v 2.1 91/11/22 11:45:18 buckley Exp $ C>RCS $Log: date.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:18 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/05 12:50:05 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9 89/06/30 13:30:12 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:26 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:12:13 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:33:41 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:30 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C THIS ROUTINE MUST CALL A SYSTEM ROUTINE TO GET THE CURRENT DATE. C ZZDATE MUST RETURN THIS DATE IN THE CHARACTER VARIABLE CHDATE C IN THE FORM C C (YY+MM+DD) C C AS REQUIRED BY THE ROUTINE ZZDTTM. CHDATE MUST OF LENGTH 10. C ONLY THE 6 CHARACTERS YY MM DD ARE ACTUALLY USED. THE OTHERS C CAN BE ANYTHING, I.E. ONLY THE POSITION OF THE YY MM DD MATTERS. C C THIS MUST CALL A SYSTEM ROUTINE TO GET THE DATE. C TO IMPLEMENT THIS ON ANOTHER SYSTEM, ONE MAY EITHER C C (A) INCORPORATE AN ALTERNATE VERSION OF ZZDATE; C C (B) USE THE "DUMMY" VERSION OF THIS ROUTINE WITH THE SINGLE C EXECUTABLE STATEMENT CHDATE='( + + )', IN WHICH CASE NO C DATE INFORMATION WILL APPEAR IN THE OUTPUT. C## E N T R Y P O I N T S: The natural entry ZZdate. C## S U B R O U T I N E S: System date routine. C==>VAX/VMS C==>CYBER/FTN5 C==>HW6 C==>MAC/MS C==>LAHEYF77L C## P A R A M E T E R S: NONE are defined. C==>VAX/BERK4.2 C==>SUN4 C==>SUN3 C==>SSYM C## P A R A M E T E R S: INTEGER CTOUPP, CTOLOW, CTOCAP PARAMETER ( CTOUPP = 1, CTOLOW = 2, CTOCAP = 3 ) C==> C## L O C A L D E C L: C==>CYBER/FTN5 CHARACTER * 10 DATE C==>VAX/VMS CHARACTER * 9 VAXDAT C==>VAX/BERK4.2 C==>SUN4 C==>SUN3 C==>SSYM CHARACTER * 24 UNXDAT C==>VAX/BERK4.2 C==>SUN4 C==>SUN3 C==>SSYM C==>VAX/VMS CHARACTER * 3 NAME (12), TEMP INTEGER I C==>HW6 CHARACTER * 24 HWDATE INTEGER * 8 CLOCK_ C==>MAC/MS INTEGER MM, DD, YY C==>LAHEYF77L CHARACTER * 8 TODAY C==> C==>CYBER/FTN5 C==>MAC/MS C==>HW6 C==>LAHEYF77L C## S A V E: NONE selected. C==>VAX/VMS C==>VAX/BERK4.2 C==>SUN4 C==>SUN3 C==>SSYM C## S A V E: SAVE NAME C==> C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C==>CYBER/FTN5 C==>MAC/MS C==>HW6 C==>LAHEYF77L C## D A T A: NO DATA VALUES SET. C==>VAX/VMS C==>VAX/BERK4.2 C==>SUN4 C==>SUN3 C==>SSYM C## D A T A: DATA NAME /'JAN','FEB','MAR','APR','MAY','JUN', - 'JUL','AUG','SEP','OCT','NOV','DEC' / C==> C## E X E C U T I O N C## E X E C U T I O N C---- INITIALIZE CHDATE CHDATE = '( + + )' C==>VAX/VMS CALL DATE(VAXDAT) CHDATE(2:3) = VAXDAT(8:9) CHDATE(8:9) = VAXDAT(1:2) TEMP = VAXDAT(4:6) C==>VAX/BERK4.2 C==>SUN4 C==>SUN3 C==>SSYM CALL FDATE(UNXDAT) CHDATE(2:3) = UNXDAT(23:24) CHDATE(8:9) = UNXDAT(9:10) TEMP = UNXDAT(5:7) CALL ZZCASE(TEMP, CTOUPP) C==>VAX/VMS C==>VAX/BERK4.2 C==>SUN4 C==>SUN3 C==>SSYM DO 100 I = 1,12 IF ( TEMP .EQ. NAME(I) ) THEN WRITE ( CHDATE(5:6), '(I2.2)' ) I GOTO 90000 ENDIF 100 CONTINUE C==>CYBER/FTN5 CHDATE = DATE() C==>HW6 CALL DATE_TIME_ (CLOCK_(), HWDATE) CHDATE(2:3) = HWDATE(7:8) CHDATE(5:6) = HWDATE(1:2) CHDATE(8:9) = HWDATE(4:5) C==>MAC/MS CALL DATE ( MM, DD, YY ) WRITE ( CHDATE(2:3), '(I2.2)' ) YY WRITE ( CHDATE(5:6), '(I2.2)' ) MM WRITE ( CHDATE(8:9), '(I2.2)' ) DD C==>LAHEYF77L C Lahey's routine DATE returns an 8-character string containing C MM / DD / YY CALL DATE ( TODAY ) CHDATE(2:3) = TODAY(7:8) CHDATE(5:6) = TODAY(1:2) CHDATE(8:9) = TODAY(4:5) C==>DUMMY C TO DO A QUICKIE CONVERSION FOR A NEW SYSTEM, JUST SET C CHDATE TO A DUMMY BLANK VALUE. CHDATE = '( + + )' C==> C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZdate. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> mparsg.gnc REAL FUNCTION ZZMPAR(I) C!!!! DOUBLE PRECISION FUNCTION ZZMPAR(I) C## A R G U M E N T S: INTEGER I C## S T A T U S: C IGNORE LINES BEGINNING WITH "C!!!!" . C C SYSTEM DEPENDENCE: THE CODE IS VERY DEFINITELY MACHINE DEPENDENT C FOR IT CONTAINS MACHINE PRECISION CONSTANTS C FOR MANY MACHINES, AS DESCRIBED BELOW. C C SINGLE/DOUBLE Conversion: NEEDED (SEE CONVRT). C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C>RCS $Header: mpar.gl,v 2.3 91/11/22 11:45:19 buckley Exp $ C>RCS $Log: mpar.gl,v $ C>RCS Revision 2.3 91/11/22 11:45:19 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.2 91/06/12 14:07:08 buckley C>RCS Added stardent C>RCS C>RCS Revision 2.1 90/07/31 10:57:40 buckley C>RCS Added constants for ieee for pc's C>RCS C>RCS Revision 2.0 90/07/06 10:39:26 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9.1.2 90/06/26 14:24:24 buckley C>RCS Fixed single/double precision constants for sun4 C>RCS C>RCS Revision 1.9.1.1 89/07/01 11:36:48 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.9 89/06/30 13:30:15 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:28 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:23 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:34:59 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:31 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C C THIS IS A MODIFICATION OF THE TWO ROUTINES DPMPAR AND SPMPAR C OBTAINED FROM JORGE MORE. IT HAS BEEN CHANGED ONLY TO CONFORM C WITH MY CONVENTIONS, AND TO ADD STATEMENTS FOR THE CDC C CYBERS WHICH ARE ACCEPTABLE TO FTN5 (FORTRAN '77). THE C OTHER CHANGES ARE: C C 1. THE SINGLE NAME ZZMPAR HAS BEEN USED. IT IS DOUBLE OR SINGLE C PRECISION ACCORDING TO CONVERSION BY CONVRT, JUST AS FOR ALL C OF MY OTHER PROGRAMS. C C 2. THE ROUTINES HAVE BEEN MERGED SO THAT SINGLE AND DOUBLE C PRECISION STATEMENTS WHICH CORRESPOND APPEAR IN PAIRS. C C OTHERWISE ALL OF THE COMMENTS OF THE ORIGINAL AUTHORS APPLY. C THEIR ORIGINAL COMMENTS (UNALTERED) FOR THE DOUBLE PRECISION C VERSION FOLLOW IMMEDIATELY. C C FUNCTION DPMPAR C C THIS FUNCTION PROVIDES DOUBLE PRECISION MACHINE PARAMETERS C WHEN THE APPROPRIATE SET OF DATA STATEMENTS IS ACTIVATED (BY C REMOVING THE C FROM COLUMN 1) AND ALL OTHER DATA STATEMENTS ARE C RENDERED INACTIVE. MOST OF THE PARAMETER VALUES WERE OBTAINED C FROM THE CORRESPONDING BELL LABORATORIES PORT LIBRARY FUNCTION. C C THE FUNCTION STATEMENT IS C C DOUBLE PRECISION FUNCTION DPMPAR(I) C C WHERE C C I IS AN INTEGER INPUT VARIABLE SET TO 1, 2, OR 3 WHICH C SELECTS THE DESIRED MACHINE PARAMETER. IF THE MACHINE HAS C T BASE B DIGITS AND ITS SMALLEST AND LARGEST EXPONENTS ARE C EMIN AND EMAX, RESPECTIVELY, THEN THESE PARAMETERS ARE C C DPMPAR(1) B**(1 - T), THE MACHINE PRECISION, C C DPMPAR(2) B**(EMIN - 1), THE SMALLEST MAGNITUDE, C C DPMPAR(3) B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE C C## E N T R Y P O I N T S: The natural entry ZZmpar. C## S U B R O U T I N E S: NONE are called. C## P A R A M E T E R S: NONE are defined. C C## L O C A L D E C L: C NOTE THAT THESE ARRAYS MUST HAVE DIMENSIONS 2 AND 4, RATHER C THAN 1 AND 2 AS ONE MIGHT EXPECT, BECAUSE OF THE PDP-11 C DEFINITIONS. INTEGER MCHEPS(2) C!!!! INTEGER MCHEPS(4) INTEGER MINMAG(2) C!!!! INTEGER MINMAG(4) INTEGER MAXMAG(2) C!!!! INTEGER MAXMAG(4) REAL RMACH(3) C!!!! DOUBLE PRECISION DMACH(3) INTEGER EMIN, EMAX, IMACH(10) REAL B, BINV, BM1, ONE, W, Z C!!!! DOUBLE PRECISION B, BINV, BM1, ONE, W, Z C## S A V E: SAVE RMACH C!!!! SAVE DMACH SAVE IMACH C## E Q U I V A L E N C E S: EQUIVALENCE (RMACH(1),MCHEPS(1)) C!!!! EQUIVALENCE (DMACH(1),MCHEPS(1)) EQUIVALENCE (RMACH(2),MINMAG(1)) C!!!! EQUIVALENCE (DMACH(2),MINMAG(1)) EQUIVALENCE (RMACH(3),MAXMAG(1)) C!!!! EQUIVALENCE (DMACH(3),MAXMAG(1)) C## C O M M O N: NONE is defined. C## D A T A: C==>IBM 360/370 C==>AMDAHL 470/V6 C==>ICL 2900 C==>ITEL A/6 C==>XEROX SIGMA 5/7/9 C==>SEL 85/86 C-----MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, C THE AMDAHL 470/V6, THE ICL 2900, THE ITEL AS/6, C THE XEROX SIGMA 5/7/9 AND THE SEL SYSTEMS 85/86. DATA RMACH(1) / Z3C100000 / C!!!! DATA MCHEPS(1),MCHEPS(2) / Z34100000, Z00000000 / DATA RMACH(2) / Z00100000 / C!!!! DATA MINMAG(1),MINMAG(2) / Z00100000, Z00000000 / DATA RMACH(3) / Z7FFFFFFF / C!!!! DATA MAXMAG(1),MAXMAG(2) / Z7FFFFFFF, ZFFFFFFFF / C==>HW6 C-----MACHINE CONSTANTS FOR THE HONEYWELL 60/600/6000 SERIES. DATA RMACH(1) / O716400000000 / C!!!! DATA MCHEPS(1),MCHEPS(2) / O606400000000, O000000000000 / DATA RMACH(2) / O402400000000 / C!!!! DATA MINMAG(1),MINMAG(2) / O402400000000, O000000000000 / DATA RMACH(3) / O376777777777 / C!!!! DATA MAXMAG(1),MAXMAG(2) / O376777777777, O777777777777 / C==>CYBER/FTN5 C-----MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES (FTN 5). C-----SAME FOR CYBER 800/900 SERIES IN 60 BIT MODE (NOS) C!!!! DATA MCHEPS(1) / O"15614000000000000000" / DATA RMACH(1) / O"16414000000000000000" / C!!!! DATA MCHEPS(2) / O"15010000000000000000" / C!!!! DATA MINMAG(1) / O"00604000000000000000" / DATA RMACH(2) / O"00014000000000000000" / C!!!! DATA MINMAG(2) / O"00000000000000000000" / C!!!! DATA MAXMAG(1) / O"37767777777777777777" / DATA RMACH(3) / O"37767777777777777777" / C!!!! DATA MAXMAG(2) / O"37167777777777777777" / C==>CYBER/FTN4 C-----MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES (FTN 4). C!!!! DATA MCHEPS(1) / 15614000000000000000B / DATA RMACH(1) / 16414000000000000000B / C!!!! DATA MCHEPS(2) / 15010000000000000000B / C!!!! DATA MINMAG(1) / 00604000000000000000B / DATA RMACH(2) / 00014000000000000000B / C!!!! DATA MINMAG(2) / 00000000000000000000B / C!!!! DATA MAXMAG(1) / 37767777777777777777B / DATA RMACH(3) / 37767777777777777777B / C!!!! DATA MAXMAG(2) / 37167777777777777777B / C==>PDP-10-KA C-----MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR). DATA RMACH(1) / "147400000000 / C!!!! DATA MCHEPS(1),MCHEPS(2) / "114400000000, "000000000000 / DATA RMACH(2) / "000400000000 / C!!!! DATA MINMAG(1),MINMAG(2) / "033400000000, "000000000000 / DATA RMACH(3) / "377777777777 / C!!!! DATA MAXMAG(1),MAXMAG(2) / "377777777777, "344777777777 / C==>PDP-10-KI C-----MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR). DATA RMACH(1) / "147400000000 / C!!!! DATA MCHEPS(1),MCHEPS(2) / "104400000000, "000000000000 / DATA RMACH(2) / "000400000000 / C!!!! DATA MINMAG(1),MINMAG(2) / "000400000000, "000000000000 / DATA RMACH(3) / "377777777777 / C!!!! DATA MAXMAG(1),MAXMAG(2) / "377777777777, "377777777777 / C==>PDP-11 C-----MACHINE CONSTANTS FOR THE PDP-11. DATA MCHEPS(1),MCHEPS(2) / 13568, 0 / C!!!! DATA MCHEPS(1),MCHEPS(2),MCHEPS(3),MCHEPS(4) / 9472, 0, 0, 0 / DATA MINMAG(1),MINMAG(2) / 128, 0 / C!!!! DATA MINMAG(1),MINMAG(2),MINMAG(3),MINMAG(4) / 128, 0, 0, 0 / DATA MAXMAG(1),MAXMAG(2) / 32767,-1 / C!!!! DATA MAXMAG(1),MAXMAG(2),MAXMAG(3),MAXMAG(4) / 32767,-1,-1,-1 / C==>BURROUGHS 67/7700 C-----MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS. DATA RMACH(1) / O1301000000000000 / C!!!! DATA MCHEPS(1),MCHEPS(2) / O1451000000000000, O0000000000000000 / DATA RMACH(2) / O1771000000000000 / C!!!! DATA MINMAG(1),MINMAG(2) / O1771000000000000, O7770000000000000 / DATA RMACH(3) / O0777777777777777 / C!!!! DATA MAXMAG(1),MAXMAG(2) / O0777777777777777, O7777777777777777 / C==>BURROUGHS 5700 C-----MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM. DATA RMACH(1) / O1301000000000000 / C!!!! DATA MCHEPS(1),MCHEPS(2) / O1451000000000000, O0000000000000000 / DATA RMACH(2) / O1771000000000000 / C!!!! DATA MINMAG(1),MINMAG(2) / O1771000000000000, O0000000000000000 / DATA RMACH(3) / O0777777777777777 / C!!!! DATA MAXMAG(1),MAXMAG(2) / O0777777777777777, O0007777777777777 / C==>BURROUGHS 1700 C-----MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. DATA RMACH(1) / Z4EA800000 / C!!!! DATA MCHEPS(1),MCHEPS(2) / ZCC6800000, Z000000000 / DATA RMACH(2) / Z400800000 / C!!!! DATA MINMAG(1),MINMAG(2) / ZC00800000, Z000000000 / DATA RMACH(3) / Z5FFFFFFFF / C!!!! DATA MAXMAG(1),MAXMAG(2) / ZDFFFFFFFF, ZFFFFFFFFF / C==>UNIVAC 1100 C-----MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. DATA RMACH(1) / O147400000000 / C!!!! DATA MCHEPS(1),MCHEPS(2) / O170640000000, O000000000000 / DATA RMACH(2) / O000400000000 / C!!!! DATA MINMAG(1),MINMAG(2) / O000040000000, O000000000000 / DATA RMACH(3) / O377777777777 / C!!!! DATA MAXMAG(1),MAXMAG(2) / O377777777777, O777777777777 / C==>DG ECLIPSE S/200 C-----MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200. C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - C STATIC RMACH(3) C!!!! STATIC DMACH(3) DATA MINMAG / 20K, 0 /, MAXMAG / 77777K, 177777K / C!!!! DATA MINMAG / 20K, 3*0 /, MAXMAG / 77777K, 3 * 177777K / DATA MCHEPS / 36020K, 0 / C!!!! DATA MCHEPS / 32020K, 3*0 / C==>HARRIS 220 C-----MACHINE CONSTANTS FOR THE HARRIS 220. DATA MCHEPS(1),MCHEPS(2) / '20000000, '00000353 / C!!!! DATA MCHEPS(1),MCHEPS(2) / '20000000, '00000334 / DATA MINMAG(1),MINMAG(2) / '20000000, '00000201 / C!!!! DATA MINMAG(1),MINMAG(2) / '20000000, '00000201 / DATA MAXMAG(1),MAXMAG(2) / '37777777, '00000177 / C!!!! DATA MAXMAG(1),MAXMAG(2) / '37777777, '37777577 / C==>CRAY-1 C-----MACHINE CONSTANTS FOR THE CRAY-1. C!!!! DATA MCHEPS(1) / 0376424000000000000000B / DATA RMACH(1) / 0377224000000000000000B / C!!!! DATA MCHEPS(2) / 0000000000000000000000B / C!!!! DATA MINMAG(1) / 0200034000000000000000B / DATA RMACH(2) / 0200034000000000000000B / C!!!! DATA MINMAG(2) / 0000000000000000000000B / C!!!! DATA MAXMAG(1) / 0577777777777777777777B / DATA RMACH(3) / 0577777777777777777776B / C!!!! DATA MAXMAG(2) / 0000007777777777777776B / C==>PRIME 400 C-----MACHINE CONSTANTS FOR THE PRIME 400. DATA MCHEPS(1) / :10000000153 / C!!!! DATA MCHEPS(1),MCHEPS(2) / :10000000000, :00000000123 / DATA MINMAG(1) / :10000000000 / C!!!! DATA MINMAG(1),MINMAG(2) / :10000000000, :00000100000 / DATA MAXMAG(1) / :17777777777 / C!!!! DATA MAXMAG(1),MAXMAG(2) / :17777777777, :37777677776 / C==>VAX/VMS C==>VAX/BERK4.2 C-----MACHINE CONSTANTS FOR THE VAX-11. DATA MCHEPS(1) / 13568 / C!!!! DATA MCHEPS(1),MCHEPS(2) / 9472, 0 / DATA MINMAG(1) / 128 / C!!!! DATA MINMAG(1),MINMAG(2) / 128, 0 / DATA MAXMAG(1) / -32769 / C!!!! DATA MAXMAG(1),MAXMAG(2) / -32769, -1 / C==>STARDENT C-----MACHINE CONSTANTS FOR THE STARDENT MACHINES. DATA MCHEPS(1) / '34000000'X/ C!!!! DATA MCHEPS(1),MCHEPS(2) / '3CB00000'X, '00000000'X / DATA MINMAG(1) / '00800000'X / C!!!! DATA MINMAG(1),MINMAG(2) / '00100000'X, '00000000'X / DATA MAXMAG(1) / '7F7FFFFF'X / C!!!! DATA MAXMAG(1),MAXMAG(2) / '7FEFFFFF'X, 'FFFFFFFF'X/ C==>SUN4 C-----MACHINE CONSTANTS FOR THE SUN-4. DATA MCHEPS(1) / X'34000000'/ C!!!! DATA MCHEPS(1),MCHEPS(2) / X'3CB00000', X'00000000' / DATA MINMAG(1) / X'00800000' / C!!!! DATA MINMAG(1),MINMAG(2) / X'00100000', X'00000000' / DATA MAXMAG(1) / X'7F7FFFFF' / C!!!! DATA MAXMAG(1),MAXMAG(2) / X'7FEFFFFF', X'FFFFFFFF'/ C==>MAC/MS C==>SUN3 C-----MACHINE CONSTANTS FOR THE APPLE MACINTOSH WITH C MICROSOFT FORTRAN (AS DEVELOPED BY ABSOFT). C THESE SHOULD BE THE SAME FOR ANY 68000/68020. DATA MCHEPS(1) / O'06400000000' / C!!!! DATA MCHEPS(1),MCHEPS(2) / O'07454000000', O'00000000000' / DATA MINMAG(1) / O'00040000000' / C!!!! DATA MINMAG(1),MINMAG(2) / O'00004000000', O'00000000000' / DATA MAXMAG(1) / O'17737777777' / C!!!! DATA MAXMAG(1),MAXMAG(2) / O'17773777777', O'37777777777' / C==>LAHEYF77L C==>PC/MS C==>PC/PROF C==>PC/RM C==>SSYM C-----MACHINE CONSTANTS FOR machines conforming to the IEEE standard C FOR IBM PC WITH Laheyf77l, Microsoft Fortran, Professional C Fortran, or Ryan MacFarland. DATA RMACH(1) /5.96045E-08 / C!!!! DATA DMACH(1) /1.11022302D-16 / DATA RMACH(2) /1.17549E-38/ C!!!! DATA DMACH(2) /2.23D-308/ DATA RMACH(3) /3.40282E+38 / C!!!! DATA DMACH(3) /1.79769313D+308 / C==>CDC/NOSVE C MACHINE CONSTANTS FOR THE CDC CYBER 995 64 BIT C ARITHMETIC (NOS/VE OPERATING SYSTEM). C DATA IMACH( 1) / 2 / DATA IMACH( 2) / 63 / DATA IMACH( 3) / 9223372036854775807 / DATA IMACH( 4) / 2 / DATA IMACH( 5) / 48 / DATA IMACH( 6) / -4096 / DATA IMACH( 7) / 4095 / DATA IMACH( 8) / 96 / DATA IMACH( 9) / -4096 / DATA IMACH(10) / 4095 / C==>HP2100W3 C MACHINE CONSTANTS FOR THE HP 2100 C 3 WORD DOUBLE PRECISION OPTION WITH FTN4 C DATA IMACH( 1) / 2 / DATA IMACH( 2) / 15 / DATA IMACH( 3) / 32767 / DATA IMACH( 4) / 2 / DATA IMACH( 5) / 23 / DATA IMACH( 6) / -128 / DATA IMACH( 7) / 127 / DATA IMACH( 8) / 39 / DATA IMACH( 9) / -128 / DATA IMACH(10) / 127 / C==>HP2100W4 C MACHINE CONSTANTS FOR THE HP 2100 C 4 WORD DOUBLE PRECISION OPTION WITH FTN4 C DATA IMACH( 1) / 2 / DATA IMACH( 2) / 15 / DATA IMACH( 3) / 32767 / DATA IMACH( 4) / 2 / DATA IMACH( 5) / 23 / DATA IMACH( 6) / -128 / DATA IMACH( 7) / 127 / DATA IMACH( 8) / 55 / DATA IMACH( 9) / -128 / DATA IMACH(10) / 127 / C==>HP9000 C MACHINE CONSTANTS FOR THE HP 9000. C DATA IMACH( 1) / 2 / DATA IMACH( 2) / 31 / DATA IMACH( 3) / 2147483647 / DATA IMACH( 4) / 2 / DATA IMACH( 5) / 24 / DATA IMACH( 6) / -126 / DATA IMACH( 7) / 128 / DATA IMACH( 8) / 53 / DATA IMACH( 9) / -1021 / DATA IMACH(10) / 1024 / C==>PDP11/32 C MACHINE CONSTANTS FOR THE PDP-11 FORTRAN SUPPORTING C 32-BIT INTEGER ARITHMETIC. C DATA IMACH( 1) / 2 / DATA IMACH( 2) / 31 / DATA IMACH( 3) / 2147483647 / DATA IMACH( 4) / 2 / DATA IMACH( 5) / 24 / DATA IMACH( 6) / -127 / DATA IMACH( 7) / 127 / DATA IMACH( 8) / 56 / DATA IMACH( 9) / -127 / DATA IMACH(10) / 127 / C==PDP11/16 C C MACHINE CONSTANTS FOR THE PDP-11 FORTRAN SUPPORTING C 16-BIT INTEGER ARITHMETIC. C DATA IMACH( 1) / 2 / DATA IMACH( 2) / 15 / DATA IMACH( 3) / 32767 / DATA IMACH( 4) / 2 / DATA IMACH( 5) / 24 / DATA IMACH( 6) / -127 / DATA IMACH( 7) / 127 / DATA IMACH( 8) / 56 / DATA IMACH( 9) / -127 / DATA IMACH(10) / 127 / C==> C## E X E C U T I O N C## E X E C U T I O N C==>IBM 360/370 C==>AMDAHL 470/V6 C==>ICL 2900 C==>ITEL A/6 C==>XEROX SIGMA 5/7/9 C==>SEL 85/86 C==>HW6 C==>CYBER/FTN5 C==>CYBER/FTN4 C==>PDP-10-KA C==>PDP-10-KI C==>PDP-11 C==>BURROUGHS 67/7700 C==>BURROUGHS 5700 C==>BURROUGHS 1700 C==>UNIVAC 1100 C==>DG ECLIPSE S/200 C==>HARRIS 220 C==>CRAY-1 C==>PRIME 400 C==>VAX/VMS C==>VAX/BERK4.2 C==>SUN4 C==>MAC/MS C==>SUN3 C==>LAHEYF77L C==>PC/MS C==>PC/PROF C==>PC/RM ZZMPAR = RMACH(I) C!!!! ZZMPAR = DMACH(I) C==>CDC/NOSVE C==>HP2100W3 C==>HP2100W4 C==>HP9000 C==>PDP11/32 C==>PDP11/16 C If (I.LE.1) Then B = IMACH(4) M = M = IMACH(5) C!!!!IMACH(8) ZZMPAR = B ** (1-M) GOTO 90000 End If C If (I.LE.2) Then B = IMACH(4) EMIN EMIN = IMACH(6) C!!!! = IMACH(9) ONE = FLOAT(1) BINV = ONE / B W = B ** (EMIN+2) ZZMPAR = ((W*BINV)*BINV) * BINV GOTO 90000 End If C IBETA = IMACH(4) M = IMACH(5) C!!!! M = IMACH(8) EMAX = IMACH(7) C!!!! EMAX = IMACH(10) C B = IBETA BM1 = IBETA - 1 ONE = FLOAT(1) Z = B ** (M-1) W = ((Z-ONE)*B+BM1) / (B*Z) C Z = B ** (EMAX-2) ZZMPAR = ((W*Z)*B) * B C==> C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZmpar. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> opensg.gnc SUBROUTINE ZZOPEN ( IUNIT, FLAG, INAME, * , RECLEN ) C## A R G U M E N T S: INTEGER IUNIT, RECLEN LOGICAL FLAG CHARACTER *(*) INAME C## S T A T U S: C IGNORE LINES BEGINNING WITH "C!!!!" . C C SINGLE/DOUBLE Conversion: NEEDED (SEE CONVRT). C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR C OPENING AND CLOSING FILES. C C==>CYBER/FTN5 C THIS VERSION IS FOR CYBER/FTN5 C==>VAX/BERK4.2 C THIS VERSION IS FOR VAX/BERK4.2(3) C==>VAX/VMS C THIS VERSION IS FOR VAX/VMS C==>HW6 C THIS VERSION IS FOR HW6 C==>SUN4 C THIS VERSION IS FOR SUN4 C==>SUN3 C THIS VERSION IS FOR SUN3 C==>SSYM C THIS IS A VERSION FOR Sequent Symmetry C==>MAC/MS C THIS VERSION IS FOR MAC/MS C==>LAHEYF77L C THIS VERSION IS FOR Lahey's F77L for PC's C C==> C C>RCS $Header: open.gl,v 2.1 91/11/22 11:45:21 buckley Exp $ C>RCS $Log: open.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:21 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/06 10:43:19 buckley C>RCS Common version for TOMS and MT C>RCS C>RCS Revision 1.9.1.2 89/07/01 11:51:41 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.9.1.1 89/07/01 11:36:50 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.9 89/06/30 13:30:16 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:29 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:26 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:02 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:31 buckley C>RCS Initial revision C>RCS C## D E S C R I P T I O N: C C THIS OPENS THE FILES NEEDED FOR TESTPACK AND KEEPS TRACK OF C WHICH ARE OPEN AND WHICH ARE NOT. IT ALSO SUPPLIES THE APPRO- C PRIATE ARGUMENTS FOR EACH FILE. C C IF NAME IS NOT BLANK ON ENTRY, THEN THE FILE IS OPENED C WITH THE NAME GIVEN. OTHERWISE, NO NAME IS SPECIFIED WHEN C OPENING THE FILE. C C THE OPEN IS ONLY DONE IF "FLAG" IS TRUE. C C IF RECLEN IS NOT EQUAL TO ZERO, THEN THE FILE IS OPENED C AS DIRECT ACCESS UNFORMATTED. C C IF RECLEN IS EQUAL TO ZERO, THEN THE FILE IS OPENED C FOR FORMATTED SEQUENTIAL ACCESS. C C## E N T R Y P O I N T S: The natural entry ZZopen and ZZclse C## S U B R O U T I N E S: OPEN, CLOSE, REAL ...INTRINSIC C ZZERRM ...FOR ERROR MESSAGES. C## P A R A M E T E R S: INTEGER FILENL, NFILES PARAMETER ( FILENL = 80, NFILES = 15 ) CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) CHARACTER*(*) PERIOD, COMMA, SEMICN PARAMETER ( PERIOD = '.', COMMA = ',', SEMICN = ';' ) CHARACTER*(*) COLON, DASH, EQUALS PARAMETER ( COLON = ':', DASH = '-', EQUALS = '=' ) CHARACTER*(*) OBRACE, CBRACE, UNDERS PARAMETER ( OBRACE = '{', CBRACE = '}', UNDERS = '_' ) CHARACTER*(*) PLUS, MINUS, EXCLAM PARAMETER ( PLUS = '+', MINUS = '-', EXCLAM = '!' ) CHARACTER*(*) GTHAN, LTHAN, QUESMK PARAMETER ( GTHAN = '>', LTHAN = '<', QUESMK = '?' ) CHARACTER*(*) SLASH, BSLASH, PERCNT PARAMETER ( SLASH = '/', BSLASH = '\\',PERCNT = '%' ) CHARACTER*(*) CARAT, ATSIGN, TILDE PARAMETER ( CARAT = '^', ATSIGN = '@', TILDE = '~' ) LOGICAL T, F PARAMETER ( T = .TRUE., F = .FALSE. ) CHARACTER*(*) TRUE, QT, FALSE, QF PARAMETER ( TRUE = 'TRUE', QT = 'T', FALSE = 'FALSE', QF = 'F' ) INTEGER ITRUE, IFALSE PARAMETER ( ITRUE = 1, IFALSE = 0 ) REAL RTRUE, RFALSE C!!!! DOUBLE PRECISION RTRUE, RFALSE PARAMETER ( RTRUE = 1.D0, RFALSE = 0.D0 ) INTEGER CTOUPP, CTOLOW, CTOCAP PARAMETER ( CTOUPP = 1, CTOLOW = 2, CTOCAP = 3 ) INTEGER PREPRC, DAUF, INPTUN PARAMETER ( PREPRC = 1, DAUF = 2, INPTUN = 3 ) INTEGER TEMPUN, STDIN, TRMOUT PARAMETER ( TEMPUN = 4, STDIN = 5, TRMOUT = 6 ) INTEGER WRITUN, TRACUN, SUMMUN PARAMETER ( WRITUN = 7, TRACUN = 8, SUMMUN = 9 ) INTEGER COPYUN, TEXUN PARAMETER ( COPYUN =10, TEXUN =11 ) C==>CYBER/FTN5 C THIS REDUCES I/O BUFFER SIZES FOR THE C CYBER AND HENCE MEMORY REQUIREMENTS. INTEGER BUFLEN PARAMETER ( BUFLEN = 100 ) C==> CHARACTER *(*) SEQ , DIR PARAMETER ( SEQ = 'SEQUENTIAL', DIR = 'DIRECT' ) CHARACTER *(*) UNKN , NEW PARAMETER ( UNKN = 'UNKNOWN' , NEW = 'NEW' ) CHARACTER *(*) OLD , SCR PARAMETER ( OLD = 'OLD' , SCR = 'SCRATCH' ) CHARACTER *(*) DEL , KEEP PARAMETER ( DEL = 'DELETE' , KEEP = 'KEEP' ) CHARACTER *(*) FMT , UNFRMT PARAMETER ( FMT = 'FORMATTED' , UNFRMT = 'UNFORMATTED' ) C==> C## L O C A L D E C L: INTEGER ERRINT, UNIT LOGICAL OPENFS(NFILES), REW, OPENIT, COPY CHARACTER STAT*7, ACCS*10, FRMT*11 CHARACTER *(FILENL) COPYNM, NAME REAL RD C!!!! DOUBLE PRECISION RD C## S A V E: SAVE OPENFS, COPY, COPYNM C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA OPENFS / NFILES * .FALSE. / DATA COPY/F/, COPYNM/BLANK/ C## E X E C U T I O N C## E X E C U T I O N C----- DEFINE A STATEMENT FUNCTION. RD(UNIT) = REAL(UNIT) C!!!! RD(UNIT) = DBLE(UNIT) IF ( FLAG ) THEN IF ( RECLEN .EQ. 0 ) THEN ACCS = SEQ FRMT = FMT ELSE ACCS = DIR FRMT = UNFRMT ENDIF UNIT = IUNIT NAME = INAME 100 CONTINUE OPENIT = .NOT. OPENFS(UNIT) REW = .FALSE. IF ( UNIT .EQ. SUMMUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. TRMOUT ) THEN C==>DUMMY C==>CYBER/FTN5 C==>VAX/VMS C==>MAC/MS C==>LAHEYF77L STAT = UNKN C==>VAX/BERK4.2 C==>SUN4 C==>SUN3 C==>SSYM C==>HW6 OPENIT = .FALSE. C==> ELSE IF ( UNIT .EQ. STDIN ) THEN C==>DUMMY C==>CYBER/FTN5 C==>VAX/VMS C==>MAC/MS C==>LAHEYF77L STAT = UNKN C==>VAX/BERK4.2 C==>SUN4 C==>SUN3 C==>SSYM C==>HW6 OPENIT = .FALSE. C==> ELSE IF ( UNIT .EQ. PREPRC) THEN STAT = OLD REW = .TRUE. ELSE IF ( UNIT .EQ. TEMPUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. WRITUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. TRACUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. DAUF ) THEN STAT = OLD ELSE IF ( UNIT .EQ. COPYUN ) THEN STAT = UNKN COPY = T ELSE IF ( UNIT .EQ. INPTUN ) THEN STAT = OLD REW = .TRUE. ELSE CALL ZZERRM ( RD(UNIT), *91000, - 'IS REQUEST TO OPEN UNKNOWN UNIT # ' ) ENDIF C FOR THE "CHOICE OF UNIT..." 500 IF ( OPENIT ) THEN C==>VAX/BERK4.2 C==>SUN4 C==>SUN3 C==>SSYM CALL ZZCASE ( STAT, CTOLOW ) CALL ZZCASE ( ACCS, CTOLOW ) CALL ZZCASE ( FRMT, CTOLOW ) C==> IF ( NAME .EQ. BLANK ) THEN C PRINT*,'OPENING ',UNIT,'NAME=' IF ( RECLEN .EQ. 0 ) THEN OPEN ( UNIT = UNIT, - ERR = 1000, - IOSTAT = ERRINT, - STATUS = STAT, - ACCESS = ACCS, C==>DUMMY C==>VAX/BERK4.2 C==>SUN4 C==>SUN3 C==>SSYM C==>VAX/VMS C==>MAC/MS C==>LAHEYF77L C==>HW6 - FORM = FRMT ) C==>CYBER/FTN5 - FORM = FRMT, - BUFL = BUFLEN ) C==> ELSE OPEN ( UNIT = UNIT, - ERR = 1000, - IOSTAT = ERRINT, - STATUS = STAT, - ACCESS = ACCS, - RECL = RECLEN, C==>DUMMY C==>VAX/BERK4.2 C==>SUN4 C==>SUN3 C==>SSYM C==>VAX/VMS C==>MAC/MS C==>LAHEYF77L C==>HW6 - FORM = FRMT ) C==>CYBER/FTN5 - FORM = FRMT, - BUFL = BUFLEN ) C==> ENDIF ELSE C NAMED FILE IF ( RECLEN .EQ. 0 ) THEN C PRINT*,'OPENING ',UNIT,'NAME=',NAME(1:20) OPEN ( UNIT = UNIT, - ERR = 1000, - IOSTAT = ERRINT, - FILE = NAME, - STATUS = STAT, - ACCESS = ACCS, C==>DUMMY C==>VAX/BERK4.2 C==>SUN4 C==>SUN3 C==>SSYM C==>VAX/VMS C==>MAC/MS C==>LAHEYF77L C==>HW6 - FORM = FRMT ) C==>CYBER/FTN5 - FORM = FRMT, - BUFL = BUFLEN ) C==> C PRINT*,'OK' ELSE OPEN ( UNIT = UNIT, - ERR = 1000, - FILE = NAME, - IOSTAT = ERRINT, - STATUS = STAT, - ACCESS = ACCS, - RECL = RECLEN, C==>DUMMY C==>VAX/BERK4.2 C==>SUN4 C==>SUN3 C==>SSYM C==>VAX/VMS C==>MAC/MS C==>LAHEYF77L C==>HW6 - FORM = FRMT ) C==>CYBER/FTN5 - FORM = FRMT, - BUFL = BUFLEN ) C==> ENDIF ENDIF ENDIF C FOR EACH UNIT FROM 1 TO NFILES WE NEED TO KEEP A RECORD OF C WHETHER IT IS CURRENTLY OPEN. OPENFS(UNIT) = .TRUE. IF ( REW .AND. RECLEN .EQ. 0 ) THEN REWIND UNIT ENDIF GOTO 1025 1000 IF ( UNIT .EQ. DAUF ) THEN C CREATE THE DAUF. STAT = NEW GOTO 500 ELSE GOTO 1050 ENDIF 1025 CONTINUE IF ( COPY .AND. UNIT .EQ. STDIN ) THEN UNIT = COPYUN NAME = COPYNM GOTO 100 ENDIF ENDIF C FOR THE "IF FLAG..." GOTO 90000 1050 CONTINUE GOTO 91000 C## E N T R Y ZZCLSE: ENTRY ZZCLSE ( IUNIT, * ) STAT = KEEP IF ( IUNIT .EQ. SUMMUN ) THEN STAT = KEEP C==>DUMMY C==>CYBER/FTN5 C==>VAX/VMS C==>MAC/MS C==>LAHEYF77L C==>HW6 ELSE IF ( IUNIT .EQ. TRMOUT ) THEN ELSE IF ( IUNIT .EQ. STDIN ) THEN C==>VAX/BERK4.2 C==>SUN4 C==>SUN3 C==>SSYM ELSE IF ( IUNIT .EQ. TRMOUT ) THEN OPENFS(TRMOUT) = .FALSE. ELSE IF ( IUNIT .EQ. STDIN ) THEN OPENFS(STDIN ) = .FALSE. C==> ELSE IF ( IUNIT .EQ. TEMPUN ) THEN STAT = KEEP ELSE IF ( IUNIT .EQ. WRITUN ) THEN ELSE IF ( IUNIT .EQ. TRACUN ) THEN ELSE IF ( IUNIT .EQ. COPYUN ) THEN STAT = KEEP COPY = F ELSE IF ( IUNIT .EQ. DAUF ) THEN ELSE IF ( IUNIT .EQ. PREPRC ) THEN ELSE IF ( IUNIT .EQ. INPTUN ) THEN ELSE CALL ZZERRM ( RD(IUNIT), *91000, - 'IS IGNORING REQUEST TO CLOSE UNKNOWN UNIT #' ) ENDIF IF ( OPENFS(IUNIT) ) THEN C==>VAX/BERK4.2 C==>SUN4 C==>SUN3 C==>SSYM CALL ZZCASE ( STAT, CTOLOW ) C==> C PRINT*,'CLOSING ',IUNIT CLOSE ( UNIT = IUNIT, STATUS = STAT ) OPENFS(IUNIT) = .FALSE. ENDIF RETURN C## E X I T 90000 CONTINUE CALL ZZCASE (STAT,CTOUPP) IF ( IUNIT .EQ. DAUF .AND. STAT .EQ. NEW ) THEN GOTO 91000 ELSE RETURN ENDIF 91000 RETURN 1 C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZOPEN. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> reclsg.gnc INTEGER FUNCTION ZZRECL ( CPERLN, IPERLN, LPERLN, RPERLN ) C## A R G U M E N T S: INTEGER CPERLN, IPERLN, LPERLN, RPERLN C## S T A T U S: C SINGLE/DOUBLE Conversion: Needed (See CONVRT). C C Ignore lines beginning with "C!!!!" . C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C System Dependence: System routine for direct C access unformatted record length C C==>CYBER/FTN5 C THIS VERSION IS FOR CYBER/FTN5 C==>VAX/BERK4.2 C THIS VERSION IS FOR VAX/BERK4.2(3) C==>VAX/VMS C THIS VERSION IS FOR VAX/VMS C==>HW6 C THIS VERSION IS FOR HW6 C==>SUN4 C THIS VERSION IS FOR SUN4 C==>SUN3 C THIS VERSION IS FOR SUN3 C==>SSYM C THIS IS A VERSION FOR Sequent Symmetry C==>MAC/MS C THIS VERSION IS FOR MAC/MS C==>LAHEYF77L C THIS VERSION IS FOR Lahey's F77L for PC's C==> C C>RCS $Header: recl.gl,v 2.1 91/11/22 11:45:23 buckley Exp $ C>RCS $Log: recl.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:23 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/16 14:39:15 buckley C>RCS Added Lahey C>RCS C>RCS Revision 1.9 89/06/30 13:30:18 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:30 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:29 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:07 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:32 buckley C>RCS Initial revision C>RCS C## D E S C R I P T I O N: C C THIS ROUTINE USES FOUR INTEGER CONSTANTS NEEDED TO DETERMINE C THE LENGTH OF AN UNFORMATTED RECORD FOR READING AND WRITING C DIRECT ACCESS FILES. THE PROCESSOR IS ASSUMED, ACCORDING C TO THE FORTRAN STANDARD, TO WRITE UNFORMATTED RECORDS C IN "PROCESSOR DEFINED UNITS", I.E. IN PDU'S. C C HERE WE MUST DEFINE FOUR CONSTANTS: C C CHARS THE NUMBER OF PDU'S NEEDED TO WRITE ONE CHARACTER; C INTS THE NUMBER OF PDU'S NEEDED TO WRITE ONE INTEGER VALUE; C LOGS THE NUMBER OF PDU'S NEEDED TO WRITE ONE LOGICAL VALUE; C REALS THE NUMBER OF PDU'S NEEDED TO WRITE ONE REAL(DP) VALUE. C C NOTE THAT IT MAY HAPPEN (PARTICULARLY WITH CHARACTER OR LOGICAL C DATA) THAT SEVERAL VALUES MAY FIT INTO ONE PDU. IN THIS CASE, SET C THE CONSTANT TO A NEGATIVE VALUE. FOR EXAMPLE, ON A CYBER, A PDU C IS ONE WORD AND 10 CHARACTERS FIT PER WORD. IN THIS CASE, CHARS C IS SET TO -10. BUT ON A VAX, A PDU IS ONE BYTE AND AN INTEGER C OCCUPIES 4 BYTES, SO INTS IS SET TO 4. NOTE THAT THE VALUES FOR C 'REALS' WILL GENERALLY BE DIFFERENT FOR THE SINGLE AND DOUBLE C PRECISION VERSIONS ON THE SAME MACHINE. C C ON ENTRY, THE FOUR ARGUMENTS INDICATE HOW MANY VALUES OF EACH OF C THE FOUR BASIC TYPES ARE REQUIRED TO FIT IN ONE DIRECT ACCESS C UNFORMATTED RECORD. THIS ROUTINE WILL DETERMINE THE MINIMUM RECORD C LENGTH NEEDED TO SATISFY ALL FOUR REQUIREMENTS. THAT VALUE WILL BE C RETURNED AS THE VALUE OF THE FUNCTION ZZRECL. C C IT WILL THEN *RETURN* IN EACH OF THE FOUR ARGUMENTS THE *ACTUAL* C NUMBER OF EACH OF THESE WHICH CAN FIT IN THE RECORD OF THE SIZE C DETERMINED. C C N.B. **** THIS ROUTINE ASSUMES *NO MIXING* OF DATA TYPES ON C ANY ONE RECORD WHEN USING DIRECT ACCESS UNFORMATTED I/O. C THUS EACH TIME A RECORD IS WRITTEN, IT CONTAINS *ONLY* C CHARACTER DATA, OR *ONLY* INTEGER DATA, OR *ONLY* REAL C DATA, OR *ONLY* LOGICAL DATA. ANY MIXING WOULD C TOTALLY DESTROY ANY HOPE OF PORTABILITY TO SOME SYSTEMS. C C## E N T R Y P O I N T S: The natural entry ZZRECL. C## S U B R O U T I N E S: ABS, MAX ... INTRINSIC C C## P A R A M E T E R S: C==>CYBER/FTN5 INTEGER CHARS, INTS, LOGS, REALS PARAMETER ( CHARS = -10, INTS = 1, LOGS = 1, REALS = 1 ) C!!!! PARAMETER ( CHARS = -10, INTS = 1, LOGS = 1, REALS = 2 ) C==>VAX/VMS C==>VAX/BERK4.2 C==>SUN4 C==>SUN3 C==>SSYM C==>MAC/MS C==>LAHEYF77L INTEGER CHARS, INTS, LOGS, REALS PARAMETER ( CHARS = 1, INTS = 4, LOGS = 4, REALS = 4 ) C!!!! PARAMETER ( CHARS = 1, INTS = 4, LOGS = 4, REALS = 8 ) C==>HW6 INTEGER CHARS, INTS, LOGS, REALS PARAMETER ( CHARS = 1, INTS = 4, LOGS = 4, REALS = 4 ) C!!!! PARAMETER ( CHARS = 1, INTS = 4, LOGS = 4, REALS = 8 ) C==> C## L O C A L D E C L: INTEGER N C## S A V E: NONE selected. C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C## D A T A: NONE are set. C## E X E C U T I O N C## E X E C U T I O N ZZRECL = 1 IF ( CHARS .LT. 0 ) THEN N = ABS(CHARS) N = ( CPERLN + N - 1 ) / N ELSE N = CPERLN * CHARS ENDIF ZZRECL = MAX ( ZZRECL, N ) IF ( INTS .LT. 0 ) THEN N = ABS(INTS) N = ( IPERLN + N - 1 ) / N ELSE N = IPERLN * INTS ENDIF ZZRECL = MAX ( ZZRECL, N ) IF ( LOGS .LT. 0 ) THEN N = ABS(LOGS) N = ( LPERLN + N - 1 ) / N ELSE N = LPERLN * LOGS ENDIF ZZRECL = MAX ( ZZRECL, N ) IF ( REALS .LT. 0 ) THEN N = ABS(REALS) N = ( RPERLN + N - 1 ) / N ELSE N = RPERLN * REALS ENDIF ZZRECL = MAX ( ZZRECL, N ) C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZRECL. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> secssg.gnc SUBROUTINE ZZSECS(SECS) C## A R G U M E N T S: REAL SECS C!!!! DOUBLE PRECISION SECS C## S T A T U S: C SINGLE/DOUBLE Conversion: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C SYSTEM DEPENDENCE: System routine for CPU usage. C==>CYBER/FTN5 C This version is for CYBER/FTN5 C==>VAX/BERK4.2 C This version is for VAX/BERK4.2(3) C==>VAX/VMS C This version is for VAX/VMS C==>HW6 C This version is for HW6 C==>SUN4 C This version is for SUN4 C==>SUN3 C This version is for SUN3 C==>SSYM C THIS IS A VERSION FOR Sequent Symmetry C==>MAC/MS C This version is for MAC/MS C==>LAHEYF77L C THIS VERSION IS FOR Lahey's F77L for PC's C==> C C>RCS $Header: secs.gl,v 2.1 91/11/22 11:45:25 buckley Exp $ C>RCS $Log: secs.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:25 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/06 10:48:10 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9 89/06/30 13:30:19 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:31 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:31 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:12 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:33 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C THIS SUBROUTINE SHOULD OBTAIN (FROM THE OPERATING SYSTEM) THE C AMOUNT OF CPU TIME USED BY THE CALLING PROGRAM SINCE THE C EXECUTION BEGAN. IF DESIRABLE, "SECS" CAN ALSO BE CONVERTED C TO DOUBLE PRECISION (SEE CONVRT). HOWEVER, THE ROUTINE ACTUALLY C WORKS TOTALLY AS A SINGLE PRECISION ROUTINE, EXCEPT THAT THE C VALUE WHICH IS PASSED BACK MAY BE IN EITHER PRECISION AS C APPROPRIATE. C TIME IS MEASURED FROM THE FIRST CALL TO ZZSECS. THUS C ON THE FIRST CALL TO ZZSECS, A TIME OF 0.0 SECONDS IS ALWAYS C RETURNED. C## E N T R Y P O I N T S: The natural entry ZZSECS. C## S U B R O U T I N E S: A SYSTEM CLOCK. C## P A R A M E T E R S: C==>CYBER/FTN5 C==>VAX/BERK4.2 C==>SUN4 C==>SUN3 C==>SSYM REAL ZERO PARAMETER ( ZERO = 0.0E0 ) C==>MAC/MS REAL ZERO, SHIFT, SIXTY PARAMETER ( ZERO = 0.0E0, SHIFT = 2.0**32, SIXTY = 60.0 ) C==>VAX/VMS REAL R100 PARAMETER ( R100 = 100.0 ) C==>HW6 INTEGER*8 ZERO PARAMETER ( ZERO = 0 ) REAL MICROS PARAMETER ( MICROS = 1000000.0 ) C==>LAHEYF77L INTEGER * 4 ONEDAY PARAMETER ( ONEDAY = 8640000 ) REAL ZERO, R100 PARAMETER ( ZERO = 0.0E0, R100 = 100.0 ) C==> C## L O C A L D E C L: LOGICAL FIRST C==>CYBER/FTN5 REAL SECOND REAL STTIME, SEC C==>VAX/VMS INTEGER CLOCK REAL STTIME, SEC C==>MAC/MS INCLUDE TOOLBX.PAR INTEGER SECNDS, TOOLBX REAL STTIME, SEC C==>VAX/BERK4.2 C==>SUN4 C==>SUN3 C==>SSYM REAL ETIME, DUMMY(2) REAL STTIME, SEC C==>HW6 INTEGER*8 TOTAL_CPU_TIME_ REAL STTIME, SEC C==>LAHEYF77L INTEGER * 4 STTIME, HUNSEC REAL SEC C==> C## S A V E: SAVE FIRST, STTIME C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C## D A T A: DATA FIRST/.TRUE./ C## E X E C U T I O N C## E X E C U T I O N IF ( FIRST ) THEN FIRST = .FALSE. C==>CYBER/FTN5 STTIME = SECOND() C==>VAX/BERK4.2 C==>SUN4 C==>SUN3 C==>SSYM STTIME = ETIME(DUMMY) C==>VAX/VMS STTIME = LIB$INIT_TIMER ( ) STTIME = ZERO C==>MAC/MS STTIME = REAL(TOOLBX(TICKCOUNT))/SIXTY C==>HW6 STTIME = TOTAL_CPU_TIME_() C==>LAHEYF77L CALL TIMER(STTIME) C==> SEC = ZERO ELSE C==>CYBER/FTN5 SEC = SECOND() - STTIME C==>VAX/BERK4.2 C==>SUN4 C==>SUN3 C==>SSYM SEC = ETIME(DUMMY) - STTIME C==>VAX/VMS SEC = LIB$STAT_TIMER ( %REF(2), %REF(CLOCK), ) SEC = ( REAL(CLOCK)/R100 ) - STTIME C==>MAC/MS SECNDS = TOOLBX(TICKCOUNT) SEC = REAL(SECNDS)/SIXTY - STTIME IF ( SEC .LT. ZERO ) THEN SEC = SEC + SHIFT ENDIF C==>HW6 SEC = (TOTAL_CPU_TIME_() - STTIME) / MICROS C==>LAHEYF77L CALL TIMER(HUNSEC) HUNSEC = HUNSEC - STTIME C C Routine TIMER returns the time in hundredths of a second since C midnight. Hence HUNSEC will be negative if midnight has been C passed. The following code corrects this for any job which has C been running not more than 248 days ! C 10 IF (HUNSEC .LT. 0) THEN HUNSEC = HUNSEC + ONEDAY GO TO 10 END IF SEC = HUNSEC / R100 C==>DUMMY C TO CHEAT AND QUICKLY CONVERT THIS TO A NON-SYSTEM DEPENDENT C ROUTINE, JUST SET SEC = ZERO. SEC = ZERO C==> ENDIF SECS = SEC C!!!! SECS = DBLE(SEC) C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZSECS. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> timesg.gnc SUBROUTINE ZZTIME ( CHTIME ) C## A R G U M E N T S: CHARACTER *(*) CHTIME C## S T A T U S: C SINGLE/DOUBLE Conversion: NOT required. C C System Dependence: System routine for Time. C C==>CYBER/FTN5 C THIS VERSION IS FOR CYBER/FTN5 C==>VAX/BERK4.2 C THIS VERSION IS FOR VAX/BERK4.2(3) C==>VAX/VMS C THIS VERSION IS FOR VAX/VMS C==>HW6 C THIS VERSION IS FOR HW6 C==>SUN4 C THIS VERSION IS FOR SUN4 C==>SUN3 C THIS VERSION IS FOR SUN3 C==>SSYM C THIS IS A VERSION FOR Sequent Symmetry C==>MAC/MS C THIS VERSION IS FOR MAC/MS C==>LAHEYF77L C THIS VERSION IS FOR Lahey's F77L for PC's C==> C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C>RCS $Header: time.gl,v 2.1 91/11/22 11:45:26 buckley Exp $ C>RCS $Log: time.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:26 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/06 10:52:37 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9 89/06/30 13:30:20 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:32 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:33 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:16 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:33 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE MUST CALL A SYSTEM ROUTINE TO GET THE CURRENT TIME. C IT MUST RETURN THIS TIME IN THE CHARACTER VARIABLE CHTIME C IN THE FORM C C (HH+MM+SS) C C AS REQUIRED BY THE ROUTINE ZZDTTM. CHTIME MUST BE OF LENGTH 10. C ONLY THE SIX CHARACTERS HH MM SS ARE ACTUALLY USED. THE OTHERS C CAN BE ANYTHING, BUT THE HH, MM AND SS MUST BE IN THE CORRECT C POSITION. HH SHOULD BE BETWEEN 0 AND 23, I.E. BASED ON THE 24 HOUR C CLOCK. OF COURSE MM AND SS MUST BE IN THE RANGE 0 TO 59. C C THIS VERSION CALLS A SYSTEM DEPENDENT ROUTINE. C TO IMPLEMENT THIS ON ANOTHER SYSTEM, ONE MAY EITHER C C (A) INCORPORATE AN ALTERNATE VERSION OF ZZTIME; C C (B) USE THE "DUMMY" VERSION OF THIS ROUTINE WITH THE SINGLE C EXECUTABLE STATEMENT CHTIME=' ', IN WHICH CASE NO C TIME INFORMATION WILL APPEAR IN THE OUTPUT. C C## E N T R Y P O I N T S: The natural entry ZZTIME. C## S U B R O U T I N E S: SYSTEM ROUTINE TO GET TIME OF DAY. C## P A R A M E T E R S: NONE are defined. C## L O C A L D E C L: C==>CYBER/FTN5 CHARACTER * 10 TIME C==>VAX/BERK4.2 C==>SUN4 C==>SUN3 C==>SSYM CHARACTER * 24 UNXTIM C==>VAX/VMS CHARACTER * 8 VAXTIM C==>HW6 CHARACTER * 24 HWTIME INTEGER * 8 CLOCK_ INTEGER SECS C==>MAC/MS INTEGER SECNDS, MINUTS, HOURS C==>LAHEYF77L CHARACTER * 11 NOW C==> C## S A V E: NONE selected. C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C## D A T A: NONE are set. C## E X E C U T I O N C## E X E C U T I O N C==>CYBER/FTN5 CHTIME = TIME() C==>VAX/BERK4.2 C==>SUN4 C==>SUN3 C==>SSYM CALL FDATE (UNXTIM) CHTIME(2:9) = UNXTIM(12:19) C==>VAX/VMS CALL TIME (VAXTIM) CHTIME(2:9) = VAXTIM(1:8) C==>HW6 CALL DATE_TIME_ (CLOCK_(), HWTIME) CHTIME(2:3) = HWTIME(11:12) CHTIME(5:6) = HWTIME(13:14) READ ( HWTIME(16:16), '(I1)' ) SECS WRITE( CHTIME(8:9), '(I2.2)' ) SECS*6 C==>MAC/MS CALL TIME(SECNDS) MINUTS = SECNDS / 60 HOURS = MINUTS / 60 MINUTS = MINUTS - 60*HOURS SECNDS = SECNDS - 60 * ( MINUTS + 60*HOURS ) WRITE ( CHTIME(2:3), '(I2.2)' ) HOURS WRITE ( CHTIME(5:6), '(I2.2)' ) MINUTS WRITE ( CHTIME(8:9), '(I2.2)' ) SECNDS C==>LAHEYF77L CALL TIME (NOW) CHTIME(2:9) = NOW(1:8) C==> C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZTIME. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> casesg.hw6 SUBROUTINE ZZCASE (STRING, TYPE ) C## A R G U M E N T S: CHARACTER *(*) STRING INTEGER TYPE C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NOT REQUIRED. C C SYSTEM DEPENDENCE: SYSTEM ROUTINE FOR CASE C CONVERSION OF LETTERS. C C THIS IS A VERSION FOR HW6 C>RCS $HEADER: CASE.GL,V 2.0 90/07/05 12:44:20 BUCKLEY EXP $ C>RCS $LOG: CASE.GL,V $ C>RCS REVISION 2.0 90/07/05 12:44:20 BUCKLEY C>RCS COMMON VERSION FOR TOMS AND GL C>RCS C>RCS REVISION 1.9.1.1 89/06/30 14:59:19 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.9 89/06/30 13:30:11 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 16:07:53 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/20 13:48:39 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C## D E S C R I P T I O N: C THIS CONVERTS EACH LOWER CASE ALPHABETIC LETTER TO C UPPER CASE, OR VICE VERSA. C IF TYPE = CTOUPP, CONVERSION IS LOWER TO UPPER C IF TYPE = CTOLOW, CONVERSION IS UPPER TO LOWER C IF TYPE = CTOCAP, USE UPPER FOR FIRST LETTER; LOWER FOR REST C ALL OTHER CHARACTERS ARE LEFT UNCHANGED. C## E N T R Y P O I N T S: THE NATURAL ENTRY TTOUPPR. C## S U B R O U T I N E S: LEN (INTRINSIC). C## P A R A M E T E R S: INTEGER CTOUPP, CTOLOW, CTOCAP PARAMETER ( CTOUPP = 1, CTOLOW = 2, CTOCAP = 3 ) CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) CHARACTER*(*) PERIOD, COMMA, SEMICN PARAMETER ( PERIOD = '.', COMMA = ',', SEMICN = ';' ) CHARACTER*(*) COLON, DASH, EQUALS PARAMETER ( COLON = ':', DASH = '-', EQUALS = '=' ) CHARACTER*(*) OBRACE, CBRACE, UNDERS PARAMETER ( OBRACE = '{', CBRACE = '}', UNDERS = '_' ) CHARACTER*(*) PLUS, MINUS, EXCLAM PARAMETER ( PLUS = '+', MINUS = '-', EXCLAM = '!' ) CHARACTER*(*) GTHAN, LTHAN, QUESMK PARAMETER ( GTHAN = '>', LTHAN = '<', QUESMK = '?' ) CHARACTER*(*) SLASH, BSLASH, PERCNT PARAMETER ( SLASH = '/', BSLASH = '\\',PERCNT = '%' ) CHARACTER*(*) CARAT, ATSIGN, TILDE PARAMETER ( CARAT = '^', ATSIGN = '@', TILDE = '~' ) C## L O C A L D E C L: INTEGER I, SHIFT LOGICAL FIRST CHARACTER *1 CH C## S A V E: SAVE FIRST, SHIFT C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA FIRST/.TRUE./ C## E X E C U T I O N C## E X E C U T I O N IF (FIRST) THEN FIRST = .FALSE. SHIFT = ICHAR('A') - ICHAR('a') ENDIF I = 0 100 I = I + 1 IF ( I .LE. LEN(STRING) ) THEN IF ( TYPE .EQ. CTOUPP ) THEN IF ('a' .LE. STRING(I:I) .AND. STRING(I:I) .LE. 'z') THEN CH = CHAR( ICHAR(STRING(I:I)) + SHIFT ) ELSE CH = STRING(I:I) ENDIF ELSE IF ( TYPE .EQ. CTOLOW .OR. TYPE .EQ. CTOCAP ) THEN IF ('A' .LE. STRING(I:I) .AND. STRING(I:I) .LE. 'Z') THEN CH = CHAR( ICHAR(STRING(I:I)) - SHIFT ) ELSE CH = STRING(I:I) ENDIF ENDIF STRING(I:I) = CH GOTO 100 ENDIF IF ( TYPE .EQ. CTOCAP .and. - 'a' .LE. STRING(1:1) .AND. STRING(1:1) .LE. 'z') THEN CH = CHAR( ICHAR(STRING(1:1)) + SHIFT ) STRING(1:1) = CH ENDIF C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF TOUPPR. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> datesg.hw6 SUBROUTINE ZZdate (CHDATE) C## A R G U M E N T S: CHARACTER *(*) CHDATE C## S T A T U S: C SINGLE/DOUBLE Conversion: NOT required. C SYSTEM DEPENDENCE: System routine for date. C C THIS VERSION IS FOR HW6 C C>RCS $Header: date.gl,v 2.1 91/11/22 11:45:18 buckley Exp $ C>RCS $Log: date.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:18 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/05 12:50:05 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9 89/06/30 13:30:12 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:26 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:12:13 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:33:41 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:30 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C THIS ROUTINE MUST CALL A SYSTEM ROUTINE TO GET THE CURRENT DATE. C ZZDATE MUST RETURN THIS DATE IN THE CHARACTER VARIABLE CHDATE C IN THE FORM C C (YY+MM+DD) C C AS REQUIRED BY THE ROUTINE ZZDTTM. CHDATE MUST OF LENGTH 10. C ONLY THE 6 CHARACTERS YY MM DD ARE ACTUALLY USED. THE OTHERS C CAN BE ANYTHING, I.E. ONLY THE POSITION OF THE YY MM DD MATTERS. C C THIS MUST CALL A SYSTEM ROUTINE TO GET THE DATE. C TO IMPLEMENT THIS ON ANOTHER SYSTEM, ONE MAY EITHER C C (A) INCORPORATE AN ALTERNATE VERSION OF ZZDATE; C C (B) USE THE "DUMMY" VERSION OF THIS ROUTINE WITH THE SINGLE C EXECUTABLE STATEMENT CHDATE='( + + )', IN WHICH CASE NO C DATE INFORMATION WILL APPEAR IN THE OUTPUT. C## E N T R Y P O I N T S: The natural entry ZZdate. C## S U B R O U T I N E S: System date routine. C## P A R A M E T E R S: NONE are defined. C## L O C A L D E C L: CHARACTER * 24 HWDATE INTEGER * 8 CLOCK_ C## S A V E: NONE selected. C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C## D A T A: NO DATA VALUES SET. C## E X E C U T I O N C## E X E C U T I O N C---- INITIALIZE CHDATE CHDATE = '( + + )' CALL DATE_TIME_ (CLOCK_(), HWDATE) CHDATE(2:3) = HWDATE(7:8) CHDATE(5:6) = HWDATE(1:2) CHDATE(8:9) = HWDATE(4:5) C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZdate. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> mparsg.hw6 REAL FUNCTION ZZMPAR(I) C!!!! DOUBLE PRECISION FUNCTION ZZMPAR(I) C## A R G U M E N T S: INTEGER I C## S T A T U S: C IGNORE LINES BEGINNING WITH "C!!!!" . C C SYSTEM DEPENDENCE: THE CODE IS VERY DEFINITELY MACHINE DEPENDENT C FOR IT CONTAINS MACHINE PRECISION CONSTANTS C FOR MANY MACHINES, AS DESCRIBED BELOW. C C SINGLE/DOUBLE Conversion: NEEDED (SEE CONVRT). C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C>RCS $Header: mpar.gl,v 2.3 91/11/22 11:45:19 buckley Exp $ C>RCS $Log: mpar.gl,v $ C>RCS Revision 2.3 91/11/22 11:45:19 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.2 91/06/12 14:07:08 buckley C>RCS Added stardent C>RCS C>RCS Revision 2.1 90/07/31 10:57:40 buckley C>RCS Added constants for ieee for pc's C>RCS C>RCS Revision 2.0 90/07/06 10:39:26 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9.1.2 90/06/26 14:24:24 buckley C>RCS Fixed single/double precision constants for sun4 C>RCS C>RCS Revision 1.9.1.1 89/07/01 11:36:48 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.9 89/06/30 13:30:15 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:28 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:23 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:34:59 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:31 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C C THIS IS A MODIFICATION OF THE TWO ROUTINES DPMPAR AND SPMPAR C OBTAINED FROM JORGE MORE. IT HAS BEEN CHANGED ONLY TO CONFORM C WITH MY CONVENTIONS, AND TO ADD STATEMENTS FOR THE CDC C CYBERS WHICH ARE ACCEPTABLE TO FTN5 (FORTRAN '77). THE C OTHER CHANGES ARE: C C 1. THE SINGLE NAME ZZMPAR HAS BEEN USED. IT IS DOUBLE OR SINGLE C PRECISION ACCORDING TO CONVERSION BY CONVRT, JUST AS FOR ALL C OF MY OTHER PROGRAMS. C C 2. THE ROUTINES HAVE BEEN MERGED SO THAT SINGLE AND DOUBLE C PRECISION STATEMENTS WHICH CORRESPOND APPEAR IN PAIRS. C C OTHERWISE ALL OF THE COMMENTS OF THE ORIGINAL AUTHORS APPLY. C THEIR ORIGINAL COMMENTS (UNALTERED) FOR THE DOUBLE PRECISION C VERSION FOLLOW IMMEDIATELY. C C FUNCTION DPMPAR C C THIS FUNCTION PROVIDES DOUBLE PRECISION MACHINE PARAMETERS C WHEN THE APPROPRIATE SET OF DATA STATEMENTS IS ACTIVATED (BY C REMOVING THE C FROM COLUMN 1) AND ALL OTHER DATA STATEMENTS ARE C RENDERED INACTIVE. MOST OF THE PARAMETER VALUES WERE OBTAINED C FROM THE CORRESPONDING BELL LABORATORIES PORT LIBRARY FUNCTION. C C THE FUNCTION STATEMENT IS C C DOUBLE PRECISION FUNCTION DPMPAR(I) C C WHERE C C I IS AN INTEGER INPUT VARIABLE SET TO 1, 2, OR 3 WHICH C SELECTS THE DESIRED MACHINE PARAMETER. IF THE MACHINE HAS C T BASE B DIGITS AND ITS SMALLEST AND LARGEST EXPONENTS ARE C EMIN AND EMAX, RESPECTIVELY, THEN THESE PARAMETERS ARE C C DPMPAR(1) B**(1 - T), THE MACHINE PRECISION, C C DPMPAR(2) B**(EMIN - 1), THE SMALLEST MAGNITUDE, C C DPMPAR(3) B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE C C## E N T R Y P O I N T S: The natural entry ZZmpar. C## S U B R O U T I N E S: NONE are called. C## P A R A M E T E R S: NONE are defined. C C## L O C A L D E C L: C NOTE THAT THESE ARRAYS MUST HAVE DIMENSIONS 2 AND 4, RATHER C THAN 1 AND 2 AS ONE MIGHT EXPECT, BECAUSE OF THE PDP-11 C DEFINITIONS. INTEGER MCHEPS(2) C!!!! INTEGER MCHEPS(4) INTEGER MINMAG(2) C!!!! INTEGER MINMAG(4) INTEGER MAXMAG(2) C!!!! INTEGER MAXMAG(4) REAL RMACH(3) C!!!! DOUBLE PRECISION DMACH(3) INTEGER EMIN, EMAX, IMACH(10) REAL B, BINV, BM1, ONE, W, Z C!!!! DOUBLE PRECISION B, BINV, BM1, ONE, W, Z C## S A V E: SAVE RMACH C!!!! SAVE DMACH SAVE IMACH C## E Q U I V A L E N C E S: EQUIVALENCE (RMACH(1),MCHEPS(1)) C!!!! EQUIVALENCE (DMACH(1),MCHEPS(1)) EQUIVALENCE (RMACH(2),MINMAG(1)) C!!!! EQUIVALENCE (DMACH(2),MINMAG(1)) EQUIVALENCE (RMACH(3),MAXMAG(1)) C!!!! EQUIVALENCE (DMACH(3),MAXMAG(1)) C## C O M M O N: NONE is defined. C## D A T A: C-----MACHINE CONSTANTS FOR THE HONEYWELL 60/600/6000 SERIES. DATA RMACH(1) / O716400000000 / C!!!! DATA MCHEPS(1),MCHEPS(2) / O606400000000, O000000000000 / DATA RMACH(2) / O402400000000 / C!!!! DATA MINMAG(1),MINMAG(2) / O402400000000, O000000000000 / DATA RMACH(3) / O376777777777 / C!!!! DATA MAXMAG(1),MAXMAG(2) / O376777777777, O777777777777 / C## E X E C U T I O N C## E X E C U T I O N ZZMPAR = RMACH(I) C!!!! ZZMPAR = DMACH(I) C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZmpar. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> opensg.hw6 SUBROUTINE ZZOPEN ( IUNIT, FLAG, INAME, * , RECLEN ) C## A R G U M E N T S: INTEGER IUNIT, RECLEN LOGICAL FLAG CHARACTER *(*) INAME C## S T A T U S: C IGNORE LINES BEGINNING WITH "C!!!!" . C C SINGLE/DOUBLE Conversion: NEEDED (SEE CONVRT). C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR C OPENING AND CLOSING FILES. C C THIS VERSION IS FOR HW6 C C>RCS $Header: open.gl,v 2.1 91/11/22 11:45:21 buckley Exp $ C>RCS $Log: open.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:21 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/06 10:43:19 buckley C>RCS Common version for TOMS and MT C>RCS C>RCS Revision 1.9.1.2 89/07/01 11:51:41 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.9.1.1 89/07/01 11:36:50 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.9 89/06/30 13:30:16 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:29 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:26 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:02 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:31 buckley C>RCS Initial revision C>RCS C## D E S C R I P T I O N: C C THIS OPENS THE FILES NEEDED FOR TESTPACK AND KEEPS TRACK OF C WHICH ARE OPEN AND WHICH ARE NOT. IT ALSO SUPPLIES THE APPRO- C PRIATE ARGUMENTS FOR EACH FILE. C C IF NAME IS NOT BLANK ON ENTRY, THEN THE FILE IS OPENED C WITH THE NAME GIVEN. OTHERWISE, NO NAME IS SPECIFIED WHEN C OPENING THE FILE. C C THE OPEN IS ONLY DONE IF "FLAG" IS TRUE. C C IF RECLEN IS NOT EQUAL TO ZERO, THEN THE FILE IS OPENED C AS DIRECT ACCESS UNFORMATTED. C C IF RECLEN IS EQUAL TO ZERO, THEN THE FILE IS OPENED C FOR FORMATTED SEQUENTIAL ACCESS. C C## E N T R Y P O I N T S: The natural entry ZZopen and ZZclse C## S U B R O U T I N E S: OPEN, CLOSE, REAL ...INTRINSIC C ZZERRM ...FOR ERROR MESSAGES. C## P A R A M E T E R S: INTEGER FILENL, NFILES PARAMETER ( FILENL = 80, NFILES = 15 ) CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) CHARACTER*(*) PERIOD, COMMA, SEMICN PARAMETER ( PERIOD = '.', COMMA = ',', SEMICN = ';' ) CHARACTER*(*) COLON, DASH, EQUALS PARAMETER ( COLON = ':', DASH = '-', EQUALS = '=' ) CHARACTER*(*) OBRACE, CBRACE, UNDERS PARAMETER ( OBRACE = '{', CBRACE = '}', UNDERS = '_' ) CHARACTER*(*) PLUS, MINUS, EXCLAM PARAMETER ( PLUS = '+', MINUS = '-', EXCLAM = '!' ) CHARACTER*(*) GTHAN, LTHAN, QUESMK PARAMETER ( GTHAN = '>', LTHAN = '<', QUESMK = '?' ) CHARACTER*(*) SLASH, BSLASH, PERCNT PARAMETER ( SLASH = '/', BSLASH = '\\',PERCNT = '%' ) CHARACTER*(*) CARAT, ATSIGN, TILDE PARAMETER ( CARAT = '^', ATSIGN = '@', TILDE = '~' ) LOGICAL T, F PARAMETER ( T = .TRUE., F = .FALSE. ) CHARACTER*(*) TRUE, QT, FALSE, QF PARAMETER ( TRUE = 'TRUE', QT = 'T', FALSE = 'FALSE', QF = 'F' ) INTEGER ITRUE, IFALSE PARAMETER ( ITRUE = 1, IFALSE = 0 ) REAL RTRUE, RFALSE C!!!! DOUBLE PRECISION RTRUE, RFALSE PARAMETER ( RTRUE = 1.D0, RFALSE = 0.D0 ) INTEGER CTOUPP, CTOLOW, CTOCAP PARAMETER ( CTOUPP = 1, CTOLOW = 2, CTOCAP = 3 ) INTEGER PREPRC, DAUF, INPTUN PARAMETER ( PREPRC = 1, DAUF = 2, INPTUN = 3 ) INTEGER TEMPUN, STDIN, TRMOUT PARAMETER ( TEMPUN = 4, STDIN = 5, TRMOUT = 6 ) INTEGER WRITUN, TRACUN, SUMMUN PARAMETER ( WRITUN = 7, TRACUN = 8, SUMMUN = 9 ) INTEGER COPYUN, TEXUN PARAMETER ( COPYUN =10, TEXUN =11 ) CHARACTER *(*) SEQ , DIR PARAMETER ( SEQ = 'SEQUENTIAL', DIR = 'DIRECT' ) CHARACTER *(*) UNKN , NEW PARAMETER ( UNKN = 'UNKNOWN' , NEW = 'NEW' ) CHARACTER *(*) OLD , SCR PARAMETER ( OLD = 'OLD' , SCR = 'SCRATCH' ) CHARACTER *(*) DEL , KEEP PARAMETER ( DEL = 'DELETE' , KEEP = 'KEEP' ) CHARACTER *(*) FMT , UNFRMT PARAMETER ( FMT = 'FORMATTED' , UNFRMT = 'UNFORMATTED' ) C## L O C A L D E C L: INTEGER ERRINT, UNIT LOGICAL OPENFS(NFILES), REW, OPENIT, COPY CHARACTER STAT*7, ACCS*10, FRMT*11 CHARACTER *(FILENL) COPYNM, NAME REAL RD C!!!! DOUBLE PRECISION RD C## S A V E: SAVE OPENFS, COPY, COPYNM C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA OPENFS / NFILES * .FALSE. / DATA COPY/F/, COPYNM/BLANK/ C## E X E C U T I O N C## E X E C U T I O N C----- DEFINE A STATEMENT FUNCTION. RD(UNIT) = REAL(UNIT) C!!!! RD(UNIT) = DBLE(UNIT) IF ( FLAG ) THEN IF ( RECLEN .EQ. 0 ) THEN ACCS = SEQ FRMT = FMT ELSE ACCS = DIR FRMT = UNFRMT ENDIF UNIT = IUNIT NAME = INAME 100 CONTINUE OPENIT = .NOT. OPENFS(UNIT) REW = .FALSE. IF ( UNIT .EQ. SUMMUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. TRMOUT ) THEN OPENIT = .FALSE. ELSE IF ( UNIT .EQ. STDIN ) THEN OPENIT = .FALSE. ELSE IF ( UNIT .EQ. PREPRC) THEN STAT = OLD REW = .TRUE. ELSE IF ( UNIT .EQ. TEMPUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. WRITUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. TRACUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. DAUF ) THEN STAT = OLD ELSE IF ( UNIT .EQ. COPYUN ) THEN STAT = UNKN COPY = T ELSE IF ( UNIT .EQ. INPTUN ) THEN STAT = OLD REW = .TRUE. ELSE CALL ZZERRM ( RD(UNIT), *91000, - 'IS REQUEST TO OPEN UNKNOWN UNIT # ' ) ENDIF C FOR THE "CHOICE OF UNIT..." 500 IF ( OPENIT ) THEN IF ( NAME .EQ. BLANK ) THEN C PRINT*,'OPENING ',UNIT,'NAME=' IF ( RECLEN .EQ. 0 ) THEN OPEN ( UNIT = UNIT, - ERR = 1000, - IOSTAT = ERRINT, - STATUS = STAT, - ACCESS = ACCS, - FORM = FRMT ) ELSE OPEN ( UNIT = UNIT, - ERR = 1000, - IOSTAT = ERRINT, - STATUS = STAT, - ACCESS = ACCS, - RECL = RECLEN, - FORM = FRMT ) ENDIF ELSE C NAMED FILE IF ( RECLEN .EQ. 0 ) THEN C PRINT*,'OPENING ',UNIT,'NAME=',NAME(1:20) OPEN ( UNIT = UNIT, - ERR = 1000, - IOSTAT = ERRINT, - FILE = NAME, - STATUS = STAT, - ACCESS = ACCS, - FORM = FRMT ) C PRINT*,'OK' ELSE OPEN ( UNIT = UNIT, - ERR = 1000, - FILE = NAME, - IOSTAT = ERRINT, - STATUS = STAT, - ACCESS = ACCS, - RECL = RECLEN, - FORM = FRMT ) ENDIF ENDIF ENDIF C FOR EACH UNIT FROM 1 TO NFILES WE NEED TO KEEP A RECORD OF C WHETHER IT IS CURRENTLY OPEN. OPENFS(UNIT) = .TRUE. IF ( REW .AND. RECLEN .EQ. 0 ) THEN REWIND UNIT ENDIF GOTO 1025 1000 IF ( UNIT .EQ. DAUF ) THEN C CREATE THE DAUF. STAT = NEW GOTO 500 ELSE GOTO 1050 ENDIF 1025 CONTINUE IF ( COPY .AND. UNIT .EQ. STDIN ) THEN UNIT = COPYUN NAME = COPYNM GOTO 100 ENDIF ENDIF C FOR THE "IF FLAG..." GOTO 90000 1050 CONTINUE GOTO 91000 C## E N T R Y ZZCLSE: ENTRY ZZCLSE ( IUNIT, * ) STAT = KEEP IF ( IUNIT .EQ. SUMMUN ) THEN STAT = KEEP ELSE IF ( IUNIT .EQ. TRMOUT ) THEN ELSE IF ( IUNIT .EQ. STDIN ) THEN ELSE IF ( IUNIT .EQ. TEMPUN ) THEN STAT = KEEP ELSE IF ( IUNIT .EQ. WRITUN ) THEN ELSE IF ( IUNIT .EQ. TRACUN ) THEN ELSE IF ( IUNIT .EQ. COPYUN ) THEN STAT = KEEP COPY = F ELSE IF ( IUNIT .EQ. DAUF ) THEN ELSE IF ( IUNIT .EQ. PREPRC ) THEN ELSE IF ( IUNIT .EQ. INPTUN ) THEN ELSE CALL ZZERRM ( RD(IUNIT), *91000, - 'IS IGNORING REQUEST TO CLOSE UNKNOWN UNIT #' ) ENDIF IF ( OPENFS(IUNIT) ) THEN C PRINT*,'CLOSING ',IUNIT CLOSE ( UNIT = IUNIT, STATUS = STAT ) OPENFS(IUNIT) = .FALSE. ENDIF RETURN C## E X I T 90000 CONTINUE CALL ZZCASE (STAT,CTOUPP) IF ( IUNIT .EQ. DAUF .AND. STAT .EQ. NEW ) THEN GOTO 91000 ELSE RETURN ENDIF 91000 RETURN 1 C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZOPEN. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> reclsg.hw6 INTEGER FUNCTION ZZRECL ( CPERLN, IPERLN, LPERLN, RPERLN ) C## A R G U M E N T S: INTEGER CPERLN, IPERLN, LPERLN, RPERLN C## S T A T U S: C SINGLE/DOUBLE Conversion: Needed (See CONVRT). C C Ignore lines beginning with "C!!!!" . C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C System Dependence: System routine for direct C access unformatted record length C C THIS VERSION IS FOR HW6 C C>RCS $Header: recl.gl,v 2.1 91/11/22 11:45:23 buckley Exp $ C>RCS $Log: recl.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:23 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/16 14:39:15 buckley C>RCS Added Lahey C>RCS C>RCS Revision 1.9 89/06/30 13:30:18 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:30 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:29 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:07 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:32 buckley C>RCS Initial revision C>RCS C## D E S C R I P T I O N: C C THIS ROUTINE USES FOUR INTEGER CONSTANTS NEEDED TO DETERMINE C THE LENGTH OF AN UNFORMATTED RECORD FOR READING AND WRITING C DIRECT ACCESS FILES. THE PROCESSOR IS ASSUMED, ACCORDING C TO THE FORTRAN STANDARD, TO WRITE UNFORMATTED RECORDS C IN "PROCESSOR DEFINED UNITS", I.E. IN PDU'S. C C HERE WE MUST DEFINE FOUR CONSTANTS: C C CHARS THE NUMBER OF PDU'S NEEDED TO WRITE ONE CHARACTER; C INTS THE NUMBER OF PDU'S NEEDED TO WRITE ONE INTEGER VALUE; C LOGS THE NUMBER OF PDU'S NEEDED TO WRITE ONE LOGICAL VALUE; C REALS THE NUMBER OF PDU'S NEEDED TO WRITE ONE REAL(DP) VALUE. C C NOTE THAT IT MAY HAPPEN (PARTICULARLY WITH CHARACTER OR LOGICAL C DATA) THAT SEVERAL VALUES MAY FIT INTO ONE PDU. IN THIS CASE, SET C THE CONSTANT TO A NEGATIVE VALUE. FOR EXAMPLE, ON A CYBER, A PDU C IS ONE WORD AND 10 CHARACTERS FIT PER WORD. IN THIS CASE, CHARS C IS SET TO -10. BUT ON A VAX, A PDU IS ONE BYTE AND AN INTEGER C OCCUPIES 4 BYTES, SO INTS IS SET TO 4. NOTE THAT THE VALUES FOR C 'REALS' WILL GENERALLY BE DIFFERENT FOR THE SINGLE AND DOUBLE C PRECISION VERSIONS ON THE SAME MACHINE. C C ON ENTRY, THE FOUR ARGUMENTS INDICATE HOW MANY VALUES OF EACH OF C THE FOUR BASIC TYPES ARE REQUIRED TO FIT IN ONE DIRECT ACCESS C UNFORMATTED RECORD. THIS ROUTINE WILL DETERMINE THE MINIMUM RECORD C LENGTH NEEDED TO SATISFY ALL FOUR REQUIREMENTS. THAT VALUE WILL BE C RETURNED AS THE VALUE OF THE FUNCTION ZZRECL. C C IT WILL THEN *RETURN* IN EACH OF THE FOUR ARGUMENTS THE *ACTUAL* C NUMBER OF EACH OF THESE WHICH CAN FIT IN THE RECORD OF THE SIZE C DETERMINED. C C N.B. **** THIS ROUTINE ASSUMES *NO MIXING* OF DATA TYPES ON C ANY ONE RECORD WHEN USING DIRECT ACCESS UNFORMATTED I/O. C THUS EACH TIME A RECORD IS WRITTEN, IT CONTAINS *ONLY* C CHARACTER DATA, OR *ONLY* INTEGER DATA, OR *ONLY* REAL C DATA, OR *ONLY* LOGICAL DATA. ANY MIXING WOULD C TOTALLY DESTROY ANY HOPE OF PORTABILITY TO SOME SYSTEMS. C C## E N T R Y P O I N T S: The natural entry ZZRECL. C## S U B R O U T I N E S: ABS, MAX ... INTRINSIC C C## P A R A M E T E R S: INTEGER CHARS, INTS, LOGS, REALS PARAMETER ( CHARS = 1, INTS = 4, LOGS = 4, REALS = 4 ) C!!!! PARAMETER ( CHARS = 1, INTS = 4, LOGS = 4, REALS = 8 ) C## L O C A L D E C L: INTEGER N C## S A V E: NONE selected. C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C## D A T A: NONE are set. C## E X E C U T I O N C## E X E C U T I O N ZZRECL = 1 IF ( CHARS .LT. 0 ) THEN N = ABS(CHARS) N = ( CPERLN + N - 1 ) / N ELSE N = CPERLN * CHARS ENDIF ZZRECL = MAX ( ZZRECL, N ) IF ( INTS .LT. 0 ) THEN N = ABS(INTS) N = ( IPERLN + N - 1 ) / N ELSE N = IPERLN * INTS ENDIF ZZRECL = MAX ( ZZRECL, N ) IF ( LOGS .LT. 0 ) THEN N = ABS(LOGS) N = ( LPERLN + N - 1 ) / N ELSE N = LPERLN * LOGS ENDIF ZZRECL = MAX ( ZZRECL, N ) IF ( REALS .LT. 0 ) THEN N = ABS(REALS) N = ( RPERLN + N - 1 ) / N ELSE N = RPERLN * REALS ENDIF ZZRECL = MAX ( ZZRECL, N ) C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZRECL. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> secssg.hw6 SUBROUTINE ZZSECS(SECS) C## A R G U M E N T S: REAL SECS C!!!! DOUBLE PRECISION SECS C## S T A T U S: C SINGLE/DOUBLE Conversion: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C SYSTEM DEPENDENCE: System routine for CPU usage. C This version is for HW6 C C>RCS $Header: secs.gl,v 2.1 91/11/22 11:45:25 buckley Exp $ C>RCS $Log: secs.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:25 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/06 10:48:10 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9 89/06/30 13:30:19 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:31 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:31 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:12 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:33 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C THIS SUBROUTINE SHOULD OBTAIN (FROM THE OPERATING SYSTEM) THE C AMOUNT OF CPU TIME USED BY THE CALLING PROGRAM SINCE THE C EXECUTION BEGAN. IF DESIRABLE, "SECS" CAN ALSO BE CONVERTED C TO DOUBLE PRECISION (SEE CONVRT). HOWEVER, THE ROUTINE ACTUALLY C WORKS TOTALLY AS A SINGLE PRECISION ROUTINE, EXCEPT THAT THE C VALUE WHICH IS PASSED BACK MAY BE IN EITHER PRECISION AS C APPROPRIATE. C TIME IS MEASURED FROM THE FIRST CALL TO ZZSECS. THUS C ON THE FIRST CALL TO ZZSECS, A TIME OF 0.0 SECONDS IS ALWAYS C RETURNED. C## E N T R Y P O I N T S: The natural entry ZZSECS. C## S U B R O U T I N E S: A SYSTEM CLOCK. C## P A R A M E T E R S: INTEGER*8 ZERO PARAMETER ( ZERO = 0 ) REAL MICROS PARAMETER ( MICROS = 1000000.0 ) C## L O C A L D E C L: LOGICAL FIRST INTEGER*8 TOTAL_CPU_TIME_ REAL STTIME, SEC C## S A V E: SAVE FIRST, STTIME C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C## D A T A: DATA FIRST/.TRUE./ C## E X E C U T I O N C## E X E C U T I O N IF ( FIRST ) THEN FIRST = .FALSE. STTIME = TOTAL_CPU_TIME_() SEC = ZERO ELSE SEC = (TOTAL_CPU_TIME_() - STTIME) / MICROS ENDIF SECS = SEC C!!!! SECS = DBLE(SEC) C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZSECS. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> timesg.hw6 SUBROUTINE ZZTIME ( CHTIME ) C## A R G U M E N T S: CHARACTER *(*) CHTIME C## S T A T U S: C SINGLE/DOUBLE Conversion: NOT required. C C System Dependence: System routine for Time. C C THIS VERSION IS FOR HW6 C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C>RCS $Header: time.gl,v 2.1 91/11/22 11:45:26 buckley Exp $ C>RCS $Log: time.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:26 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/06 10:52:37 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9 89/06/30 13:30:20 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:32 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:33 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:16 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:33 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE MUST CALL A SYSTEM ROUTINE TO GET THE CURRENT TIME. C IT MUST RETURN THIS TIME IN THE CHARACTER VARIABLE CHTIME C IN THE FORM C C (HH+MM+SS) C C AS REQUIRED BY THE ROUTINE ZZDTTM. CHTIME MUST BE OF LENGTH 10. C ONLY THE SIX CHARACTERS HH MM SS ARE ACTUALLY USED. THE OTHERS C CAN BE ANYTHING, BUT THE HH, MM AND SS MUST BE IN THE CORRECT C POSITION. HH SHOULD BE BETWEEN 0 AND 23, I.E. BASED ON THE 24 HOUR C CLOCK. OF COURSE MM AND SS MUST BE IN THE RANGE 0 TO 59. C C THIS VERSION CALLS A SYSTEM DEPENDENT ROUTINE. C TO IMPLEMENT THIS ON ANOTHER SYSTEM, ONE MAY EITHER C C (A) INCORPORATE AN ALTERNATE VERSION OF ZZTIME; C C (B) USE THE "DUMMY" VERSION OF THIS ROUTINE WITH THE SINGLE C EXECUTABLE STATEMENT CHTIME=' ', IN WHICH CASE NO C TIME INFORMATION WILL APPEAR IN THE OUTPUT. C C## E N T R Y P O I N T S: The natural entry ZZTIME. C## S U B R O U T I N E S: SYSTEM ROUTINE TO GET TIME OF DAY. C## P A R A M E T E R S: NONE are defined. C## L O C A L D E C L: CHARACTER * 24 HWTIME INTEGER * 8 CLOCK_ INTEGER SECS C## S A V E: NONE selected. C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C## D A T A: NONE are set. C## E X E C U T I O N C## E X E C U T I O N CALL DATE_TIME_ (CLOCK_(), HWTIME) CHTIME(2:3) = HWTIME(11:12) CHTIME(5:6) = HWTIME(13:14) READ ( HWTIME(16:16), '(I1)' ) SECS WRITE( CHTIME(8:9), '(I2.2)' ) SECS*6 C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZTIME. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> casesg.mac SUBROUTINE ZZCASE (STRING, TYPE ) C## A R G U M E N T S: CHARACTER *(*) STRING INTEGER TYPE C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NOT REQUIRED. C C SYSTEM DEPENDENCE: SYSTEM ROUTINE FOR CASE C CONVERSION OF LETTERS. C C THIS IS A VERSION FOR MAC/MS C>RCS $HEADER: CASE.GL,V 2.0 90/07/05 12:44:20 BUCKLEY EXP $ C>RCS $LOG: CASE.GL,V $ C>RCS REVISION 2.0 90/07/05 12:44:20 BUCKLEY C>RCS COMMON VERSION FOR TOMS AND GL C>RCS C>RCS REVISION 1.9.1.1 89/06/30 14:59:19 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.9 89/06/30 13:30:11 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 16:07:53 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/20 13:48:39 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C## D E S C R I P T I O N: C THIS CONVERTS EACH LOWER CASE ALPHABETIC LETTER TO C UPPER CASE, OR VICE VERSA. C IF TYPE = CTOUPP, CONVERSION IS LOWER TO UPPER C IF TYPE = CTOLOW, CONVERSION IS UPPER TO LOWER C IF TYPE = CTOCAP, USE UPPER FOR FIRST LETTER; LOWER FOR REST C ALL OTHER CHARACTERS ARE LEFT UNCHANGED. C## E N T R Y P O I N T S: THE NATURAL ENTRY TTOUPPR. C## S U B R O U T I N E S: LEN (INTRINSIC). C## P A R A M E T E R S: INTEGER CTOUPP, CTOLOW, CTOCAP PARAMETER ( CTOUPP = 1, CTOLOW = 2, CTOCAP = 3 ) CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) CHARACTER*(*) PERIOD, COMMA, SEMICN PARAMETER ( PERIOD = '.', COMMA = ',', SEMICN = ';' ) CHARACTER*(*) COLON, DASH, EQUALS PARAMETER ( COLON = ':', DASH = '-', EQUALS = '=' ) CHARACTER*(*) OBRACE, CBRACE, UNDERS PARAMETER ( OBRACE = '{', CBRACE = '}', UNDERS = '_' ) CHARACTER*(*) PLUS, MINUS, EXCLAM PARAMETER ( PLUS = '+', MINUS = '-', EXCLAM = '!' ) CHARACTER*(*) GTHAN, LTHAN, QUESMK PARAMETER ( GTHAN = '>', LTHAN = '<', QUESMK = '?' ) CHARACTER*(*) SLASH, BSLASH, PERCNT PARAMETER ( SLASH = '/', BSLASH = '\\',PERCNT = '%' ) CHARACTER*(*) CARAT, ATSIGN, TILDE PARAMETER ( CARAT = '^', ATSIGN = '@', TILDE = '~' ) C## L O C A L D E C L: INTEGER I, SHIFT LOGICAL FIRST CHARACTER *1 CH C## S A V E: SAVE FIRST, SHIFT C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA FIRST/.TRUE./ C## E X E C U T I O N C## E X E C U T I O N IF (FIRST) THEN FIRST = .FALSE. SHIFT = ICHAR('A') - ICHAR('a') ENDIF I = 0 100 I = I + 1 IF ( I .LE. LEN(STRING) ) THEN IF ( TYPE .EQ. CTOUPP ) THEN IF ('a' .LE. STRING(I:I) .AND. STRING(I:I) .LE. 'z') THEN CH = CHAR( ICHAR(STRING(I:I)) + SHIFT ) ELSE CH = STRING(I:I) ENDIF ELSE IF ( TYPE .EQ. CTOLOW .OR. TYPE .EQ. CTOCAP ) THEN IF ('A' .LE. STRING(I:I) .AND. STRING(I:I) .LE. 'Z') THEN CH = CHAR( ICHAR(STRING(I:I)) - SHIFT ) ELSE CH = STRING(I:I) ENDIF ENDIF STRING(I:I) = CH GOTO 100 ENDIF IF ( TYPE .EQ. CTOCAP .and. - 'a' .LE. STRING(1:1) .AND. STRING(1:1) .LE. 'z') THEN CH = CHAR( ICHAR(STRING(1:1)) + SHIFT ) STRING(1:1) = CH ENDIF C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF TOUPPR. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> datesg.mac SUBROUTINE ZZdate (CHDATE) C## A R G U M E N T S: CHARACTER *(*) CHDATE C## S T A T U S: C SINGLE/DOUBLE Conversion: NOT required. C SYSTEM DEPENDENCE: System routine for date. C C THIS VERSION IS FOR MAC/MS C C>RCS $Header: date.gl,v 2.1 91/11/22 11:45:18 buckley Exp $ C>RCS $Log: date.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:18 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/05 12:50:05 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9 89/06/30 13:30:12 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:26 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:12:13 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:33:41 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:30 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C THIS ROUTINE MUST CALL A SYSTEM ROUTINE TO GET THE CURRENT DATE. C ZZDATE MUST RETURN THIS DATE IN THE CHARACTER VARIABLE CHDATE C IN THE FORM C C (YY+MM+DD) C C AS REQUIRED BY THE ROUTINE ZZDTTM. CHDATE MUST OF LENGTH 10. C ONLY THE 6 CHARACTERS YY MM DD ARE ACTUALLY USED. THE OTHERS C CAN BE ANYTHING, I.E. ONLY THE POSITION OF THE YY MM DD MATTERS. C C THIS MUST CALL A SYSTEM ROUTINE TO GET THE DATE. C TO IMPLEMENT THIS ON ANOTHER SYSTEM, ONE MAY EITHER C C (A) INCORPORATE AN ALTERNATE VERSION OF ZZDATE; C C (B) USE THE "DUMMY" VERSION OF THIS ROUTINE WITH THE SINGLE C EXECUTABLE STATEMENT CHDATE='( + + )', IN WHICH CASE NO C DATE INFORMATION WILL APPEAR IN THE OUTPUT. C## E N T R Y P O I N T S: The natural entry ZZdate. C## S U B R O U T I N E S: System date routine. C## P A R A M E T E R S: NONE are defined. C## L O C A L D E C L: INTEGER MM, DD, YY C## S A V E: NONE selected. C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C## D A T A: NO DATA VALUES SET. C## E X E C U T I O N C## E X E C U T I O N C---- INITIALIZE CHDATE CHDATE = '( + + )' CALL DATE ( MM, DD, YY ) WRITE ( CHDATE(2:3), '(I2.2)' ) YY WRITE ( CHDATE(5:6), '(I2.2)' ) MM WRITE ( CHDATE(8:9), '(I2.2)' ) DD C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZdate. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> mparsg.mac REAL FUNCTION ZZMPAR(I) C!!!! DOUBLE PRECISION FUNCTION ZZMPAR(I) C## A R G U M E N T S: INTEGER I C## S T A T U S: C IGNORE LINES BEGINNING WITH "C!!!!" . C C SYSTEM DEPENDENCE: THE CODE IS VERY DEFINITELY MACHINE DEPENDENT C FOR IT CONTAINS MACHINE PRECISION CONSTANTS C FOR MANY MACHINES, AS DESCRIBED BELOW. C C SINGLE/DOUBLE Conversion: NEEDED (SEE CONVRT). C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C>RCS $Header: mpar.gl,v 2.3 91/11/22 11:45:19 buckley Exp $ C>RCS $Log: mpar.gl,v $ C>RCS Revision 2.3 91/11/22 11:45:19 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.2 91/06/12 14:07:08 buckley C>RCS Added stardent C>RCS C>RCS Revision 2.1 90/07/31 10:57:40 buckley C>RCS Added constants for ieee for pc's C>RCS C>RCS Revision 2.0 90/07/06 10:39:26 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9.1.2 90/06/26 14:24:24 buckley C>RCS Fixed single/double precision constants for sun4 C>RCS C>RCS Revision 1.9.1.1 89/07/01 11:36:48 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.9 89/06/30 13:30:15 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:28 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:23 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:34:59 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:31 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C C THIS IS A MODIFICATION OF THE TWO ROUTINES DPMPAR AND SPMPAR C OBTAINED FROM JORGE MORE. IT HAS BEEN CHANGED ONLY TO CONFORM C WITH MY CONVENTIONS, AND TO ADD STATEMENTS FOR THE CDC C CYBERS WHICH ARE ACCEPTABLE TO FTN5 (FORTRAN '77). THE C OTHER CHANGES ARE: C C 1. THE SINGLE NAME ZZMPAR HAS BEEN USED. IT IS DOUBLE OR SINGLE C PRECISION ACCORDING TO CONVERSION BY CONVRT, JUST AS FOR ALL C OF MY OTHER PROGRAMS. C C 2. THE ROUTINES HAVE BEEN MERGED SO THAT SINGLE AND DOUBLE C PRECISION STATEMENTS WHICH CORRESPOND APPEAR IN PAIRS. C C OTHERWISE ALL OF THE COMMENTS OF THE ORIGINAL AUTHORS APPLY. C THEIR ORIGINAL COMMENTS (UNALTERED) FOR THE DOUBLE PRECISION C VERSION FOLLOW IMMEDIATELY. C C FUNCTION DPMPAR C C THIS FUNCTION PROVIDES DOUBLE PRECISION MACHINE PARAMETERS C WHEN THE APPROPRIATE SET OF DATA STATEMENTS IS ACTIVATED (BY C REMOVING THE C FROM COLUMN 1) AND ALL OTHER DATA STATEMENTS ARE C RENDERED INACTIVE. MOST OF THE PARAMETER VALUES WERE OBTAINED C FROM THE CORRESPONDING BELL LABORATORIES PORT LIBRARY FUNCTION. C C THE FUNCTION STATEMENT IS C C DOUBLE PRECISION FUNCTION DPMPAR(I) C C WHERE C C I IS AN INTEGER INPUT VARIABLE SET TO 1, 2, OR 3 WHICH C SELECTS THE DESIRED MACHINE PARAMETER. IF THE MACHINE HAS C T BASE B DIGITS AND ITS SMALLEST AND LARGEST EXPONENTS ARE C EMIN AND EMAX, RESPECTIVELY, THEN THESE PARAMETERS ARE C C DPMPAR(1) B**(1 - T), THE MACHINE PRECISION, C C DPMPAR(2) B**(EMIN - 1), THE SMALLEST MAGNITUDE, C C DPMPAR(3) B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE C C## E N T R Y P O I N T S: The natural entry ZZmpar. C## S U B R O U T I N E S: NONE are called. C## P A R A M E T E R S: NONE are defined. C C## L O C A L D E C L: C NOTE THAT THESE ARRAYS MUST HAVE DIMENSIONS 2 AND 4, RATHER C THAN 1 AND 2 AS ONE MIGHT EXPECT, BECAUSE OF THE PDP-11 C DEFINITIONS. INTEGER MCHEPS(2) C!!!! INTEGER MCHEPS(4) INTEGER MINMAG(2) C!!!! INTEGER MINMAG(4) INTEGER MAXMAG(2) C!!!! INTEGER MAXMAG(4) REAL RMACH(3) C!!!! DOUBLE PRECISION DMACH(3) INTEGER EMIN, EMAX, IMACH(10) REAL B, BINV, BM1, ONE, W, Z C!!!! DOUBLE PRECISION B, BINV, BM1, ONE, W, Z C## S A V E: SAVE RMACH C!!!! SAVE DMACH SAVE IMACH C## E Q U I V A L E N C E S: EQUIVALENCE (RMACH(1),MCHEPS(1)) C!!!! EQUIVALENCE (DMACH(1),MCHEPS(1)) EQUIVALENCE (RMACH(2),MINMAG(1)) C!!!! EQUIVALENCE (DMACH(2),MINMAG(1)) EQUIVALENCE (RMACH(3),MAXMAG(1)) C!!!! EQUIVALENCE (DMACH(3),MAXMAG(1)) C## C O M M O N: NONE is defined. C## D A T A: C-----MACHINE CONSTANTS FOR THE APPLE MACINTOSH WITH C MICROSOFT FORTRAN (AS DEVELOPED BY ABSOFT). C THESE SHOULD BE THE SAME FOR ANY 68000/68020. DATA MCHEPS(1) / O'06400000000' / C!!!! DATA MCHEPS(1),MCHEPS(2) / O'07454000000', O'00000000000' / DATA MINMAG(1) / O'00040000000' / C!!!! DATA MINMAG(1),MINMAG(2) / O'00004000000', O'00000000000' / DATA MAXMAG(1) / O'17737777777' / C!!!! DATA MAXMAG(1),MAXMAG(2) / O'17773777777', O'37777777777' / C## E X E C U T I O N C## E X E C U T I O N ZZMPAR = RMACH(I) C!!!! ZZMPAR = DMACH(I) C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZmpar. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> opensg.mac SUBROUTINE ZZOPEN ( IUNIT, FLAG, INAME, * , RECLEN ) C## A R G U M E N T S: INTEGER IUNIT, RECLEN LOGICAL FLAG CHARACTER *(*) INAME C## S T A T U S: C IGNORE LINES BEGINNING WITH "C!!!!" . C C SINGLE/DOUBLE Conversion: NEEDED (SEE CONVRT). C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR C OPENING AND CLOSING FILES. C C THIS VERSION IS FOR MAC/MS C C>RCS $Header: open.gl,v 2.1 91/11/22 11:45:21 buckley Exp $ C>RCS $Log: open.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:21 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/06 10:43:19 buckley C>RCS Common version for TOMS and MT C>RCS C>RCS Revision 1.9.1.2 89/07/01 11:51:41 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.9.1.1 89/07/01 11:36:50 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.9 89/06/30 13:30:16 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:29 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:26 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:02 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:31 buckley C>RCS Initial revision C>RCS C## D E S C R I P T I O N: C C THIS OPENS THE FILES NEEDED FOR TESTPACK AND KEEPS TRACK OF C WHICH ARE OPEN AND WHICH ARE NOT. IT ALSO SUPPLIES THE APPRO- C PRIATE ARGUMENTS FOR EACH FILE. C C IF NAME IS NOT BLANK ON ENTRY, THEN THE FILE IS OPENED C WITH THE NAME GIVEN. OTHERWISE, NO NAME IS SPECIFIED WHEN C OPENING THE FILE. C C THE OPEN IS ONLY DONE IF "FLAG" IS TRUE. C C IF RECLEN IS NOT EQUAL TO ZERO, THEN THE FILE IS OPENED C AS DIRECT ACCESS UNFORMATTED. C C IF RECLEN IS EQUAL TO ZERO, THEN THE FILE IS OPENED C FOR FORMATTED SEQUENTIAL ACCESS. C C## E N T R Y P O I N T S: The natural entry ZZopen and ZZclse C## S U B R O U T I N E S: OPEN, CLOSE, REAL ...INTRINSIC C ZZERRM ...FOR ERROR MESSAGES. C## P A R A M E T E R S: INTEGER FILENL, NFILES PARAMETER ( FILENL = 80, NFILES = 15 ) CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) CHARACTER*(*) PERIOD, COMMA, SEMICN PARAMETER ( PERIOD = '.', COMMA = ',', SEMICN = ';' ) CHARACTER*(*) COLON, DASH, EQUALS PARAMETER ( COLON = ':', DASH = '-', EQUALS = '=' ) CHARACTER*(*) OBRACE, CBRACE, UNDERS PARAMETER ( OBRACE = '{', CBRACE = '}', UNDERS = '_' ) CHARACTER*(*) PLUS, MINUS, EXCLAM PARAMETER ( PLUS = '+', MINUS = '-', EXCLAM = '!' ) CHARACTER*(*) GTHAN, LTHAN, QUESMK PARAMETER ( GTHAN = '>', LTHAN = '<', QUESMK = '?' ) CHARACTER*(*) SLASH, BSLASH, PERCNT PARAMETER ( SLASH = '/', BSLASH = '\\',PERCNT = '%' ) CHARACTER*(*) CARAT, ATSIGN, TILDE PARAMETER ( CARAT = '^', ATSIGN = '@', TILDE = '~' ) LOGICAL T, F PARAMETER ( T = .TRUE., F = .FALSE. ) CHARACTER*(*) TRUE, QT, FALSE, QF PARAMETER ( TRUE = 'TRUE', QT = 'T', FALSE = 'FALSE', QF = 'F' ) INTEGER ITRUE, IFALSE PARAMETER ( ITRUE = 1, IFALSE = 0 ) REAL RTRUE, RFALSE C!!!! DOUBLE PRECISION RTRUE, RFALSE PARAMETER ( RTRUE = 1.D0, RFALSE = 0.D0 ) INTEGER CTOUPP, CTOLOW, CTOCAP PARAMETER ( CTOUPP = 1, CTOLOW = 2, CTOCAP = 3 ) INTEGER PREPRC, DAUF, INPTUN PARAMETER ( PREPRC = 1, DAUF = 2, INPTUN = 3 ) INTEGER TEMPUN, STDIN, TRMOUT PARAMETER ( TEMPUN = 4, STDIN = 5, TRMOUT = 6 ) INTEGER WRITUN, TRACUN, SUMMUN PARAMETER ( WRITUN = 7, TRACUN = 8, SUMMUN = 9 ) INTEGER COPYUN, TEXUN PARAMETER ( COPYUN =10, TEXUN =11 ) CHARACTER *(*) SEQ , DIR PARAMETER ( SEQ = 'SEQUENTIAL', DIR = 'DIRECT' ) CHARACTER *(*) UNKN , NEW PARAMETER ( UNKN = 'UNKNOWN' , NEW = 'NEW' ) CHARACTER *(*) OLD , SCR PARAMETER ( OLD = 'OLD' , SCR = 'SCRATCH' ) CHARACTER *(*) DEL , KEEP PARAMETER ( DEL = 'DELETE' , KEEP = 'KEEP' ) CHARACTER *(*) FMT , UNFRMT PARAMETER ( FMT = 'FORMATTED' , UNFRMT = 'UNFORMATTED' ) C## L O C A L D E C L: INTEGER ERRINT, UNIT LOGICAL OPENFS(NFILES), REW, OPENIT, COPY CHARACTER STAT*7, ACCS*10, FRMT*11 CHARACTER *(FILENL) COPYNM, NAME REAL RD C!!!! DOUBLE PRECISION RD C## S A V E: SAVE OPENFS, COPY, COPYNM C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA OPENFS / NFILES * .FALSE. / DATA COPY/F/, COPYNM/BLANK/ C## E X E C U T I O N C## E X E C U T I O N C----- DEFINE A STATEMENT FUNCTION. RD(UNIT) = REAL(UNIT) C!!!! RD(UNIT) = DBLE(UNIT) IF ( FLAG ) THEN IF ( RECLEN .EQ. 0 ) THEN ACCS = SEQ FRMT = FMT ELSE ACCS = DIR FRMT = UNFRMT ENDIF UNIT = IUNIT NAME = INAME 100 CONTINUE OPENIT = .NOT. OPENFS(UNIT) REW = .FALSE. IF ( UNIT .EQ. SUMMUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. TRMOUT ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. STDIN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. PREPRC) THEN STAT = OLD REW = .TRUE. ELSE IF ( UNIT .EQ. TEMPUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. WRITUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. TRACUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. DAUF ) THEN STAT = OLD ELSE IF ( UNIT .EQ. COPYUN ) THEN STAT = UNKN COPY = T ELSE IF ( UNIT .EQ. INPTUN ) THEN STAT = OLD REW = .TRUE. ELSE CALL ZZERRM ( RD(UNIT), *91000, - 'IS REQUEST TO OPEN UNKNOWN UNIT # ' ) ENDIF C FOR THE "CHOICE OF UNIT..." 500 IF ( OPENIT ) THEN IF ( NAME .EQ. BLANK ) THEN C PRINT*,'OPENING ',UNIT,'NAME=' IF ( RECLEN .EQ. 0 ) THEN OPEN ( UNIT = UNIT, - ERR = 1000, - IOSTAT = ERRINT, - STATUS = STAT, - ACCESS = ACCS, - FORM = FRMT ) ELSE OPEN ( UNIT = UNIT, - ERR = 1000, - IOSTAT = ERRINT, - STATUS = STAT, - ACCESS = ACCS, - RECL = RECLEN, - FORM = FRMT ) ENDIF ELSE C NAMED FILE IF ( RECLEN .EQ. 0 ) THEN C PRINT*,'OPENING ',UNIT,'NAME=',NAME(1:20) OPEN ( UNIT = UNIT, - ERR = 1000, - IOSTAT = ERRINT, - FILE = NAME, - STATUS = STAT, - ACCESS = ACCS, - FORM = FRMT ) C PRINT*,'OK' ELSE OPEN ( UNIT = UNIT, - ERR = 1000, - FILE = NAME, - IOSTAT = ERRINT, - STATUS = STAT, - ACCESS = ACCS, - RECL = RECLEN, - FORM = FRMT ) ENDIF ENDIF ENDIF C FOR EACH UNIT FROM 1 TO NFILES WE NEED TO KEEP A RECORD OF C WHETHER IT IS CURRENTLY OPEN. OPENFS(UNIT) = .TRUE. IF ( REW .AND. RECLEN .EQ. 0 ) THEN REWIND UNIT ENDIF GOTO 1025 1000 IF ( UNIT .EQ. DAUF ) THEN C CREATE THE DAUF. STAT = NEW GOTO 500 ELSE GOTO 1050 ENDIF 1025 CONTINUE IF ( COPY .AND. UNIT .EQ. STDIN ) THEN UNIT = COPYUN NAME = COPYNM GOTO 100 ENDIF ENDIF C FOR THE "IF FLAG..." GOTO 90000 1050 CONTINUE GOTO 91000 C## E N T R Y ZZCLSE: ENTRY ZZCLSE ( IUNIT, * ) STAT = KEEP IF ( IUNIT .EQ. SUMMUN ) THEN STAT = KEEP ELSE IF ( IUNIT .EQ. TRMOUT ) THEN ELSE IF ( IUNIT .EQ. STDIN ) THEN ELSE IF ( IUNIT .EQ. TEMPUN ) THEN STAT = KEEP ELSE IF ( IUNIT .EQ. WRITUN ) THEN ELSE IF ( IUNIT .EQ. TRACUN ) THEN ELSE IF ( IUNIT .EQ. COPYUN ) THEN STAT = KEEP COPY = F ELSE IF ( IUNIT .EQ. DAUF ) THEN ELSE IF ( IUNIT .EQ. PREPRC ) THEN ELSE IF ( IUNIT .EQ. INPTUN ) THEN ELSE CALL ZZERRM ( RD(IUNIT), *91000, - 'IS IGNORING REQUEST TO CLOSE UNKNOWN UNIT #' ) ENDIF IF ( OPENFS(IUNIT) ) THEN C PRINT*,'CLOSING ',IUNIT CLOSE ( UNIT = IUNIT, STATUS = STAT ) OPENFS(IUNIT) = .FALSE. ENDIF RETURN C## E X I T 90000 CONTINUE CALL ZZCASE (STAT,CTOUPP) IF ( IUNIT .EQ. DAUF .AND. STAT .EQ. NEW ) THEN GOTO 91000 ELSE RETURN ENDIF 91000 RETURN 1 C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZOPEN. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> reclsg.mac INTEGER FUNCTION ZZRECL ( CPERLN, IPERLN, LPERLN, RPERLN ) C## A R G U M E N T S: INTEGER CPERLN, IPERLN, LPERLN, RPERLN C## S T A T U S: C SINGLE/DOUBLE Conversion: Needed (See CONVRT). C C Ignore lines beginning with "C!!!!" . C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C System Dependence: System routine for direct C access unformatted record length C C THIS VERSION IS FOR MAC/MS C C>RCS $Header: recl.gl,v 2.1 91/11/22 11:45:23 buckley Exp $ C>RCS $Log: recl.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:23 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/16 14:39:15 buckley C>RCS Added Lahey C>RCS C>RCS Revision 1.9 89/06/30 13:30:18 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:30 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:29 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:07 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:32 buckley C>RCS Initial revision C>RCS C## D E S C R I P T I O N: C C THIS ROUTINE USES FOUR INTEGER CONSTANTS NEEDED TO DETERMINE C THE LENGTH OF AN UNFORMATTED RECORD FOR READING AND WRITING C DIRECT ACCESS FILES. THE PROCESSOR IS ASSUMED, ACCORDING C TO THE FORTRAN STANDARD, TO WRITE UNFORMATTED RECORDS C IN "PROCESSOR DEFINED UNITS", I.E. IN PDU'S. C C HERE WE MUST DEFINE FOUR CONSTANTS: C C CHARS THE NUMBER OF PDU'S NEEDED TO WRITE ONE CHARACTER; C INTS THE NUMBER OF PDU'S NEEDED TO WRITE ONE INTEGER VALUE; C LOGS THE NUMBER OF PDU'S NEEDED TO WRITE ONE LOGICAL VALUE; C REALS THE NUMBER OF PDU'S NEEDED TO WRITE ONE REAL(DP) VALUE. C C NOTE THAT IT MAY HAPPEN (PARTICULARLY WITH CHARACTER OR LOGICAL C DATA) THAT SEVERAL VALUES MAY FIT INTO ONE PDU. IN THIS CASE, SET C THE CONSTANT TO A NEGATIVE VALUE. FOR EXAMPLE, ON A CYBER, A PDU C IS ONE WORD AND 10 CHARACTERS FIT PER WORD. IN THIS CASE, CHARS C IS SET TO -10. BUT ON A VAX, A PDU IS ONE BYTE AND AN INTEGER C OCCUPIES 4 BYTES, SO INTS IS SET TO 4. NOTE THAT THE VALUES FOR C 'REALS' WILL GENERALLY BE DIFFERENT FOR THE SINGLE AND DOUBLE C PRECISION VERSIONS ON THE SAME MACHINE. C C ON ENTRY, THE FOUR ARGUMENTS INDICATE HOW MANY VALUES OF EACH OF C THE FOUR BASIC TYPES ARE REQUIRED TO FIT IN ONE DIRECT ACCESS C UNFORMATTED RECORD. THIS ROUTINE WILL DETERMINE THE MINIMUM RECORD C LENGTH NEEDED TO SATISFY ALL FOUR REQUIREMENTS. THAT VALUE WILL BE C RETURNED AS THE VALUE OF THE FUNCTION ZZRECL. C C IT WILL THEN *RETURN* IN EACH OF THE FOUR ARGUMENTS THE *ACTUAL* C NUMBER OF EACH OF THESE WHICH CAN FIT IN THE RECORD OF THE SIZE C DETERMINED. C C N.B. **** THIS ROUTINE ASSUMES *NO MIXING* OF DATA TYPES ON C ANY ONE RECORD WHEN USING DIRECT ACCESS UNFORMATTED I/O. C THUS EACH TIME A RECORD IS WRITTEN, IT CONTAINS *ONLY* C CHARACTER DATA, OR *ONLY* INTEGER DATA, OR *ONLY* REAL C DATA, OR *ONLY* LOGICAL DATA. ANY MIXING WOULD C TOTALLY DESTROY ANY HOPE OF PORTABILITY TO SOME SYSTEMS. C C## E N T R Y P O I N T S: The natural entry ZZRECL. C## S U B R O U T I N E S: ABS, MAX ... INTRINSIC C C## P A R A M E T E R S: INTEGER CHARS, INTS, LOGS, REALS PARAMETER ( CHARS = 1, INTS = 4, LOGS = 4, REALS = 4 ) C!!!! PARAMETER ( CHARS = 1, INTS = 4, LOGS = 4, REALS = 8 ) C## L O C A L D E C L: INTEGER N C## S A V E: NONE selected. C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C## D A T A: NONE are set. C## E X E C U T I O N C## E X E C U T I O N ZZRECL = 1 IF ( CHARS .LT. 0 ) THEN N = ABS(CHARS) N = ( CPERLN + N - 1 ) / N ELSE N = CPERLN * CHARS ENDIF ZZRECL = MAX ( ZZRECL, N ) IF ( INTS .LT. 0 ) THEN N = ABS(INTS) N = ( IPERLN + N - 1 ) / N ELSE N = IPERLN * INTS ENDIF ZZRECL = MAX ( ZZRECL, N ) IF ( LOGS .LT. 0 ) THEN N = ABS(LOGS) N = ( LPERLN + N - 1 ) / N ELSE N = LPERLN * LOGS ENDIF ZZRECL = MAX ( ZZRECL, N ) IF ( REALS .LT. 0 ) THEN N = ABS(REALS) N = ( RPERLN + N - 1 ) / N ELSE N = RPERLN * REALS ENDIF ZZRECL = MAX ( ZZRECL, N ) C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZRECL. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> secssg.mac SUBROUTINE ZZSECS(SECS) C## A R G U M E N T S: REAL SECS C!!!! DOUBLE PRECISION SECS C## S T A T U S: C SINGLE/DOUBLE Conversion: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C SYSTEM DEPENDENCE: System routine for CPU usage. C This version is for MAC/MS C C>RCS $Header: secs.gl,v 2.1 91/11/22 11:45:25 buckley Exp $ C>RCS $Log: secs.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:25 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/06 10:48:10 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9 89/06/30 13:30:19 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:31 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:31 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:12 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:33 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C THIS SUBROUTINE SHOULD OBTAIN (FROM THE OPERATING SYSTEM) THE C AMOUNT OF CPU TIME USED BY THE CALLING PROGRAM SINCE THE C EXECUTION BEGAN. IF DESIRABLE, "SECS" CAN ALSO BE CONVERTED C TO DOUBLE PRECISION (SEE CONVRT). HOWEVER, THE ROUTINE ACTUALLY C WORKS TOTALLY AS A SINGLE PRECISION ROUTINE, EXCEPT THAT THE C VALUE WHICH IS PASSED BACK MAY BE IN EITHER PRECISION AS C APPROPRIATE. C TIME IS MEASURED FROM THE FIRST CALL TO ZZSECS. THUS C ON THE FIRST CALL TO ZZSECS, A TIME OF 0.0 SECONDS IS ALWAYS C RETURNED. C## E N T R Y P O I N T S: The natural entry ZZSECS. C## S U B R O U T I N E S: A SYSTEM CLOCK. C## P A R A M E T E R S: REAL ZERO, SHIFT, SIXTY PARAMETER ( ZERO = 0.0E0, SHIFT = 2.0**32, SIXTY = 60.0 ) C## L O C A L D E C L: LOGICAL FIRST INCLUDE TOOLBX.PAR INTEGER SECNDS, TOOLBX REAL STTIME, SEC C## S A V E: SAVE FIRST, STTIME C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C## D A T A: DATA FIRST/.TRUE./ C## E X E C U T I O N C## E X E C U T I O N IF ( FIRST ) THEN FIRST = .FALSE. STTIME = REAL(TOOLBX(TICKCOUNT))/SIXTY SEC = ZERO ELSE SECNDS = TOOLBX(TICKCOUNT) SEC = REAL(SECNDS)/SIXTY - STTIME IF ( SEC .LT. ZERO ) THEN SEC = SEC + SHIFT ENDIF ENDIF SECS = SEC C!!!! SECS = DBLE(SEC) C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZSECS. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> timesg.mac SUBROUTINE ZZTIME ( CHTIME ) C## A R G U M E N T S: CHARACTER *(*) CHTIME C## S T A T U S: C SINGLE/DOUBLE Conversion: NOT required. C C System Dependence: System routine for Time. C C THIS VERSION IS FOR MAC/MS C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C>RCS $Header: time.gl,v 2.1 91/11/22 11:45:26 buckley Exp $ C>RCS $Log: time.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:26 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/06 10:52:37 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9 89/06/30 13:30:20 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:32 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:33 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:16 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:33 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE MUST CALL A SYSTEM ROUTINE TO GET THE CURRENT TIME. C IT MUST RETURN THIS TIME IN THE CHARACTER VARIABLE CHTIME C IN THE FORM C C (HH+MM+SS) C C AS REQUIRED BY THE ROUTINE ZZDTTM. CHTIME MUST BE OF LENGTH 10. C ONLY THE SIX CHARACTERS HH MM SS ARE ACTUALLY USED. THE OTHERS C CAN BE ANYTHING, BUT THE HH, MM AND SS MUST BE IN THE CORRECT C POSITION. HH SHOULD BE BETWEEN 0 AND 23, I.E. BASED ON THE 24 HOUR C CLOCK. OF COURSE MM AND SS MUST BE IN THE RANGE 0 TO 59. C C THIS VERSION CALLS A SYSTEM DEPENDENT ROUTINE. C TO IMPLEMENT THIS ON ANOTHER SYSTEM, ONE MAY EITHER C C (A) INCORPORATE AN ALTERNATE VERSION OF ZZTIME; C C (B) USE THE "DUMMY" VERSION OF THIS ROUTINE WITH THE SINGLE C EXECUTABLE STATEMENT CHTIME=' ', IN WHICH CASE NO C TIME INFORMATION WILL APPEAR IN THE OUTPUT. C C## E N T R Y P O I N T S: The natural entry ZZTIME. C## S U B R O U T I N E S: SYSTEM ROUTINE TO GET TIME OF DAY. C## P A R A M E T E R S: NONE are defined. C## L O C A L D E C L: INTEGER SECNDS, MINUTS, HOURS C## S A V E: NONE selected. C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C## D A T A: NONE are set. C## E X E C U T I O N C## E X E C U T I O N CALL TIME(SECNDS) MINUTS = SECNDS / 60 HOURS = MINUTS / 60 MINUTS = MINUTS - 60*HOURS SECNDS = SECNDS - 60 * ( MINUTS + 60*HOURS ) WRITE ( CHTIME(2:3), '(I2.2)' ) HOURS WRITE ( CHTIME(5:6), '(I2.2)' ) MINUTS WRITE ( CHTIME(8:9), '(I2.2)' ) SECNDS C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZTIME. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> casesg.sn3 SUBROUTINE ZZCASE (STRING, TYPE ) C## A R G U M E N T S: CHARACTER *(*) STRING INTEGER TYPE C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NOT REQUIRED. C C SYSTEM DEPENDENCE: SYSTEM ROUTINE FOR CASE C CONVERSION OF LETTERS. C C THIS IS A VERSION FOR SUN3 C>RCS $HEADER: CASE.GL,V 2.0 90/07/05 12:44:20 BUCKLEY EXP $ C>RCS $LOG: CASE.GL,V $ C>RCS REVISION 2.0 90/07/05 12:44:20 BUCKLEY C>RCS COMMON VERSION FOR TOMS AND GL C>RCS C>RCS REVISION 1.9.1.1 89/06/30 14:59:19 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.9 89/06/30 13:30:11 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 16:07:53 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/20 13:48:39 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C## D E S C R I P T I O N: C THIS CONVERTS EACH LOWER CASE ALPHABETIC LETTER TO C UPPER CASE, OR VICE VERSA. C IF TYPE = CTOUPP, CONVERSION IS LOWER TO UPPER C IF TYPE = CTOLOW, CONVERSION IS UPPER TO LOWER C IF TYPE = CTOCAP, USE UPPER FOR FIRST LETTER; LOWER FOR REST C ALL OTHER CHARACTERS ARE LEFT UNCHANGED. C## E N T R Y P O I N T S: THE NATURAL ENTRY TTOUPPR. C## S U B R O U T I N E S: LEN (INTRINSIC). C## P A R A M E T E R S: INTEGER CTOUPP, CTOLOW, CTOCAP PARAMETER ( CTOUPP = 1, CTOLOW = 2, CTOCAP = 3 ) CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) CHARACTER*(*) PERIOD, COMMA, SEMICN PARAMETER ( PERIOD = '.', COMMA = ',', SEMICN = ';' ) CHARACTER*(*) COLON, DASH, EQUALS PARAMETER ( COLON = ':', DASH = '-', EQUALS = '=' ) CHARACTER*(*) OBRACE, CBRACE, UNDERS PARAMETER ( OBRACE = '{', CBRACE = '}', UNDERS = '_' ) CHARACTER*(*) PLUS, MINUS, EXCLAM PARAMETER ( PLUS = '+', MINUS = '-', EXCLAM = '!' ) CHARACTER*(*) GTHAN, LTHAN, QUESMK PARAMETER ( GTHAN = '>', LTHAN = '<', QUESMK = '?' ) CHARACTER*(*) SLASH, BSLASH, PERCNT PARAMETER ( SLASH = '/', BSLASH = '\\',PERCNT = '%' ) CHARACTER*(*) CARAT, ATSIGN, TILDE PARAMETER ( CARAT = '^', ATSIGN = '@', TILDE = '~' ) C## L O C A L D E C L: INTEGER I, SHIFT LOGICAL FIRST CHARACTER *1 CH C## S A V E: SAVE FIRST, SHIFT C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA FIRST/.TRUE./ C## E X E C U T I O N C## E X E C U T I O N IF (FIRST) THEN FIRST = .FALSE. SHIFT = ICHAR('A') - ICHAR('a') ENDIF I = 0 100 I = I + 1 IF ( I .LE. LEN(STRING) ) THEN IF ( TYPE .EQ. CTOUPP ) THEN IF ('a' .LE. STRING(I:I) .AND. STRING(I:I) .LE. 'z') THEN CH = CHAR( ICHAR(STRING(I:I)) + SHIFT ) ELSE CH = STRING(I:I) ENDIF ELSE IF ( TYPE .EQ. CTOLOW .OR. TYPE .EQ. CTOCAP ) THEN IF ('A' .LE. STRING(I:I) .AND. STRING(I:I) .LE. 'Z') THEN CH = CHAR( ICHAR(STRING(I:I)) - SHIFT ) ELSE CH = STRING(I:I) ENDIF ENDIF STRING(I:I) = CH GOTO 100 ENDIF IF ( TYPE .EQ. CTOCAP .and. - 'a' .LE. STRING(1:1) .AND. STRING(1:1) .LE. 'z') THEN CH = CHAR( ICHAR(STRING(1:1)) + SHIFT ) STRING(1:1) = CH ENDIF C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF TOUPPR. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> datesg.sn3 SUBROUTINE ZZdate (CHDATE) C## A R G U M E N T S: CHARACTER *(*) CHDATE C## S T A T U S: C SINGLE/DOUBLE Conversion: NOT required. C SYSTEM DEPENDENCE: System routine for date. C C THIS VERSION IS FOR SUN3 C C>RCS $Header: date.gl,v 2.1 91/11/22 11:45:18 buckley Exp $ C>RCS $Log: date.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:18 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/05 12:50:05 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9 89/06/30 13:30:12 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:26 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:12:13 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:33:41 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:30 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C THIS ROUTINE MUST CALL A SYSTEM ROUTINE TO GET THE CURRENT DATE. C ZZDATE MUST RETURN THIS DATE IN THE CHARACTER VARIABLE CHDATE C IN THE FORM C C (YY+MM+DD) C C AS REQUIRED BY THE ROUTINE ZZDTTM. CHDATE MUST OF LENGTH 10. C ONLY THE 6 CHARACTERS YY MM DD ARE ACTUALLY USED. THE OTHERS C CAN BE ANYTHING, I.E. ONLY THE POSITION OF THE YY MM DD MATTERS. C C THIS MUST CALL A SYSTEM ROUTINE TO GET THE DATE. C TO IMPLEMENT THIS ON ANOTHER SYSTEM, ONE MAY EITHER C C (A) INCORPORATE AN ALTERNATE VERSION OF ZZDATE; C C (B) USE THE "DUMMY" VERSION OF THIS ROUTINE WITH THE SINGLE C EXECUTABLE STATEMENT CHDATE='( + + )', IN WHICH CASE NO C DATE INFORMATION WILL APPEAR IN THE OUTPUT. C## E N T R Y P O I N T S: The natural entry ZZdate. C## S U B R O U T I N E S: System date routine. C## P A R A M E T E R S: INTEGER CTOUPP, CTOLOW, CTOCAP PARAMETER ( CTOUPP = 1, CTOLOW = 2, CTOCAP = 3 ) C## L O C A L D E C L: CHARACTER * 24 UNXDAT CHARACTER * 3 NAME (12), TEMP INTEGER I C## S A V E: SAVE NAME C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C## D A T A: DATA NAME /'JAN','FEB','MAR','APR','MAY','JUN', - 'JUL','AUG','SEP','OCT','NOV','DEC' / C## E X E C U T I O N C## E X E C U T I O N C---- INITIALIZE CHDATE CHDATE = '( + + )' CALL FDATE(UNXDAT) CHDATE(2:3) = UNXDAT(23:24) CHDATE(8:9) = UNXDAT(9:10) TEMP = UNXDAT(5:7) CALL ZZCASE(TEMP, CTOUPP) DO 100 I = 1,12 IF ( TEMP .EQ. NAME(I) ) THEN WRITE ( CHDATE(5:6), '(I2.2)' ) I GOTO 90000 ENDIF 100 CONTINUE C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZdate. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> mparsg.sn3 REAL FUNCTION ZZMPAR(I) C!!!! DOUBLE PRECISION FUNCTION ZZMPAR(I) C## A R G U M E N T S: INTEGER I C## S T A T U S: C IGNORE LINES BEGINNING WITH "C!!!!" . C C SYSTEM DEPENDENCE: THE CODE IS VERY DEFINITELY MACHINE DEPENDENT C FOR IT CONTAINS MACHINE PRECISION CONSTANTS C FOR MANY MACHINES, AS DESCRIBED BELOW. C C SINGLE/DOUBLE Conversion: NEEDED (SEE CONVRT). C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C>RCS $Header: mpar.gl,v 2.3 91/11/22 11:45:19 buckley Exp $ C>RCS $Log: mpar.gl,v $ C>RCS Revision 2.3 91/11/22 11:45:19 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.2 91/06/12 14:07:08 buckley C>RCS Added stardent C>RCS C>RCS Revision 2.1 90/07/31 10:57:40 buckley C>RCS Added constants for ieee for pc's C>RCS C>RCS Revision 2.0 90/07/06 10:39:26 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9.1.2 90/06/26 14:24:24 buckley C>RCS Fixed single/double precision constants for sun4 C>RCS C>RCS Revision 1.9.1.1 89/07/01 11:36:48 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.9 89/06/30 13:30:15 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:28 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:23 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:34:59 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:31 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C C THIS IS A MODIFICATION OF THE TWO ROUTINES DPMPAR AND SPMPAR C OBTAINED FROM JORGE MORE. IT HAS BEEN CHANGED ONLY TO CONFORM C WITH MY CONVENTIONS, AND TO ADD STATEMENTS FOR THE CDC C CYBERS WHICH ARE ACCEPTABLE TO FTN5 (FORTRAN '77). THE C OTHER CHANGES ARE: C C 1. THE SINGLE NAME ZZMPAR HAS BEEN USED. IT IS DOUBLE OR SINGLE C PRECISION ACCORDING TO CONVERSION BY CONVRT, JUST AS FOR ALL C OF MY OTHER PROGRAMS. C C 2. THE ROUTINES HAVE BEEN MERGED SO THAT SINGLE AND DOUBLE C PRECISION STATEMENTS WHICH CORRESPOND APPEAR IN PAIRS. C C OTHERWISE ALL OF THE COMMENTS OF THE ORIGINAL AUTHORS APPLY. C THEIR ORIGINAL COMMENTS (UNALTERED) FOR THE DOUBLE PRECISION C VERSION FOLLOW IMMEDIATELY. C C FUNCTION DPMPAR C C THIS FUNCTION PROVIDES DOUBLE PRECISION MACHINE PARAMETERS C WHEN THE APPROPRIATE SET OF DATA STATEMENTS IS ACTIVATED (BY C REMOVING THE C FROM COLUMN 1) AND ALL OTHER DATA STATEMENTS ARE C RENDERED INACTIVE. MOST OF THE PARAMETER VALUES WERE OBTAINED C FROM THE CORRESPONDING BELL LABORATORIES PORT LIBRARY FUNCTION. C C THE FUNCTION STATEMENT IS C C DOUBLE PRECISION FUNCTION DPMPAR(I) C C WHERE C C I IS AN INTEGER INPUT VARIABLE SET TO 1, 2, OR 3 WHICH C SELECTS THE DESIRED MACHINE PARAMETER. IF THE MACHINE HAS C T BASE B DIGITS AND ITS SMALLEST AND LARGEST EXPONENTS ARE C EMIN AND EMAX, RESPECTIVELY, THEN THESE PARAMETERS ARE C C DPMPAR(1) B**(1 - T), THE MACHINE PRECISION, C C DPMPAR(2) B**(EMIN - 1), THE SMALLEST MAGNITUDE, C C DPMPAR(3) B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE C C## E N T R Y P O I N T S: The natural entry ZZmpar. C## S U B R O U T I N E S: NONE are called. C## P A R A M E T E R S: NONE are defined. C C## L O C A L D E C L: C NOTE THAT THESE ARRAYS MUST HAVE DIMENSIONS 2 AND 4, RATHER C THAN 1 AND 2 AS ONE MIGHT EXPECT, BECAUSE OF THE PDP-11 C DEFINITIONS. INTEGER MCHEPS(2) C!!!! INTEGER MCHEPS(4) INTEGER MINMAG(2) C!!!! INTEGER MINMAG(4) INTEGER MAXMAG(2) C!!!! INTEGER MAXMAG(4) REAL RMACH(3) C!!!! DOUBLE PRECISION DMACH(3) INTEGER EMIN, EMAX, IMACH(10) REAL B, BINV, BM1, ONE, W, Z C!!!! DOUBLE PRECISION B, BINV, BM1, ONE, W, Z C## S A V E: SAVE RMACH C!!!! SAVE DMACH SAVE IMACH C## E Q U I V A L E N C E S: EQUIVALENCE (RMACH(1),MCHEPS(1)) C!!!! EQUIVALENCE (DMACH(1),MCHEPS(1)) EQUIVALENCE (RMACH(2),MINMAG(1)) C!!!! EQUIVALENCE (DMACH(2),MINMAG(1)) EQUIVALENCE (RMACH(3),MAXMAG(1)) C!!!! EQUIVALENCE (DMACH(3),MAXMAG(1)) C## C O M M O N: NONE is defined. C## D A T A: C-----MACHINE CONSTANTS FOR THE APPLE MACINTOSH WITH C MICROSOFT FORTRAN (AS DEVELOPED BY ABSOFT). C THESE SHOULD BE THE SAME FOR ANY 68000/68020. DATA MCHEPS(1) / O'06400000000' / C!!!! DATA MCHEPS(1),MCHEPS(2) / O'07454000000', O'00000000000' / DATA MINMAG(1) / O'00040000000' / C!!!! DATA MINMAG(1),MINMAG(2) / O'00004000000', O'00000000000' / DATA MAXMAG(1) / O'17737777777' / C!!!! DATA MAXMAG(1),MAXMAG(2) / O'17773777777', O'37777777777' / C## E X E C U T I O N C## E X E C U T I O N ZZMPAR = RMACH(I) C!!!! ZZMPAR = DMACH(I) C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZmpar. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> opensg.sn3 SUBROUTINE ZZOPEN ( IUNIT, FLAG, INAME, * , RECLEN ) C## A R G U M E N T S: INTEGER IUNIT, RECLEN LOGICAL FLAG CHARACTER *(*) INAME C## S T A T U S: C IGNORE LINES BEGINNING WITH "C!!!!" . C C SINGLE/DOUBLE Conversion: NEEDED (SEE CONVRT). C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR C OPENING AND CLOSING FILES. C C THIS VERSION IS FOR SUN3 C C>RCS $Header: open.gl,v 2.1 91/11/22 11:45:21 buckley Exp $ C>RCS $Log: open.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:21 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/06 10:43:19 buckley C>RCS Common version for TOMS and MT C>RCS C>RCS Revision 1.9.1.2 89/07/01 11:51:41 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.9.1.1 89/07/01 11:36:50 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.9 89/06/30 13:30:16 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:29 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:26 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:02 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:31 buckley C>RCS Initial revision C>RCS C## D E S C R I P T I O N: C C THIS OPENS THE FILES NEEDED FOR TESTPACK AND KEEPS TRACK OF C WHICH ARE OPEN AND WHICH ARE NOT. IT ALSO SUPPLIES THE APPRO- C PRIATE ARGUMENTS FOR EACH FILE. C C IF NAME IS NOT BLANK ON ENTRY, THEN THE FILE IS OPENED C WITH THE NAME GIVEN. OTHERWISE, NO NAME IS SPECIFIED WHEN C OPENING THE FILE. C C THE OPEN IS ONLY DONE IF "FLAG" IS TRUE. C C IF RECLEN IS NOT EQUAL TO ZERO, THEN THE FILE IS OPENED C AS DIRECT ACCESS UNFORMATTED. C C IF RECLEN IS EQUAL TO ZERO, THEN THE FILE IS OPENED C FOR FORMATTED SEQUENTIAL ACCESS. C C## E N T R Y P O I N T S: The natural entry ZZopen and ZZclse C## S U B R O U T I N E S: OPEN, CLOSE, REAL ...INTRINSIC C ZZERRM ...FOR ERROR MESSAGES. C## P A R A M E T E R S: INTEGER FILENL, NFILES PARAMETER ( FILENL = 80, NFILES = 15 ) CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) CHARACTER*(*) PERIOD, COMMA, SEMICN PARAMETER ( PERIOD = '.', COMMA = ',', SEMICN = ';' ) CHARACTER*(*) COLON, DASH, EQUALS PARAMETER ( COLON = ':', DASH = '-', EQUALS = '=' ) CHARACTER*(*) OBRACE, CBRACE, UNDERS PARAMETER ( OBRACE = '{', CBRACE = '}', UNDERS = '_' ) CHARACTER*(*) PLUS, MINUS, EXCLAM PARAMETER ( PLUS = '+', MINUS = '-', EXCLAM = '!' ) CHARACTER*(*) GTHAN, LTHAN, QUESMK PARAMETER ( GTHAN = '>', LTHAN = '<', QUESMK = '?' ) CHARACTER*(*) SLASH, BSLASH, PERCNT PARAMETER ( SLASH = '/', BSLASH = '\\',PERCNT = '%' ) CHARACTER*(*) CARAT, ATSIGN, TILDE PARAMETER ( CARAT = '^', ATSIGN = '@', TILDE = '~' ) LOGICAL T, F PARAMETER ( T = .TRUE., F = .FALSE. ) CHARACTER*(*) TRUE, QT, FALSE, QF PARAMETER ( TRUE = 'TRUE', QT = 'T', FALSE = 'FALSE', QF = 'F' ) INTEGER ITRUE, IFALSE PARAMETER ( ITRUE = 1, IFALSE = 0 ) REAL RTRUE, RFALSE C!!!! DOUBLE PRECISION RTRUE, RFALSE PARAMETER ( RTRUE = 1.D0, RFALSE = 0.D0 ) INTEGER CTOUPP, CTOLOW, CTOCAP PARAMETER ( CTOUPP = 1, CTOLOW = 2, CTOCAP = 3 ) INTEGER PREPRC, DAUF, INPTUN PARAMETER ( PREPRC = 1, DAUF = 2, INPTUN = 3 ) INTEGER TEMPUN, STDIN, TRMOUT PARAMETER ( TEMPUN = 4, STDIN = 5, TRMOUT = 6 ) INTEGER WRITUN, TRACUN, SUMMUN PARAMETER ( WRITUN = 7, TRACUN = 8, SUMMUN = 9 ) INTEGER COPYUN, TEXUN PARAMETER ( COPYUN =10, TEXUN =11 ) CHARACTER *(*) SEQ , DIR PARAMETER ( SEQ = 'SEQUENTIAL', DIR = 'DIRECT' ) CHARACTER *(*) UNKN , NEW PARAMETER ( UNKN = 'UNKNOWN' , NEW = 'NEW' ) CHARACTER *(*) OLD , SCR PARAMETER ( OLD = 'OLD' , SCR = 'SCRATCH' ) CHARACTER *(*) DEL , KEEP PARAMETER ( DEL = 'DELETE' , KEEP = 'KEEP' ) CHARACTER *(*) FMT , UNFRMT PARAMETER ( FMT = 'FORMATTED' , UNFRMT = 'UNFORMATTED' ) C## L O C A L D E C L: INTEGER ERRINT, UNIT LOGICAL OPENFS(NFILES), REW, OPENIT, COPY CHARACTER STAT*7, ACCS*10, FRMT*11 CHARACTER *(FILENL) COPYNM, NAME REAL RD C!!!! DOUBLE PRECISION RD C## S A V E: SAVE OPENFS, COPY, COPYNM C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA OPENFS / NFILES * .FALSE. / DATA COPY/F/, COPYNM/BLANK/ C## E X E C U T I O N C## E X E C U T I O N C----- DEFINE A STATEMENT FUNCTION. RD(UNIT) = REAL(UNIT) C!!!! RD(UNIT) = DBLE(UNIT) IF ( FLAG ) THEN IF ( RECLEN .EQ. 0 ) THEN ACCS = SEQ FRMT = FMT ELSE ACCS = DIR FRMT = UNFRMT ENDIF UNIT = IUNIT NAME = INAME 100 CONTINUE OPENIT = .NOT. OPENFS(UNIT) REW = .FALSE. IF ( UNIT .EQ. SUMMUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. TRMOUT ) THEN OPENIT = .FALSE. ELSE IF ( UNIT .EQ. STDIN ) THEN OPENIT = .FALSE. ELSE IF ( UNIT .EQ. PREPRC) THEN STAT = OLD REW = .TRUE. ELSE IF ( UNIT .EQ. TEMPUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. WRITUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. TRACUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. DAUF ) THEN STAT = OLD ELSE IF ( UNIT .EQ. COPYUN ) THEN STAT = UNKN COPY = T ELSE IF ( UNIT .EQ. INPTUN ) THEN STAT = OLD REW = .TRUE. ELSE CALL ZZERRM ( RD(UNIT), *91000, - 'IS REQUEST TO OPEN UNKNOWN UNIT # ' ) ENDIF C FOR THE "CHOICE OF UNIT..." 500 IF ( OPENIT ) THEN CALL ZZCASE ( STAT, CTOLOW ) CALL ZZCASE ( ACCS, CTOLOW ) CALL ZZCASE ( FRMT, CTOLOW ) IF ( NAME .EQ. BLANK ) THEN C PRINT*,'OPENING ',UNIT,'NAME=' IF ( RECLEN .EQ. 0 ) THEN OPEN ( UNIT = UNIT, - ERR = 1000, - IOSTAT = ERRINT, - STATUS = STAT, - ACCESS = ACCS, - FORM = FRMT ) ELSE OPEN ( UNIT = UNIT, - ERR = 1000, - IOSTAT = ERRINT, - STATUS = STAT, - ACCESS = ACCS, - RECL = RECLEN, - FORM = FRMT ) ENDIF ELSE C NAMED FILE IF ( RECLEN .EQ. 0 ) THEN C PRINT*,'OPENING ',UNIT,'NAME=',NAME(1:20) OPEN ( UNIT = UNIT, - ERR = 1000, - IOSTAT = ERRINT, - FILE = NAME, - STATUS = STAT, - ACCESS = ACCS, - FORM = FRMT ) C PRINT*,'OK' ELSE OPEN ( UNIT = UNIT, - ERR = 1000, - FILE = NAME, - IOSTAT = ERRINT, - STATUS = STAT, - ACCESS = ACCS, - RECL = RECLEN, - FORM = FRMT ) ENDIF ENDIF ENDIF C FOR EACH UNIT FROM 1 TO NFILES WE NEED TO KEEP A RECORD OF C WHETHER IT IS CURRENTLY OPEN. OPENFS(UNIT) = .TRUE. IF ( REW .AND. RECLEN .EQ. 0 ) THEN REWIND UNIT ENDIF GOTO 1025 1000 IF ( UNIT .EQ. DAUF ) THEN C CREATE THE DAUF. STAT = NEW GOTO 500 ELSE GOTO 1050 ENDIF 1025 CONTINUE IF ( COPY .AND. UNIT .EQ. STDIN ) THEN UNIT = COPYUN NAME = COPYNM GOTO 100 ENDIF ENDIF C FOR THE "IF FLAG..." GOTO 90000 1050 CONTINUE GOTO 91000 C## E N T R Y ZZCLSE: ENTRY ZZCLSE ( IUNIT, * ) STAT = KEEP IF ( IUNIT .EQ. SUMMUN ) THEN STAT = KEEP ELSE IF ( IUNIT .EQ. TRMOUT ) THEN OPENFS(TRMOUT) = .FALSE. ELSE IF ( IUNIT .EQ. STDIN ) THEN OPENFS(STDIN ) = .FALSE. ELSE IF ( IUNIT .EQ. TEMPUN ) THEN STAT = KEEP ELSE IF ( IUNIT .EQ. WRITUN ) THEN ELSE IF ( IUNIT .EQ. TRACUN ) THEN ELSE IF ( IUNIT .EQ. COPYUN ) THEN STAT = KEEP COPY = F ELSE IF ( IUNIT .EQ. DAUF ) THEN ELSE IF ( IUNIT .EQ. PREPRC ) THEN ELSE IF ( IUNIT .EQ. INPTUN ) THEN ELSE CALL ZZERRM ( RD(IUNIT), *91000, - 'IS IGNORING REQUEST TO CLOSE UNKNOWN UNIT #' ) ENDIF IF ( OPENFS(IUNIT) ) THEN CALL ZZCASE ( STAT, CTOLOW ) C PRINT*,'CLOSING ',IUNIT CLOSE ( UNIT = IUNIT, STATUS = STAT ) OPENFS(IUNIT) = .FALSE. ENDIF RETURN C## E X I T 90000 CONTINUE CALL ZZCASE (STAT,CTOUPP) IF ( IUNIT .EQ. DAUF .AND. STAT .EQ. NEW ) THEN GOTO 91000 ELSE RETURN ENDIF 91000 RETURN 1 C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZOPEN. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> reclsg.sn3 INTEGER FUNCTION ZZRECL ( CPERLN, IPERLN, LPERLN, RPERLN ) C## A R G U M E N T S: INTEGER CPERLN, IPERLN, LPERLN, RPERLN C## S T A T U S: C SINGLE/DOUBLE Conversion: Needed (See CONVRT). C C Ignore lines beginning with "C!!!!" . C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C System Dependence: System routine for direct C access unformatted record length C C THIS VERSION IS FOR SUN3 C C>RCS $Header: recl.gl,v 2.1 91/11/22 11:45:23 buckley Exp $ C>RCS $Log: recl.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:23 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/16 14:39:15 buckley C>RCS Added Lahey C>RCS C>RCS Revision 1.9 89/06/30 13:30:18 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:30 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:29 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:07 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:32 buckley C>RCS Initial revision C>RCS C## D E S C R I P T I O N: C C THIS ROUTINE USES FOUR INTEGER CONSTANTS NEEDED TO DETERMINE C THE LENGTH OF AN UNFORMATTED RECORD FOR READING AND WRITING C DIRECT ACCESS FILES. THE PROCESSOR IS ASSUMED, ACCORDING C TO THE FORTRAN STANDARD, TO WRITE UNFORMATTED RECORDS C IN "PROCESSOR DEFINED UNITS", I.E. IN PDU'S. C C HERE WE MUST DEFINE FOUR CONSTANTS: C C CHARS THE NUMBER OF PDU'S NEEDED TO WRITE ONE CHARACTER; C INTS THE NUMBER OF PDU'S NEEDED TO WRITE ONE INTEGER VALUE; C LOGS THE NUMBER OF PDU'S NEEDED TO WRITE ONE LOGICAL VALUE; C REALS THE NUMBER OF PDU'S NEEDED TO WRITE ONE REAL(DP) VALUE. C C NOTE THAT IT MAY HAPPEN (PARTICULARLY WITH CHARACTER OR LOGICAL C DATA) THAT SEVERAL VALUES MAY FIT INTO ONE PDU. IN THIS CASE, SET C THE CONSTANT TO A NEGATIVE VALUE. FOR EXAMPLE, ON A CYBER, A PDU C IS ONE WORD AND 10 CHARACTERS FIT PER WORD. IN THIS CASE, CHARS C IS SET TO -10. BUT ON A VAX, A PDU IS ONE BYTE AND AN INTEGER C OCCUPIES 4 BYTES, SO INTS IS SET TO 4. NOTE THAT THE VALUES FOR C 'REALS' WILL GENERALLY BE DIFFERENT FOR THE SINGLE AND DOUBLE C PRECISION VERSIONS ON THE SAME MACHINE. C C ON ENTRY, THE FOUR ARGUMENTS INDICATE HOW MANY VALUES OF EACH OF C THE FOUR BASIC TYPES ARE REQUIRED TO FIT IN ONE DIRECT ACCESS C UNFORMATTED RECORD. THIS ROUTINE WILL DETERMINE THE MINIMUM RECORD C LENGTH NEEDED TO SATISFY ALL FOUR REQUIREMENTS. THAT VALUE WILL BE C RETURNED AS THE VALUE OF THE FUNCTION ZZRECL. C C IT WILL THEN *RETURN* IN EACH OF THE FOUR ARGUMENTS THE *ACTUAL* C NUMBER OF EACH OF THESE WHICH CAN FIT IN THE RECORD OF THE SIZE C DETERMINED. C C N.B. **** THIS ROUTINE ASSUMES *NO MIXING* OF DATA TYPES ON C ANY ONE RECORD WHEN USING DIRECT ACCESS UNFORMATTED I/O. C THUS EACH TIME A RECORD IS WRITTEN, IT CONTAINS *ONLY* C CHARACTER DATA, OR *ONLY* INTEGER DATA, OR *ONLY* REAL C DATA, OR *ONLY* LOGICAL DATA. ANY MIXING WOULD C TOTALLY DESTROY ANY HOPE OF PORTABILITY TO SOME SYSTEMS. C C## E N T R Y P O I N T S: The natural entry ZZRECL. C## S U B R O U T I N E S: ABS, MAX ... INTRINSIC C C## P A R A M E T E R S: INTEGER CHARS, INTS, LOGS, REALS PARAMETER ( CHARS = 1, INTS = 4, LOGS = 4, REALS = 4 ) C!!!! PARAMETER ( CHARS = 1, INTS = 4, LOGS = 4, REALS = 8 ) C## L O C A L D E C L: INTEGER N C## S A V E: NONE selected. C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C## D A T A: NONE are set. C## E X E C U T I O N C## E X E C U T I O N ZZRECL = 1 IF ( CHARS .LT. 0 ) THEN N = ABS(CHARS) N = ( CPERLN + N - 1 ) / N ELSE N = CPERLN * CHARS ENDIF ZZRECL = MAX ( ZZRECL, N ) IF ( INTS .LT. 0 ) THEN N = ABS(INTS) N = ( IPERLN + N - 1 ) / N ELSE N = IPERLN * INTS ENDIF ZZRECL = MAX ( ZZRECL, N ) IF ( LOGS .LT. 0 ) THEN N = ABS(LOGS) N = ( LPERLN + N - 1 ) / N ELSE N = LPERLN * LOGS ENDIF ZZRECL = MAX ( ZZRECL, N ) IF ( REALS .LT. 0 ) THEN N = ABS(REALS) N = ( RPERLN + N - 1 ) / N ELSE N = RPERLN * REALS ENDIF ZZRECL = MAX ( ZZRECL, N ) C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZRECL. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> secssg.sn3 SUBROUTINE ZZSECS(SECS) C## A R G U M E N T S: REAL SECS C!!!! DOUBLE PRECISION SECS C## S T A T U S: C SINGLE/DOUBLE Conversion: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C SYSTEM DEPENDENCE: System routine for CPU usage. C This version is for SUN3 C C>RCS $Header: secs.gl,v 2.1 91/11/22 11:45:25 buckley Exp $ C>RCS $Log: secs.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:25 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/06 10:48:10 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9 89/06/30 13:30:19 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:31 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:31 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:12 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:33 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C THIS SUBROUTINE SHOULD OBTAIN (FROM THE OPERATING SYSTEM) THE C AMOUNT OF CPU TIME USED BY THE CALLING PROGRAM SINCE THE C EXECUTION BEGAN. IF DESIRABLE, "SECS" CAN ALSO BE CONVERTED C TO DOUBLE PRECISION (SEE CONVRT). HOWEVER, THE ROUTINE ACTUALLY C WORKS TOTALLY AS A SINGLE PRECISION ROUTINE, EXCEPT THAT THE C VALUE WHICH IS PASSED BACK MAY BE IN EITHER PRECISION AS C APPROPRIATE. C TIME IS MEASURED FROM THE FIRST CALL TO ZZSECS. THUS C ON THE FIRST CALL TO ZZSECS, A TIME OF 0.0 SECONDS IS ALWAYS C RETURNED. C## E N T R Y P O I N T S: The natural entry ZZSECS. C## S U B R O U T I N E S: A SYSTEM CLOCK. C## P A R A M E T E R S: REAL ZERO PARAMETER ( ZERO = 0.0E0 ) C## L O C A L D E C L: LOGICAL FIRST REAL ETIME, DUMMY(2) REAL STTIME, SEC C## S A V E: SAVE FIRST, STTIME C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C## D A T A: DATA FIRST/.TRUE./ C## E X E C U T I O N C## E X E C U T I O N IF ( FIRST ) THEN FIRST = .FALSE. STTIME = ETIME(DUMMY) SEC = ZERO ELSE SEC = ETIME(DUMMY) - STTIME ENDIF SECS = SEC C!!!! SECS = DBLE(SEC) C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZSECS. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> timesg.sn3 SUBROUTINE ZZTIME ( CHTIME ) C## A R G U M E N T S: CHARACTER *(*) CHTIME C## S T A T U S: C SINGLE/DOUBLE Conversion: NOT required. C C System Dependence: System routine for Time. C C THIS VERSION IS FOR SUN3 C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C>RCS $Header: time.gl,v 2.1 91/11/22 11:45:26 buckley Exp $ C>RCS $Log: time.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:26 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/06 10:52:37 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9 89/06/30 13:30:20 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:32 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:33 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:16 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:33 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE MUST CALL A SYSTEM ROUTINE TO GET THE CURRENT TIME. C IT MUST RETURN THIS TIME IN THE CHARACTER VARIABLE CHTIME C IN THE FORM C C (HH+MM+SS) C C AS REQUIRED BY THE ROUTINE ZZDTTM. CHTIME MUST BE OF LENGTH 10. C ONLY THE SIX CHARACTERS HH MM SS ARE ACTUALLY USED. THE OTHERS C CAN BE ANYTHING, BUT THE HH, MM AND SS MUST BE IN THE CORRECT C POSITION. HH SHOULD BE BETWEEN 0 AND 23, I.E. BASED ON THE 24 HOUR C CLOCK. OF COURSE MM AND SS MUST BE IN THE RANGE 0 TO 59. C C THIS VERSION CALLS A SYSTEM DEPENDENT ROUTINE. C TO IMPLEMENT THIS ON ANOTHER SYSTEM, ONE MAY EITHER C C (A) INCORPORATE AN ALTERNATE VERSION OF ZZTIME; C C (B) USE THE "DUMMY" VERSION OF THIS ROUTINE WITH THE SINGLE C EXECUTABLE STATEMENT CHTIME=' ', IN WHICH CASE NO C TIME INFORMATION WILL APPEAR IN THE OUTPUT. C C## E N T R Y P O I N T S: The natural entry ZZTIME. C## S U B R O U T I N E S: SYSTEM ROUTINE TO GET TIME OF DAY. C## P A R A M E T E R S: NONE are defined. C## L O C A L D E C L: CHARACTER * 24 UNXTIM C## S A V E: NONE selected. C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C## D A T A: NONE are set. C## E X E C U T I O N C## E X E C U T I O N CALL FDATE (UNXTIM) CHTIME(2:9) = UNXTIM(12:19) C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZTIME. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> casesg.sn4 SUBROUTINE ZZCASE (STRING, TYPE ) C## A R G U M E N T S: CHARACTER *(*) STRING INTEGER TYPE C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NOT REQUIRED. C C SYSTEM DEPENDENCE: SYSTEM ROUTINE FOR CASE C CONVERSION OF LETTERS. C C THIS IS A VERSION FOR SUN4 C>RCS $HEADER: CASE.GL,V 2.0 90/07/05 12:44:20 BUCKLEY EXP $ C>RCS $LOG: CASE.GL,V $ C>RCS REVISION 2.0 90/07/05 12:44:20 BUCKLEY C>RCS COMMON VERSION FOR TOMS AND GL C>RCS C>RCS REVISION 1.9.1.1 89/06/30 14:59:19 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.9 89/06/30 13:30:11 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 16:07:53 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/20 13:48:39 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C## D E S C R I P T I O N: C THIS CONVERTS EACH LOWER CASE ALPHABETIC LETTER TO C UPPER CASE, OR VICE VERSA. C IF TYPE = CTOUPP, CONVERSION IS LOWER TO UPPER C IF TYPE = CTOLOW, CONVERSION IS UPPER TO LOWER C IF TYPE = CTOCAP, USE UPPER FOR FIRST LETTER; LOWER FOR REST C ALL OTHER CHARACTERS ARE LEFT UNCHANGED. C## E N T R Y P O I N T S: THE NATURAL ENTRY TTOUPPR. C## S U B R O U T I N E S: LEN (INTRINSIC). C## P A R A M E T E R S: INTEGER CTOUPP, CTOLOW, CTOCAP PARAMETER ( CTOUPP = 1, CTOLOW = 2, CTOCAP = 3 ) CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) CHARACTER*(*) PERIOD, COMMA, SEMICN PARAMETER ( PERIOD = '.', COMMA = ',', SEMICN = ';' ) CHARACTER*(*) COLON, DASH, EQUALS PARAMETER ( COLON = ':', DASH = '-', EQUALS = '=' ) CHARACTER*(*) OBRACE, CBRACE, UNDERS PARAMETER ( OBRACE = '{', CBRACE = '}', UNDERS = '_' ) CHARACTER*(*) PLUS, MINUS, EXCLAM PARAMETER ( PLUS = '+', MINUS = '-', EXCLAM = '!' ) CHARACTER*(*) GTHAN, LTHAN, QUESMK PARAMETER ( GTHAN = '>', LTHAN = '<', QUESMK = '?' ) CHARACTER*(*) SLASH, BSLASH, PERCNT PARAMETER ( SLASH = '/', BSLASH = '\\',PERCNT = '%' ) CHARACTER*(*) CARAT, ATSIGN, TILDE PARAMETER ( CARAT = '^', ATSIGN = '@', TILDE = '~' ) C## L O C A L D E C L: INTEGER I, SHIFT LOGICAL FIRST CHARACTER *1 CH C## S A V E: SAVE FIRST, SHIFT C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA FIRST/.TRUE./ C## E X E C U T I O N C## E X E C U T I O N IF (FIRST) THEN FIRST = .FALSE. SHIFT = ICHAR('A') - ICHAR('a') ENDIF I = 0 100 I = I + 1 IF ( I .LE. LEN(STRING) ) THEN IF ( TYPE .EQ. CTOUPP ) THEN IF ('a' .LE. STRING(I:I) .AND. STRING(I:I) .LE. 'z') THEN CH = CHAR( ICHAR(STRING(I:I)) + SHIFT ) ELSE CH = STRING(I:I) ENDIF ELSE IF ( TYPE .EQ. CTOLOW .OR. TYPE .EQ. CTOCAP ) THEN IF ('A' .LE. STRING(I:I) .AND. STRING(I:I) .LE. 'Z') THEN CH = CHAR( ICHAR(STRING(I:I)) - SHIFT ) ELSE CH = STRING(I:I) ENDIF ENDIF STRING(I:I) = CH GOTO 100 ENDIF IF ( TYPE .EQ. CTOCAP .and. - 'a' .LE. STRING(1:1) .AND. STRING(1:1) .LE. 'z') THEN CH = CHAR( ICHAR(STRING(1:1)) + SHIFT ) STRING(1:1) = CH ENDIF C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF TOUPPR. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> datesg.sn4 SUBROUTINE ZZdate (CHDATE) C## A R G U M E N T S: CHARACTER *(*) CHDATE C## S T A T U S: C SINGLE/DOUBLE Conversion: NOT required. C SYSTEM DEPENDENCE: System routine for date. C C THIS VERSION IS FOR SUN4 C C>RCS $Header: date.gl,v 2.1 91/11/22 11:45:18 buckley Exp $ C>RCS $Log: date.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:18 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/05 12:50:05 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9 89/06/30 13:30:12 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:26 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:12:13 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:33:41 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:30 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C THIS ROUTINE MUST CALL A SYSTEM ROUTINE TO GET THE CURRENT DATE. C ZZDATE MUST RETURN THIS DATE IN THE CHARACTER VARIABLE CHDATE C IN THE FORM C C (YY+MM+DD) C C AS REQUIRED BY THE ROUTINE ZZDTTM. CHDATE MUST OF LENGTH 10. C ONLY THE 6 CHARACTERS YY MM DD ARE ACTUALLY USED. THE OTHERS C CAN BE ANYTHING, I.E. ONLY THE POSITION OF THE YY MM DD MATTERS. C C THIS MUST CALL A SYSTEM ROUTINE TO GET THE DATE. C TO IMPLEMENT THIS ON ANOTHER SYSTEM, ONE MAY EITHER C C (A) INCORPORATE AN ALTERNATE VERSION OF ZZDATE; C C (B) USE THE "DUMMY" VERSION OF THIS ROUTINE WITH THE SINGLE C EXECUTABLE STATEMENT CHDATE='( + + )', IN WHICH CASE NO C DATE INFORMATION WILL APPEAR IN THE OUTPUT. C## E N T R Y P O I N T S: The natural entry ZZdate. C## S U B R O U T I N E S: System date routine. C## P A R A M E T E R S: INTEGER CTOUPP, CTOLOW, CTOCAP PARAMETER ( CTOUPP = 1, CTOLOW = 2, CTOCAP = 3 ) C## L O C A L D E C L: CHARACTER * 24 UNXDAT CHARACTER * 3 NAME (12), TEMP INTEGER I C## S A V E: SAVE NAME C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C## D A T A: DATA NAME /'JAN','FEB','MAR','APR','MAY','JUN', - 'JUL','AUG','SEP','OCT','NOV','DEC' / C## E X E C U T I O N C## E X E C U T I O N C---- INITIALIZE CHDATE CHDATE = '( + + )' CALL FDATE(UNXDAT) CHDATE(2:3) = UNXDAT(23:24) CHDATE(8:9) = UNXDAT(9:10) TEMP = UNXDAT(5:7) CALL ZZCASE(TEMP, CTOUPP) DO 100 I = 1,12 IF ( TEMP .EQ. NAME(I) ) THEN WRITE ( CHDATE(5:6), '(I2.2)' ) I GOTO 90000 ENDIF 100 CONTINUE C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZdate. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> mparsg.sn4 REAL FUNCTION ZZMPAR(I) C!!!! DOUBLE PRECISION FUNCTION ZZMPAR(I) C## A R G U M E N T S: INTEGER I C## S T A T U S: C IGNORE LINES BEGINNING WITH "C!!!!" . C C SYSTEM DEPENDENCE: THE CODE IS VERY DEFINITELY MACHINE DEPENDENT C FOR IT CONTAINS MACHINE PRECISION CONSTANTS C FOR MANY MACHINES, AS DESCRIBED BELOW. C C SINGLE/DOUBLE Conversion: NEEDED (SEE CONVRT). C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C>RCS $Header: mpar.gl,v 2.3 91/11/22 11:45:19 buckley Exp $ C>RCS $Log: mpar.gl,v $ C>RCS Revision 2.3 91/11/22 11:45:19 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.2 91/06/12 14:07:08 buckley C>RCS Added stardent C>RCS C>RCS Revision 2.1 90/07/31 10:57:40 buckley C>RCS Added constants for ieee for pc's C>RCS C>RCS Revision 2.0 90/07/06 10:39:26 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9.1.2 90/06/26 14:24:24 buckley C>RCS Fixed single/double precision constants for sun4 C>RCS C>RCS Revision 1.9.1.1 89/07/01 11:36:48 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.9 89/06/30 13:30:15 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:28 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:23 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:34:59 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:31 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C C THIS IS A MODIFICATION OF THE TWO ROUTINES DPMPAR AND SPMPAR C OBTAINED FROM JORGE MORE. IT HAS BEEN CHANGED ONLY TO CONFORM C WITH MY CONVENTIONS, AND TO ADD STATEMENTS FOR THE CDC C CYBERS WHICH ARE ACCEPTABLE TO FTN5 (FORTRAN '77). THE C OTHER CHANGES ARE: C C 1. THE SINGLE NAME ZZMPAR HAS BEEN USED. IT IS DOUBLE OR SINGLE C PRECISION ACCORDING TO CONVERSION BY CONVRT, JUST AS FOR ALL C OF MY OTHER PROGRAMS. C C 2. THE ROUTINES HAVE BEEN MERGED SO THAT SINGLE AND DOUBLE C PRECISION STATEMENTS WHICH CORRESPOND APPEAR IN PAIRS. C C OTHERWISE ALL OF THE COMMENTS OF THE ORIGINAL AUTHORS APPLY. C THEIR ORIGINAL COMMENTS (UNALTERED) FOR THE DOUBLE PRECISION C VERSION FOLLOW IMMEDIATELY. C C FUNCTION DPMPAR C C THIS FUNCTION PROVIDES DOUBLE PRECISION MACHINE PARAMETERS C WHEN THE APPROPRIATE SET OF DATA STATEMENTS IS ACTIVATED (BY C REMOVING THE C FROM COLUMN 1) AND ALL OTHER DATA STATEMENTS ARE C RENDERED INACTIVE. MOST OF THE PARAMETER VALUES WERE OBTAINED C FROM THE CORRESPONDING BELL LABORATORIES PORT LIBRARY FUNCTION. C C THE FUNCTION STATEMENT IS C C DOUBLE PRECISION FUNCTION DPMPAR(I) C C WHERE C C I IS AN INTEGER INPUT VARIABLE SET TO 1, 2, OR 3 WHICH C SELECTS THE DESIRED MACHINE PARAMETER. IF THE MACHINE HAS C T BASE B DIGITS AND ITS SMALLEST AND LARGEST EXPONENTS ARE C EMIN AND EMAX, RESPECTIVELY, THEN THESE PARAMETERS ARE C C DPMPAR(1) B**(1 - T), THE MACHINE PRECISION, C C DPMPAR(2) B**(EMIN - 1), THE SMALLEST MAGNITUDE, C C DPMPAR(3) B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE C C## E N T R Y P O I N T S: The natural entry ZZmpar. C## S U B R O U T I N E S: NONE are called. C## P A R A M E T E R S: NONE are defined. C C## L O C A L D E C L: C NOTE THAT THESE ARRAYS MUST HAVE DIMENSIONS 2 AND 4, RATHER C THAN 1 AND 2 AS ONE MIGHT EXPECT, BECAUSE OF THE PDP-11 C DEFINITIONS. INTEGER MCHEPS(2) C!!!! INTEGER MCHEPS(4) INTEGER MINMAG(2) C!!!! INTEGER MINMAG(4) INTEGER MAXMAG(2) C!!!! INTEGER MAXMAG(4) REAL RMACH(3) C!!!! DOUBLE PRECISION DMACH(3) INTEGER EMIN, EMAX, IMACH(10) REAL B, BINV, BM1, ONE, W, Z C!!!! DOUBLE PRECISION B, BINV, BM1, ONE, W, Z C## S A V E: SAVE RMACH C!!!! SAVE DMACH SAVE IMACH C## E Q U I V A L E N C E S: EQUIVALENCE (RMACH(1),MCHEPS(1)) C!!!! EQUIVALENCE (DMACH(1),MCHEPS(1)) EQUIVALENCE (RMACH(2),MINMAG(1)) C!!!! EQUIVALENCE (DMACH(2),MINMAG(1)) EQUIVALENCE (RMACH(3),MAXMAG(1)) C!!!! EQUIVALENCE (DMACH(3),MAXMAG(1)) C## C O M M O N: NONE is defined. C## D A T A: C-----MACHINE CONSTANTS FOR THE SUN-4. DATA MCHEPS(1) / X'34000000'/ C!!!! DATA MCHEPS(1),MCHEPS(2) / X'3CB00000', X'00000000' / DATA MINMAG(1) / X'00800000' / C!!!! DATA MINMAG(1),MINMAG(2) / X'00100000', X'00000000' / DATA MAXMAG(1) / X'7F7FFFFF' / C!!!! DATA MAXMAG(1),MAXMAG(2) / X'7FEFFFFF', X'FFFFFFFF'/ C## E X E C U T I O N C## E X E C U T I O N ZZMPAR = RMACH(I) C!!!! ZZMPAR = DMACH(I) C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZmpar. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> opensg.sn4 SUBROUTINE ZZOPEN ( IUNIT, FLAG, INAME, * , RECLEN ) C## A R G U M E N T S: INTEGER IUNIT, RECLEN LOGICAL FLAG CHARACTER *(*) INAME C## S T A T U S: C IGNORE LINES BEGINNING WITH "C!!!!" . C C SINGLE/DOUBLE Conversion: NEEDED (SEE CONVRT). C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR C OPENING AND CLOSING FILES. C C THIS VERSION IS FOR SUN4 C C>RCS $Header: open.gl,v 2.1 91/11/22 11:45:21 buckley Exp $ C>RCS $Log: open.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:21 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/06 10:43:19 buckley C>RCS Common version for TOMS and MT C>RCS C>RCS Revision 1.9.1.2 89/07/01 11:51:41 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.9.1.1 89/07/01 11:36:50 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.9 89/06/30 13:30:16 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:29 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:26 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:02 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:31 buckley C>RCS Initial revision C>RCS C## D E S C R I P T I O N: C C THIS OPENS THE FILES NEEDED FOR TESTPACK AND KEEPS TRACK OF C WHICH ARE OPEN AND WHICH ARE NOT. IT ALSO SUPPLIES THE APPRO- C PRIATE ARGUMENTS FOR EACH FILE. C C IF NAME IS NOT BLANK ON ENTRY, THEN THE FILE IS OPENED C WITH THE NAME GIVEN. OTHERWISE, NO NAME IS SPECIFIED WHEN C OPENING THE FILE. C C THE OPEN IS ONLY DONE IF "FLAG" IS TRUE. C C IF RECLEN IS NOT EQUAL TO ZERO, THEN THE FILE IS OPENED C AS DIRECT ACCESS UNFORMATTED. C C IF RECLEN IS EQUAL TO ZERO, THEN THE FILE IS OPENED C FOR FORMATTED SEQUENTIAL ACCESS. C C## E N T R Y P O I N T S: The natural entry ZZopen and ZZclse C## S U B R O U T I N E S: OPEN, CLOSE, REAL ...INTRINSIC C ZZERRM ...FOR ERROR MESSAGES. C## P A R A M E T E R S: INTEGER FILENL, NFILES PARAMETER ( FILENL = 80, NFILES = 15 ) CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) CHARACTER*(*) PERIOD, COMMA, SEMICN PARAMETER ( PERIOD = '.', COMMA = ',', SEMICN = ';' ) CHARACTER*(*) COLON, DASH, EQUALS PARAMETER ( COLON = ':', DASH = '-', EQUALS = '=' ) CHARACTER*(*) OBRACE, CBRACE, UNDERS PARAMETER ( OBRACE = '{', CBRACE = '}', UNDERS = '_' ) CHARACTER*(*) PLUS, MINUS, EXCLAM PARAMETER ( PLUS = '+', MINUS = '-', EXCLAM = '!' ) CHARACTER*(*) GTHAN, LTHAN, QUESMK PARAMETER ( GTHAN = '>', LTHAN = '<', QUESMK = '?' ) CHARACTER*(*) SLASH, BSLASH, PERCNT PARAMETER ( SLASH = '/', BSLASH = '\\',PERCNT = '%' ) CHARACTER*(*) CARAT, ATSIGN, TILDE PARAMETER ( CARAT = '^', ATSIGN = '@', TILDE = '~' ) LOGICAL T, F PARAMETER ( T = .TRUE., F = .FALSE. ) CHARACTER*(*) TRUE, QT, FALSE, QF PARAMETER ( TRUE = 'TRUE', QT = 'T', FALSE = 'FALSE', QF = 'F' ) INTEGER ITRUE, IFALSE PARAMETER ( ITRUE = 1, IFALSE = 0 ) REAL RTRUE, RFALSE C!!!! DOUBLE PRECISION RTRUE, RFALSE PARAMETER ( RTRUE = 1.D0, RFALSE = 0.D0 ) INTEGER CTOUPP, CTOLOW, CTOCAP PARAMETER ( CTOUPP = 1, CTOLOW = 2, CTOCAP = 3 ) INTEGER PREPRC, DAUF, INPTUN PARAMETER ( PREPRC = 1, DAUF = 2, INPTUN = 3 ) INTEGER TEMPUN, STDIN, TRMOUT PARAMETER ( TEMPUN = 4, STDIN = 5, TRMOUT = 6 ) INTEGER WRITUN, TRACUN, SUMMUN PARAMETER ( WRITUN = 7, TRACUN = 8, SUMMUN = 9 ) INTEGER COPYUN, TEXUN PARAMETER ( COPYUN =10, TEXUN =11 ) CHARACTER *(*) SEQ , DIR PARAMETER ( SEQ = 'SEQUENTIAL', DIR = 'DIRECT' ) CHARACTER *(*) UNKN , NEW PARAMETER ( UNKN = 'UNKNOWN' , NEW = 'NEW' ) CHARACTER *(*) OLD , SCR PARAMETER ( OLD = 'OLD' , SCR = 'SCRATCH' ) CHARACTER *(*) DEL , KEEP PARAMETER ( DEL = 'DELETE' , KEEP = 'KEEP' ) CHARACTER *(*) FMT , UNFRMT PARAMETER ( FMT = 'FORMATTED' , UNFRMT = 'UNFORMATTED' ) C## L O C A L D E C L: INTEGER ERRINT, UNIT LOGICAL OPENFS(NFILES), REW, OPENIT, COPY CHARACTER STAT*7, ACCS*10, FRMT*11 CHARACTER *(FILENL) COPYNM, NAME REAL RD C!!!! DOUBLE PRECISION RD C## S A V E: SAVE OPENFS, COPY, COPYNM C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA OPENFS / NFILES * .FALSE. / DATA COPY/F/, COPYNM/BLANK/ C## E X E C U T I O N C## E X E C U T I O N C----- DEFINE A STATEMENT FUNCTION. RD(UNIT) = REAL(UNIT) C!!!! RD(UNIT) = DBLE(UNIT) IF ( FLAG ) THEN IF ( RECLEN .EQ. 0 ) THEN ACCS = SEQ FRMT = FMT ELSE ACCS = DIR FRMT = UNFRMT ENDIF UNIT = IUNIT NAME = INAME 100 CONTINUE OPENIT = .NOT. OPENFS(UNIT) REW = .FALSE. IF ( UNIT .EQ. SUMMUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. TRMOUT ) THEN OPENIT = .FALSE. ELSE IF ( UNIT .EQ. STDIN ) THEN OPENIT = .FALSE. ELSE IF ( UNIT .EQ. PREPRC) THEN STAT = OLD REW = .TRUE. ELSE IF ( UNIT .EQ. TEMPUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. WRITUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. TRACUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. DAUF ) THEN STAT = OLD ELSE IF ( UNIT .EQ. COPYUN ) THEN STAT = UNKN COPY = T ELSE IF ( UNIT .EQ. INPTUN ) THEN STAT = OLD REW = .TRUE. ELSE CALL ZZERRM ( RD(UNIT), *91000, - 'IS REQUEST TO OPEN UNKNOWN UNIT # ' ) ENDIF C FOR THE "CHOICE OF UNIT..." 500 IF ( OPENIT ) THEN CALL ZZCASE ( STAT, CTOLOW ) CALL ZZCASE ( ACCS, CTOLOW ) CALL ZZCASE ( FRMT, CTOLOW ) IF ( NAME .EQ. BLANK ) THEN C PRINT*,'OPENING ',UNIT,'NAME=' IF ( RECLEN .EQ. 0 ) THEN OPEN ( UNIT = UNIT, - ERR = 1000, - IOSTAT = ERRINT, - STATUS = STAT, - ACCESS = ACCS, - FORM = FRMT ) ELSE OPEN ( UNIT = UNIT, - ERR = 1000, - IOSTAT = ERRINT, - STATUS = STAT, - ACCESS = ACCS, - RECL = RECLEN, - FORM = FRMT ) ENDIF ELSE C NAMED FILE IF ( RECLEN .EQ. 0 ) THEN C PRINT*,'OPENING ',UNIT,'NAME=',NAME(1:20) OPEN ( UNIT = UNIT, - ERR = 1000, - IOSTAT = ERRINT, - FILE = NAME, - STATUS = STAT, - ACCESS = ACCS, - FORM = FRMT ) C PRINT*,'OK' ELSE OPEN ( UNIT = UNIT, - ERR = 1000, - FILE = NAME, - IOSTAT = ERRINT, - STATUS = STAT, - ACCESS = ACCS, - RECL = RECLEN, - FORM = FRMT ) ENDIF ENDIF ENDIF C FOR EACH UNIT FROM 1 TO NFILES WE NEED TO KEEP A RECORD OF C WHETHER IT IS CURRENTLY OPEN. OPENFS(UNIT) = .TRUE. IF ( REW .AND. RECLEN .EQ. 0 ) THEN REWIND UNIT ENDIF GOTO 1025 1000 IF ( UNIT .EQ. DAUF ) THEN C CREATE THE DAUF. STAT = NEW GOTO 500 ELSE GOTO 1050 ENDIF 1025 CONTINUE IF ( COPY .AND. UNIT .EQ. STDIN ) THEN UNIT = COPYUN NAME = COPYNM GOTO 100 ENDIF ENDIF C FOR THE "IF FLAG..." GOTO 90000 1050 CONTINUE GOTO 91000 C## E N T R Y ZZCLSE: ENTRY ZZCLSE ( IUNIT, * ) STAT = KEEP IF ( IUNIT .EQ. SUMMUN ) THEN STAT = KEEP ELSE IF ( IUNIT .EQ. TRMOUT ) THEN OPENFS(TRMOUT) = .FALSE. ELSE IF ( IUNIT .EQ. STDIN ) THEN OPENFS(STDIN ) = .FALSE. ELSE IF ( IUNIT .EQ. TEMPUN ) THEN STAT = KEEP ELSE IF ( IUNIT .EQ. WRITUN ) THEN ELSE IF ( IUNIT .EQ. TRACUN ) THEN ELSE IF ( IUNIT .EQ. COPYUN ) THEN STAT = KEEP COPY = F ELSE IF ( IUNIT .EQ. DAUF ) THEN ELSE IF ( IUNIT .EQ. PREPRC ) THEN ELSE IF ( IUNIT .EQ. INPTUN ) THEN ELSE CALL ZZERRM ( RD(IUNIT), *91000, - 'IS IGNORING REQUEST TO CLOSE UNKNOWN UNIT #' ) ENDIF IF ( OPENFS(IUNIT) ) THEN CALL ZZCASE ( STAT, CTOLOW ) C PRINT*,'CLOSING ',IUNIT CLOSE ( UNIT = IUNIT, STATUS = STAT ) OPENFS(IUNIT) = .FALSE. ENDIF RETURN C## E X I T 90000 CONTINUE CALL ZZCASE (STAT,CTOUPP) IF ( IUNIT .EQ. DAUF .AND. STAT .EQ. NEW ) THEN GOTO 91000 ELSE RETURN ENDIF 91000 RETURN 1 C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZOPEN. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> reclsg.sn4 INTEGER FUNCTION ZZRECL ( CPERLN, IPERLN, LPERLN, RPERLN ) C## A R G U M E N T S: INTEGER CPERLN, IPERLN, LPERLN, RPERLN C## S T A T U S: C SINGLE/DOUBLE Conversion: Needed (See CONVRT). C C Ignore lines beginning with "C!!!!" . C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C System Dependence: System routine for direct C access unformatted record length C C THIS VERSION IS FOR SUN4 C C>RCS $Header: recl.gl,v 2.1 91/11/22 11:45:23 buckley Exp $ C>RCS $Log: recl.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:23 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/16 14:39:15 buckley C>RCS Added Lahey C>RCS C>RCS Revision 1.9 89/06/30 13:30:18 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:30 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:29 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:07 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:32 buckley C>RCS Initial revision C>RCS C## D E S C R I P T I O N: C C THIS ROUTINE USES FOUR INTEGER CONSTANTS NEEDED TO DETERMINE C THE LENGTH OF AN UNFORMATTED RECORD FOR READING AND WRITING C DIRECT ACCESS FILES. THE PROCESSOR IS ASSUMED, ACCORDING C TO THE FORTRAN STANDARD, TO WRITE UNFORMATTED RECORDS C IN "PROCESSOR DEFINED UNITS", I.E. IN PDU'S. C C HERE WE MUST DEFINE FOUR CONSTANTS: C C CHARS THE NUMBER OF PDU'S NEEDED TO WRITE ONE CHARACTER; C INTS THE NUMBER OF PDU'S NEEDED TO WRITE ONE INTEGER VALUE; C LOGS THE NUMBER OF PDU'S NEEDED TO WRITE ONE LOGICAL VALUE; C REALS THE NUMBER OF PDU'S NEEDED TO WRITE ONE REAL(DP) VALUE. C C NOTE THAT IT MAY HAPPEN (PARTICULARLY WITH CHARACTER OR LOGICAL C DATA) THAT SEVERAL VALUES MAY FIT INTO ONE PDU. IN THIS CASE, SET C THE CONSTANT TO A NEGATIVE VALUE. FOR EXAMPLE, ON A CYBER, A PDU C IS ONE WORD AND 10 CHARACTERS FIT PER WORD. IN THIS CASE, CHARS C IS SET TO -10. BUT ON A VAX, A PDU IS ONE BYTE AND AN INTEGER C OCCUPIES 4 BYTES, SO INTS IS SET TO 4. NOTE THAT THE VALUES FOR C 'REALS' WILL GENERALLY BE DIFFERENT FOR THE SINGLE AND DOUBLE C PRECISION VERSIONS ON THE SAME MACHINE. C C ON ENTRY, THE FOUR ARGUMENTS INDICATE HOW MANY VALUES OF EACH OF C THE FOUR BASIC TYPES ARE REQUIRED TO FIT IN ONE DIRECT ACCESS C UNFORMATTED RECORD. THIS ROUTINE WILL DETERMINE THE MINIMUM RECORD C LENGTH NEEDED TO SATISFY ALL FOUR REQUIREMENTS. THAT VALUE WILL BE C RETURNED AS THE VALUE OF THE FUNCTION ZZRECL. C C IT WILL THEN *RETURN* IN EACH OF THE FOUR ARGUMENTS THE *ACTUAL* C NUMBER OF EACH OF THESE WHICH CAN FIT IN THE RECORD OF THE SIZE C DETERMINED. C C N.B. **** THIS ROUTINE ASSUMES *NO MIXING* OF DATA TYPES ON C ANY ONE RECORD WHEN USING DIRECT ACCESS UNFORMATTED I/O. C THUS EACH TIME A RECORD IS WRITTEN, IT CONTAINS *ONLY* C CHARACTER DATA, OR *ONLY* INTEGER DATA, OR *ONLY* REAL C DATA, OR *ONLY* LOGICAL DATA. ANY MIXING WOULD C TOTALLY DESTROY ANY HOPE OF PORTABILITY TO SOME SYSTEMS. C C## E N T R Y P O I N T S: The natural entry ZZRECL. C## S U B R O U T I N E S: ABS, MAX ... INTRINSIC C C## P A R A M E T E R S: INTEGER CHARS, INTS, LOGS, REALS PARAMETER ( CHARS = 1, INTS = 4, LOGS = 4, REALS = 4 ) C!!!! PARAMETER ( CHARS = 1, INTS = 4, LOGS = 4, REALS = 8 ) C## L O C A L D E C L: INTEGER N C## S A V E: NONE selected. C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C## D A T A: NONE are set. C## E X E C U T I O N C## E X E C U T I O N ZZRECL = 1 IF ( CHARS .LT. 0 ) THEN N = ABS(CHARS) N = ( CPERLN + N - 1 ) / N ELSE N = CPERLN * CHARS ENDIF ZZRECL = MAX ( ZZRECL, N ) IF ( INTS .LT. 0 ) THEN N = ABS(INTS) N = ( IPERLN + N - 1 ) / N ELSE N = IPERLN * INTS ENDIF ZZRECL = MAX ( ZZRECL, N ) IF ( LOGS .LT. 0 ) THEN N = ABS(LOGS) N = ( LPERLN + N - 1 ) / N ELSE N = LPERLN * LOGS ENDIF ZZRECL = MAX ( ZZRECL, N ) IF ( REALS .LT. 0 ) THEN N = ABS(REALS) N = ( RPERLN + N - 1 ) / N ELSE N = RPERLN * REALS ENDIF ZZRECL = MAX ( ZZRECL, N ) C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZRECL. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> secssg.sn4 SUBROUTINE ZZSECS(SECS) C## A R G U M E N T S: REAL SECS C!!!! DOUBLE PRECISION SECS C## S T A T U S: C SINGLE/DOUBLE Conversion: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C SYSTEM DEPENDENCE: System routine for CPU usage. C This version is for SUN4 C C>RCS $Header: secs.gl,v 2.1 91/11/22 11:45:25 buckley Exp $ C>RCS $Log: secs.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:25 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/06 10:48:10 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9 89/06/30 13:30:19 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:31 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:31 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:12 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:33 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C THIS SUBROUTINE SHOULD OBTAIN (FROM THE OPERATING SYSTEM) THE C AMOUNT OF CPU TIME USED BY THE CALLING PROGRAM SINCE THE C EXECUTION BEGAN. IF DESIRABLE, "SECS" CAN ALSO BE CONVERTED C TO DOUBLE PRECISION (SEE CONVRT). HOWEVER, THE ROUTINE ACTUALLY C WORKS TOTALLY AS A SINGLE PRECISION ROUTINE, EXCEPT THAT THE C VALUE WHICH IS PASSED BACK MAY BE IN EITHER PRECISION AS C APPROPRIATE. C TIME IS MEASURED FROM THE FIRST CALL TO ZZSECS. THUS C ON THE FIRST CALL TO ZZSECS, A TIME OF 0.0 SECONDS IS ALWAYS C RETURNED. C## E N T R Y P O I N T S: The natural entry ZZSECS. C## S U B R O U T I N E S: A SYSTEM CLOCK. C## P A R A M E T E R S: REAL ZERO PARAMETER ( ZERO = 0.0E0 ) C## L O C A L D E C L: LOGICAL FIRST REAL ETIME, DUMMY(2) REAL STTIME, SEC C## S A V E: SAVE FIRST, STTIME C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C## D A T A: DATA FIRST/.TRUE./ C## E X E C U T I O N C## E X E C U T I O N IF ( FIRST ) THEN FIRST = .FALSE. STTIME = ETIME(DUMMY) SEC = ZERO ELSE SEC = ETIME(DUMMY) - STTIME ENDIF SECS = SEC C!!!! SECS = DBLE(SEC) C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZSECS. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> timesg.sn4 SUBROUTINE ZZTIME ( CHTIME ) C## A R G U M E N T S: CHARACTER *(*) CHTIME C## S T A T U S: C SINGLE/DOUBLE Conversion: NOT required. C C System Dependence: System routine for Time. C C THIS VERSION IS FOR SUN4 C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C>RCS $Header: time.gl,v 2.1 91/11/22 11:45:26 buckley Exp $ C>RCS $Log: time.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:26 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/06 10:52:37 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9 89/06/30 13:30:20 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:32 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:33 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:16 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:33 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE MUST CALL A SYSTEM ROUTINE TO GET THE CURRENT TIME. C IT MUST RETURN THIS TIME IN THE CHARACTER VARIABLE CHTIME C IN THE FORM C C (HH+MM+SS) C C AS REQUIRED BY THE ROUTINE ZZDTTM. CHTIME MUST BE OF LENGTH 10. C ONLY THE SIX CHARACTERS HH MM SS ARE ACTUALLY USED. THE OTHERS C CAN BE ANYTHING, BUT THE HH, MM AND SS MUST BE IN THE CORRECT C POSITION. HH SHOULD BE BETWEEN 0 AND 23, I.E. BASED ON THE 24 HOUR C CLOCK. OF COURSE MM AND SS MUST BE IN THE RANGE 0 TO 59. C C THIS VERSION CALLS A SYSTEM DEPENDENT ROUTINE. C TO IMPLEMENT THIS ON ANOTHER SYSTEM, ONE MAY EITHER C C (A) INCORPORATE AN ALTERNATE VERSION OF ZZTIME; C C (B) USE THE "DUMMY" VERSION OF THIS ROUTINE WITH THE SINGLE C EXECUTABLE STATEMENT CHTIME=' ', IN WHICH CASE NO C TIME INFORMATION WILL APPEAR IN THE OUTPUT. C C## E N T R Y P O I N T S: The natural entry ZZTIME. C## S U B R O U T I N E S: SYSTEM ROUTINE TO GET TIME OF DAY. C## P A R A M E T E R S: NONE are defined. C## L O C A L D E C L: CHARACTER * 24 UNXTIM C## S A V E: NONE selected. C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C## D A T A: NONE are set. C## E X E C U T I O N C## E X E C U T I O N CALL FDATE (UNXTIM) CHTIME(2:9) = UNXTIM(12:19) C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZTIME. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> casesg.vms SUBROUTINE ZZCASE (STRING, TYPE ) C## A R G U M E N T S: CHARACTER *(*) STRING INTEGER TYPE C## S T A T U S: C SINGLE/DOUBLE CONVERSION: NOT REQUIRED. C C SYSTEM DEPENDENCE: SYSTEM ROUTINE FOR CASE C CONVERSION OF LETTERS. C C THIS IS A VERSION FOR VAX/VMS C>RCS $HEADER: CASE.GL,V 2.0 90/07/05 12:44:20 BUCKLEY EXP $ C>RCS $LOG: CASE.GL,V $ C>RCS REVISION 2.0 90/07/05 12:44:20 BUCKLEY C>RCS COMMON VERSION FOR TOMS AND GL C>RCS C>RCS REVISION 1.9.1.1 89/06/30 14:59:19 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.9 89/06/30 13:30:11 BUCKLEY C>RCS PREPARING SUBMITTED VERSION OF MT C>RCS C>RCS REVISION 1.3.1.1 89/05/20 16:07:53 BUCKLEY C>RCS TEMP. TEST OF MT BEFORE SUBMITTING C>RCS C>RCS REVISION 1.3 89/05/20 13:48:39 BUCKLEY C>RCS FINAL TEST OF MT BEFORE SUBMITTING C>RCS C## D E S C R I P T I O N: C THIS CONVERTS EACH LOWER CASE ALPHABETIC LETTER TO C UPPER CASE, OR VICE VERSA. C IF TYPE = CTOUPP, CONVERSION IS LOWER TO UPPER C IF TYPE = CTOLOW, CONVERSION IS UPPER TO LOWER C IF TYPE = CTOCAP, USE UPPER FOR FIRST LETTER; LOWER FOR REST C ALL OTHER CHARACTERS ARE LEFT UNCHANGED. C## E N T R Y P O I N T S: THE NATURAL ENTRY TTOUPPR. C## S U B R O U T I N E S: LEN (INTRINSIC). C## P A R A M E T E R S: INTEGER CTOUPP, CTOLOW, CTOCAP PARAMETER ( CTOUPP = 1, CTOLOW = 2, CTOCAP = 3 ) CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) CHARACTER*(*) PERIOD, COMMA, SEMICN PARAMETER ( PERIOD = '.', COMMA = ',', SEMICN = ';' ) CHARACTER*(*) COLON, DASH, EQUALS PARAMETER ( COLON = ':', DASH = '-', EQUALS = '=' ) CHARACTER*(*) OBRACE, CBRACE, UNDERS PARAMETER ( OBRACE = '{', CBRACE = '}', UNDERS = '_' ) CHARACTER*(*) PLUS, MINUS, EXCLAM PARAMETER ( PLUS = '+', MINUS = '-', EXCLAM = '!' ) CHARACTER*(*) GTHAN, LTHAN, QUESMK PARAMETER ( GTHAN = '>', LTHAN = '<', QUESMK = '?' ) CHARACTER*(*) SLASH, BSLASH, PERCNT PARAMETER ( SLASH = '/', BSLASH = '\\',PERCNT = '%' ) CHARACTER*(*) CARAT, ATSIGN, TILDE PARAMETER ( CARAT = '^', ATSIGN = '@', TILDE = '~' ) C## L O C A L D E C L: INTEGER I, SHIFT LOGICAL FIRST CHARACTER *1 CH C## S A V E: SAVE FIRST, SHIFT C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA FIRST/.TRUE./ C## E X E C U T I O N C## E X E C U T I O N IF (FIRST) THEN FIRST = .FALSE. SHIFT = ICHAR('A') - ICHAR('a') ENDIF I = 0 100 I = I + 1 IF ( I .LE. LEN(STRING) ) THEN IF ( TYPE .EQ. CTOUPP ) THEN IF ('a' .LE. STRING(I:I) .AND. STRING(I:I) .LE. 'z') THEN CH = CHAR( ICHAR(STRING(I:I)) + SHIFT ) ELSE CH = STRING(I:I) ENDIF ELSE IF ( TYPE .EQ. CTOLOW .OR. TYPE .EQ. CTOCAP ) THEN IF ('A' .LE. STRING(I:I) .AND. STRING(I:I) .LE. 'Z') THEN CH = CHAR( ICHAR(STRING(I:I)) - SHIFT ) ELSE CH = STRING(I:I) ENDIF ENDIF STRING(I:I) = CH GOTO 100 ENDIF IF ( TYPE .EQ. CTOCAP .and. - 'a' .LE. STRING(1:1) .AND. STRING(1:1) .LE. 'z') THEN CH = CHAR( ICHAR(STRING(1:1)) + SHIFT ) STRING(1:1) = CH ENDIF C## E X I T 90000 RETURN C## F O R M A T S: NONE ARE DEFINED. C## E N D OF TOUPPR. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> datesg.vms SUBROUTINE ZZdate (CHDATE) C## A R G U M E N T S: CHARACTER *(*) CHDATE C## S T A T U S: C SINGLE/DOUBLE Conversion: NOT required. C SYSTEM DEPENDENCE: System routine for date. C C THIS VERSION IS FOR VAX/VMS C C>RCS $Header: date.gl,v 2.1 91/11/22 11:45:18 buckley Exp $ C>RCS $Log: date.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:18 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/05 12:50:05 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9 89/06/30 13:30:12 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:26 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:12:13 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:33:41 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:30 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C THIS ROUTINE MUST CALL A SYSTEM ROUTINE TO GET THE CURRENT DATE. C ZZDATE MUST RETURN THIS DATE IN THE CHARACTER VARIABLE CHDATE C IN THE FORM C C (YY+MM+DD) C C AS REQUIRED BY THE ROUTINE ZZDTTM. CHDATE MUST OF LENGTH 10. C ONLY THE 6 CHARACTERS YY MM DD ARE ACTUALLY USED. THE OTHERS C CAN BE ANYTHING, I.E. ONLY THE POSITION OF THE YY MM DD MATTERS. C C THIS MUST CALL A SYSTEM ROUTINE TO GET THE DATE. C TO IMPLEMENT THIS ON ANOTHER SYSTEM, ONE MAY EITHER C C (A) INCORPORATE AN ALTERNATE VERSION OF ZZDATE; C C (B) USE THE "DUMMY" VERSION OF THIS ROUTINE WITH THE SINGLE C EXECUTABLE STATEMENT CHDATE='( + + )', IN WHICH CASE NO C DATE INFORMATION WILL APPEAR IN THE OUTPUT. C## E N T R Y P O I N T S: The natural entry ZZdate. C## S U B R O U T I N E S: System date routine. C## P A R A M E T E R S: NONE are defined. C## L O C A L D E C L: CHARACTER * 9 VAXDAT CHARACTER * 3 NAME (12), TEMP INTEGER I C## S A V E: SAVE NAME C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C## D A T A: DATA NAME /'JAN','FEB','MAR','APR','MAY','JUN', - 'JUL','AUG','SEP','OCT','NOV','DEC' / C## E X E C U T I O N C## E X E C U T I O N C---- INITIALIZE CHDATE CHDATE = '( + + )' CALL DATE(VAXDAT) CHDATE(2:3) = VAXDAT(8:9) CHDATE(8:9) = VAXDAT(1:2) TEMP = VAXDAT(4:6) DO 100 I = 1,12 IF ( TEMP .EQ. NAME(I) ) THEN WRITE ( CHDATE(5:6), '(I2.2)' ) I GOTO 90000 ENDIF 100 CONTINUE C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZdate. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> mparsg.vms REAL FUNCTION ZZMPAR(I) C!!!! DOUBLE PRECISION FUNCTION ZZMPAR(I) C## A R G U M E N T S: INTEGER I C## S T A T U S: C IGNORE LINES BEGINNING WITH "C!!!!" . C C SYSTEM DEPENDENCE: THE CODE IS VERY DEFINITELY MACHINE DEPENDENT C FOR IT CONTAINS MACHINE PRECISION CONSTANTS C FOR MANY MACHINES, AS DESCRIBED BELOW. C C SINGLE/DOUBLE Conversion: NEEDED (SEE CONVRT). C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C>RCS $Header: mpar.gl,v 2.3 91/11/22 11:45:19 buckley Exp $ C>RCS $Log: mpar.gl,v $ C>RCS Revision 2.3 91/11/22 11:45:19 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.2 91/06/12 14:07:08 buckley C>RCS Added stardent C>RCS C>RCS Revision 2.1 90/07/31 10:57:40 buckley C>RCS Added constants for ieee for pc's C>RCS C>RCS Revision 2.0 90/07/06 10:39:26 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9.1.2 90/06/26 14:24:24 buckley C>RCS Fixed single/double precision constants for sun4 C>RCS C>RCS Revision 1.9.1.1 89/07/01 11:36:48 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.9 89/06/30 13:30:15 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:28 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:23 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:34:59 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:31 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C C THIS IS A MODIFICATION OF THE TWO ROUTINES DPMPAR AND SPMPAR C OBTAINED FROM JORGE MORE. IT HAS BEEN CHANGED ONLY TO CONFORM C WITH MY CONVENTIONS, AND TO ADD STATEMENTS FOR THE CDC C CYBERS WHICH ARE ACCEPTABLE TO FTN5 (FORTRAN '77). THE C OTHER CHANGES ARE: C C 1. THE SINGLE NAME ZZMPAR HAS BEEN USED. IT IS DOUBLE OR SINGLE C PRECISION ACCORDING TO CONVERSION BY CONVRT, JUST AS FOR ALL C OF MY OTHER PROGRAMS. C C 2. THE ROUTINES HAVE BEEN MERGED SO THAT SINGLE AND DOUBLE C PRECISION STATEMENTS WHICH CORRESPOND APPEAR IN PAIRS. C C OTHERWISE ALL OF THE COMMENTS OF THE ORIGINAL AUTHORS APPLY. C THEIR ORIGINAL COMMENTS (UNALTERED) FOR THE DOUBLE PRECISION C VERSION FOLLOW IMMEDIATELY. C C FUNCTION DPMPAR C C THIS FUNCTION PROVIDES DOUBLE PRECISION MACHINE PARAMETERS C WHEN THE APPROPRIATE SET OF DATA STATEMENTS IS ACTIVATED (BY C REMOVING THE C FROM COLUMN 1) AND ALL OTHER DATA STATEMENTS ARE C RENDERED INACTIVE. MOST OF THE PARAMETER VALUES WERE OBTAINED C FROM THE CORRESPONDING BELL LABORATORIES PORT LIBRARY FUNCTION. C C THE FUNCTION STATEMENT IS C C DOUBLE PRECISION FUNCTION DPMPAR(I) C C WHERE C C I IS AN INTEGER INPUT VARIABLE SET TO 1, 2, OR 3 WHICH C SELECTS THE DESIRED MACHINE PARAMETER. IF THE MACHINE HAS C T BASE B DIGITS AND ITS SMALLEST AND LARGEST EXPONENTS ARE C EMIN AND EMAX, RESPECTIVELY, THEN THESE PARAMETERS ARE C C DPMPAR(1) B**(1 - T), THE MACHINE PRECISION, C C DPMPAR(2) B**(EMIN - 1), THE SMALLEST MAGNITUDE, C C DPMPAR(3) B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE C C## E N T R Y P O I N T S: The natural entry ZZmpar. C## S U B R O U T I N E S: NONE are called. C## P A R A M E T E R S: NONE are defined. C C## L O C A L D E C L: C NOTE THAT THESE ARRAYS MUST HAVE DIMENSIONS 2 AND 4, RATHER C THAN 1 AND 2 AS ONE MIGHT EXPECT, BECAUSE OF THE PDP-11 C DEFINITIONS. INTEGER MCHEPS(2) C!!!! INTEGER MCHEPS(4) INTEGER MINMAG(2) C!!!! INTEGER MINMAG(4) INTEGER MAXMAG(2) C!!!! INTEGER MAXMAG(4) REAL RMACH(3) C!!!! DOUBLE PRECISION DMACH(3) INTEGER EMIN, EMAX, IMACH(10) REAL B, BINV, BM1, ONE, W, Z C!!!! DOUBLE PRECISION B, BINV, BM1, ONE, W, Z C## S A V E: SAVE RMACH C!!!! SAVE DMACH SAVE IMACH C## E Q U I V A L E N C E S: EQUIVALENCE (RMACH(1),MCHEPS(1)) C!!!! EQUIVALENCE (DMACH(1),MCHEPS(1)) EQUIVALENCE (RMACH(2),MINMAG(1)) C!!!! EQUIVALENCE (DMACH(2),MINMAG(1)) EQUIVALENCE (RMACH(3),MAXMAG(1)) C!!!! EQUIVALENCE (DMACH(3),MAXMAG(1)) C## C O M M O N: NONE is defined. C## D A T A: C-----MACHINE CONSTANTS FOR THE VAX-11. DATA MCHEPS(1) / 13568 / C!!!! DATA MCHEPS(1),MCHEPS(2) / 9472, 0 / DATA MINMAG(1) / 128 / C!!!! DATA MINMAG(1),MINMAG(2) / 128, 0 / DATA MAXMAG(1) / -32769 / C!!!! DATA MAXMAG(1),MAXMAG(2) / -32769, -1 / C## E X E C U T I O N C## E X E C U T I O N ZZMPAR = RMACH(I) C!!!! ZZMPAR = DMACH(I) C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZmpar. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> opensg.vms SUBROUTINE ZZOPEN ( IUNIT, FLAG, INAME, * , RECLEN ) C## A R G U M E N T S: INTEGER IUNIT, RECLEN LOGICAL FLAG CHARACTER *(*) INAME C## S T A T U S: C IGNORE LINES BEGINNING WITH "C!!!!" . C C SINGLE/DOUBLE Conversion: NEEDED (SEE CONVRT). C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR C OPENING AND CLOSING FILES. C C THIS VERSION IS FOR VAX/VMS C C>RCS $Header: open.gl,v 2.1 91/11/22 11:45:21 buckley Exp $ C>RCS $Log: open.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:21 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/06 10:43:19 buckley C>RCS Common version for TOMS and MT C>RCS C>RCS Revision 1.9.1.2 89/07/01 11:51:41 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.9.1.1 89/07/01 11:36:50 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.9 89/06/30 13:30:16 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:29 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:26 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:02 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:31 buckley C>RCS Initial revision C>RCS C## D E S C R I P T I O N: C C THIS OPENS THE FILES NEEDED FOR TESTPACK AND KEEPS TRACK OF C WHICH ARE OPEN AND WHICH ARE NOT. IT ALSO SUPPLIES THE APPRO- C PRIATE ARGUMENTS FOR EACH FILE. C C IF NAME IS NOT BLANK ON ENTRY, THEN THE FILE IS OPENED C WITH THE NAME GIVEN. OTHERWISE, NO NAME IS SPECIFIED WHEN C OPENING THE FILE. C C THE OPEN IS ONLY DONE IF "FLAG" IS TRUE. C C IF RECLEN IS NOT EQUAL TO ZERO, THEN THE FILE IS OPENED C AS DIRECT ACCESS UNFORMATTED. C C IF RECLEN IS EQUAL TO ZERO, THEN THE FILE IS OPENED C FOR FORMATTED SEQUENTIAL ACCESS. C C## E N T R Y P O I N T S: The natural entry ZZopen and ZZclse C## S U B R O U T I N E S: OPEN, CLOSE, REAL ...INTRINSIC C ZZERRM ...FOR ERROR MESSAGES. C## P A R A M E T E R S: INTEGER FILENL, NFILES PARAMETER ( FILENL = 80, NFILES = 15 ) CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) CHARACTER*(*) PERIOD, COMMA, SEMICN PARAMETER ( PERIOD = '.', COMMA = ',', SEMICN = ';' ) CHARACTER*(*) COLON, DASH, EQUALS PARAMETER ( COLON = ':', DASH = '-', EQUALS = '=' ) CHARACTER*(*) OBRACE, CBRACE, UNDERS PARAMETER ( OBRACE = '{', CBRACE = '}', UNDERS = '_' ) CHARACTER*(*) PLUS, MINUS, EXCLAM PARAMETER ( PLUS = '+', MINUS = '-', EXCLAM = '!' ) CHARACTER*(*) GTHAN, LTHAN, QUESMK PARAMETER ( GTHAN = '>', LTHAN = '<', QUESMK = '?' ) CHARACTER*(*) SLASH, BSLASH, PERCNT PARAMETER ( SLASH = '/', BSLASH = '\\',PERCNT = '%' ) CHARACTER*(*) CARAT, ATSIGN, TILDE PARAMETER ( CARAT = '^', ATSIGN = '@', TILDE = '~' ) LOGICAL T, F PARAMETER ( T = .TRUE., F = .FALSE. ) CHARACTER*(*) TRUE, QT, FALSE, QF PARAMETER ( TRUE = 'TRUE', QT = 'T', FALSE = 'FALSE', QF = 'F' ) INTEGER ITRUE, IFALSE PARAMETER ( ITRUE = 1, IFALSE = 0 ) REAL RTRUE, RFALSE C!!!! DOUBLE PRECISION RTRUE, RFALSE PARAMETER ( RTRUE = 1.D0, RFALSE = 0.D0 ) INTEGER CTOUPP, CTOLOW, CTOCAP PARAMETER ( CTOUPP = 1, CTOLOW = 2, CTOCAP = 3 ) INTEGER PREPRC, DAUF, INPTUN PARAMETER ( PREPRC = 1, DAUF = 2, INPTUN = 3 ) INTEGER TEMPUN, STDIN, TRMOUT PARAMETER ( TEMPUN = 4, STDIN = 5, TRMOUT = 6 ) INTEGER WRITUN, TRACUN, SUMMUN PARAMETER ( WRITUN = 7, TRACUN = 8, SUMMUN = 9 ) INTEGER COPYUN, TEXUN PARAMETER ( COPYUN =10, TEXUN =11 ) CHARACTER *(*) SEQ , DIR PARAMETER ( SEQ = 'SEQUENTIAL', DIR = 'DIRECT' ) CHARACTER *(*) UNKN , NEW PARAMETER ( UNKN = 'UNKNOWN' , NEW = 'NEW' ) CHARACTER *(*) OLD , SCR PARAMETER ( OLD = 'OLD' , SCR = 'SCRATCH' ) CHARACTER *(*) DEL , KEEP PARAMETER ( DEL = 'DELETE' , KEEP = 'KEEP' ) CHARACTER *(*) FMT , UNFRMT PARAMETER ( FMT = 'FORMATTED' , UNFRMT = 'UNFORMATTED' ) C## L O C A L D E C L: INTEGER ERRINT, UNIT LOGICAL OPENFS(NFILES), REW, OPENIT, COPY CHARACTER STAT*7, ACCS*10, FRMT*11 CHARACTER *(FILENL) COPYNM, NAME REAL RD C!!!! DOUBLE PRECISION RD C## S A V E: SAVE OPENFS, COPY, COPYNM C## E Q U I V A L E N C E S: NONE ARE DEFINED. C## C O M M O N: NONE IS DEFINED. C## D A T A: DATA OPENFS / NFILES * .FALSE. / DATA COPY/F/, COPYNM/BLANK/ C## E X E C U T I O N C## E X E C U T I O N C----- DEFINE A STATEMENT FUNCTION. RD(UNIT) = REAL(UNIT) C!!!! RD(UNIT) = DBLE(UNIT) IF ( FLAG ) THEN IF ( RECLEN .EQ. 0 ) THEN ACCS = SEQ FRMT = FMT ELSE ACCS = DIR FRMT = UNFRMT ENDIF UNIT = IUNIT NAME = INAME 100 CONTINUE OPENIT = .NOT. OPENFS(UNIT) REW = .FALSE. IF ( UNIT .EQ. SUMMUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. TRMOUT ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. STDIN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. PREPRC) THEN STAT = OLD REW = .TRUE. ELSE IF ( UNIT .EQ. TEMPUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. WRITUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. TRACUN ) THEN STAT = UNKN ELSE IF ( UNIT .EQ. DAUF ) THEN STAT = OLD ELSE IF ( UNIT .EQ. COPYUN ) THEN STAT = UNKN COPY = T ELSE IF ( UNIT .EQ. INPTUN ) THEN STAT = OLD REW = .TRUE. ELSE CALL ZZERRM ( RD(UNIT), *91000, - 'IS REQUEST TO OPEN UNKNOWN UNIT # ' ) ENDIF C FOR THE "CHOICE OF UNIT..." 500 IF ( OPENIT ) THEN IF ( NAME .EQ. BLANK ) THEN C PRINT*,'OPENING ',UNIT,'NAME=' IF ( RECLEN .EQ. 0 ) THEN OPEN ( UNIT = UNIT, - ERR = 1000, - IOSTAT = ERRINT, - STATUS = STAT, - ACCESS = ACCS, - FORM = FRMT ) ELSE OPEN ( UNIT = UNIT, - ERR = 1000, - IOSTAT = ERRINT, - STATUS = STAT, - ACCESS = ACCS, - RECL = RECLEN, - FORM = FRMT ) ENDIF ELSE C NAMED FILE IF ( RECLEN .EQ. 0 ) THEN C PRINT*,'OPENING ',UNIT,'NAME=',NAME(1:20) OPEN ( UNIT = UNIT, - ERR = 1000, - IOSTAT = ERRINT, - FILE = NAME, - STATUS = STAT, - ACCESS = ACCS, - FORM = FRMT ) C PRINT*,'OK' ELSE OPEN ( UNIT = UNIT, - ERR = 1000, - FILE = NAME, - IOSTAT = ERRINT, - STATUS = STAT, - ACCESS = ACCS, - RECL = RECLEN, - FORM = FRMT ) ENDIF ENDIF ENDIF C FOR EACH UNIT FROM 1 TO NFILES WE NEED TO KEEP A RECORD OF C WHETHER IT IS CURRENTLY OPEN. OPENFS(UNIT) = .TRUE. IF ( REW .AND. RECLEN .EQ. 0 ) THEN REWIND UNIT ENDIF GOTO 1025 1000 IF ( UNIT .EQ. DAUF ) THEN C CREATE THE DAUF. STAT = NEW GOTO 500 ELSE GOTO 1050 ENDIF 1025 CONTINUE IF ( COPY .AND. UNIT .EQ. STDIN ) THEN UNIT = COPYUN NAME = COPYNM GOTO 100 ENDIF ENDIF C FOR THE "IF FLAG..." GOTO 90000 1050 CONTINUE GOTO 91000 C## E N T R Y ZZCLSE: ENTRY ZZCLSE ( IUNIT, * ) STAT = KEEP IF ( IUNIT .EQ. SUMMUN ) THEN STAT = KEEP ELSE IF ( IUNIT .EQ. TRMOUT ) THEN ELSE IF ( IUNIT .EQ. STDIN ) THEN ELSE IF ( IUNIT .EQ. TEMPUN ) THEN STAT = KEEP ELSE IF ( IUNIT .EQ. WRITUN ) THEN ELSE IF ( IUNIT .EQ. TRACUN ) THEN ELSE IF ( IUNIT .EQ. COPYUN ) THEN STAT = KEEP COPY = F ELSE IF ( IUNIT .EQ. DAUF ) THEN ELSE IF ( IUNIT .EQ. PREPRC ) THEN ELSE IF ( IUNIT .EQ. INPTUN ) THEN ELSE CALL ZZERRM ( RD(IUNIT), *91000, - 'IS IGNORING REQUEST TO CLOSE UNKNOWN UNIT #' ) ENDIF IF ( OPENFS(IUNIT) ) THEN C PRINT*,'CLOSING ',IUNIT CLOSE ( UNIT = IUNIT, STATUS = STAT ) OPENFS(IUNIT) = .FALSE. ENDIF RETURN C## E X I T 90000 CONTINUE CALL ZZCASE (STAT,CTOUPP) IF ( IUNIT .EQ. DAUF .AND. STAT .EQ. NEW ) THEN GOTO 91000 ELSE RETURN ENDIF 91000 RETURN 1 C## F O R M A T S: NONE ARE DEFINED. C## E N D OF ZZOPEN. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> reclsg.vms INTEGER FUNCTION ZZRECL ( CPERLN, IPERLN, LPERLN, RPERLN ) C## A R G U M E N T S: INTEGER CPERLN, IPERLN, LPERLN, RPERLN C## S T A T U S: C SINGLE/DOUBLE Conversion: Needed (See CONVRT). C C Ignore lines beginning with "C!!!!" . C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C System Dependence: System routine for direct C access unformatted record length C C THIS VERSION IS FOR VAX/VMS C C>RCS $Header: recl.gl,v 2.1 91/11/22 11:45:23 buckley Exp $ C>RCS $Log: recl.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:23 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/16 14:39:15 buckley C>RCS Added Lahey C>RCS C>RCS Revision 1.9 89/06/30 13:30:18 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:30 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:29 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:07 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:32 buckley C>RCS Initial revision C>RCS C## D E S C R I P T I O N: C C THIS ROUTINE USES FOUR INTEGER CONSTANTS NEEDED TO DETERMINE C THE LENGTH OF AN UNFORMATTED RECORD FOR READING AND WRITING C DIRECT ACCESS FILES. THE PROCESSOR IS ASSUMED, ACCORDING C TO THE FORTRAN STANDARD, TO WRITE UNFORMATTED RECORDS C IN "PROCESSOR DEFINED UNITS", I.E. IN PDU'S. C C HERE WE MUST DEFINE FOUR CONSTANTS: C C CHARS THE NUMBER OF PDU'S NEEDED TO WRITE ONE CHARACTER; C INTS THE NUMBER OF PDU'S NEEDED TO WRITE ONE INTEGER VALUE; C LOGS THE NUMBER OF PDU'S NEEDED TO WRITE ONE LOGICAL VALUE; C REALS THE NUMBER OF PDU'S NEEDED TO WRITE ONE REAL(DP) VALUE. C C NOTE THAT IT MAY HAPPEN (PARTICULARLY WITH CHARACTER OR LOGICAL C DATA) THAT SEVERAL VALUES MAY FIT INTO ONE PDU. IN THIS CASE, SET C THE CONSTANT TO A NEGATIVE VALUE. FOR EXAMPLE, ON A CYBER, A PDU C IS ONE WORD AND 10 CHARACTERS FIT PER WORD. IN THIS CASE, CHARS C IS SET TO -10. BUT ON A VAX, A PDU IS ONE BYTE AND AN INTEGER C OCCUPIES 4 BYTES, SO INTS IS SET TO 4. NOTE THAT THE VALUES FOR C 'REALS' WILL GENERALLY BE DIFFERENT FOR THE SINGLE AND DOUBLE C PRECISION VERSIONS ON THE SAME MACHINE. C C ON ENTRY, THE FOUR ARGUMENTS INDICATE HOW MANY VALUES OF EACH OF C THE FOUR BASIC TYPES ARE REQUIRED TO FIT IN ONE DIRECT ACCESS C UNFORMATTED RECORD. THIS ROUTINE WILL DETERMINE THE MINIMUM RECORD C LENGTH NEEDED TO SATISFY ALL FOUR REQUIREMENTS. THAT VALUE WILL BE C RETURNED AS THE VALUE OF THE FUNCTION ZZRECL. C C IT WILL THEN *RETURN* IN EACH OF THE FOUR ARGUMENTS THE *ACTUAL* C NUMBER OF EACH OF THESE WHICH CAN FIT IN THE RECORD OF THE SIZE C DETERMINED. C C N.B. **** THIS ROUTINE ASSUMES *NO MIXING* OF DATA TYPES ON C ANY ONE RECORD WHEN USING DIRECT ACCESS UNFORMATTED I/O. C THUS EACH TIME A RECORD IS WRITTEN, IT CONTAINS *ONLY* C CHARACTER DATA, OR *ONLY* INTEGER DATA, OR *ONLY* REAL C DATA, OR *ONLY* LOGICAL DATA. ANY MIXING WOULD C TOTALLY DESTROY ANY HOPE OF PORTABILITY TO SOME SYSTEMS. C C## E N T R Y P O I N T S: The natural entry ZZRECL. C## S U B R O U T I N E S: ABS, MAX ... INTRINSIC C C## P A R A M E T E R S: INTEGER CHARS, INTS, LOGS, REALS PARAMETER ( CHARS = 1, INTS = 4, LOGS = 4, REALS = 4 ) C!!!! PARAMETER ( CHARS = 1, INTS = 4, LOGS = 4, REALS = 8 ) C## L O C A L D E C L: INTEGER N C## S A V E: NONE selected. C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C## D A T A: NONE are set. C## E X E C U T I O N C## E X E C U T I O N ZZRECL = 1 IF ( CHARS .LT. 0 ) THEN N = ABS(CHARS) N = ( CPERLN + N - 1 ) / N ELSE N = CPERLN * CHARS ENDIF ZZRECL = MAX ( ZZRECL, N ) IF ( INTS .LT. 0 ) THEN N = ABS(INTS) N = ( IPERLN + N - 1 ) / N ELSE N = IPERLN * INTS ENDIF ZZRECL = MAX ( ZZRECL, N ) IF ( LOGS .LT. 0 ) THEN N = ABS(LOGS) N = ( LPERLN + N - 1 ) / N ELSE N = LPERLN * LOGS ENDIF ZZRECL = MAX ( ZZRECL, N ) IF ( REALS .LT. 0 ) THEN N = ABS(REALS) N = ( RPERLN + N - 1 ) / N ELSE N = RPERLN * REALS ENDIF ZZRECL = MAX ( ZZRECL, N ) C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZRECL. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> secssg.vms SUBROUTINE ZZSECS(SECS) C## A R G U M E N T S: REAL SECS C!!!! DOUBLE PRECISION SECS C## S T A T U S: C SINGLE/DOUBLE Conversion: NEEDED (SEE CONVRT). C C IGNORE LINES BEGINNING WITH "C!!!!" . C C This version is in S I N G L E precision. C!!!! This version is in D O U B L E precision. C C SYSTEM DEPENDENCE: System routine for CPU usage. C This version is for VAX/VMS C C>RCS $Header: secs.gl,v 2.1 91/11/22 11:45:25 buckley Exp $ C>RCS $Log: secs.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:25 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/06 10:48:10 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9 89/06/30 13:30:19 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:31 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:31 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:12 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:33 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C THIS SUBROUTINE SHOULD OBTAIN (FROM THE OPERATING SYSTEM) THE C AMOUNT OF CPU TIME USED BY THE CALLING PROGRAM SINCE THE C EXECUTION BEGAN. IF DESIRABLE, "SECS" CAN ALSO BE CONVERTED C TO DOUBLE PRECISION (SEE CONVRT). HOWEVER, THE ROUTINE ACTUALLY C WORKS TOTALLY AS A SINGLE PRECISION ROUTINE, EXCEPT THAT THE C VALUE WHICH IS PASSED BACK MAY BE IN EITHER PRECISION AS C APPROPRIATE. C TIME IS MEASURED FROM THE FIRST CALL TO ZZSECS. THUS C ON THE FIRST CALL TO ZZSECS, A TIME OF 0.0 SECONDS IS ALWAYS C RETURNED. C## E N T R Y P O I N T S: The natural entry ZZSECS. C## S U B R O U T I N E S: A SYSTEM CLOCK. C## P A R A M E T E R S: REAL R100 PARAMETER ( R100 = 100.0 ) C## L O C A L D E C L: LOGICAL FIRST INTEGER CLOCK REAL STTIME, SEC C## S A V E: SAVE FIRST, STTIME C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C## D A T A: DATA FIRST/.TRUE./ C## E X E C U T I O N C## E X E C U T I O N IF ( FIRST ) THEN FIRST = .FALSE. STTIME = LIB$INIT_TIMER ( ) STTIME = ZERO SEC = ZERO ELSE SEC = LIB$STAT_TIMER ( %REF(2), %REF(CLOCK), ) SEC = ( REAL(CLOCK)/R100 ) - STTIME ENDIF SECS = SEC C!!!! SECS = DBLE(SEC) C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZSECS. END C <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> <<=>> timesg.vms SUBROUTINE ZZTIME ( CHTIME ) C## A R G U M E N T S: CHARACTER *(*) CHTIME C## S T A T U S: C SINGLE/DOUBLE Conversion: NOT required. C C System Dependence: System routine for Time. C C THIS VERSION IS FOR VAX/VMS C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C>RCS $Header: time.gl,v 2.1 91/11/22 11:45:26 buckley Exp $ C>RCS $Log: time.gl,v $ C>RCS Revision 2.1 91/11/22 11:45:26 buckley C>RCS Final submission to TOMS C>RCS C>RCS Revision 2.0 90/07/06 10:52:37 buckley C>RCS common version for TOMS and MT C>RCS C>RCS Revision 1.9 89/06/30 13:30:20 buckley C>RCS Preparing Submitted Version of Mt C>RCS C>RCS Revision 1.3.1.1 89/05/20 13:46:32 buckley C>RCS Temp. test of Mt before submitting C>RCS C>RCS Revision 1.3 89/05/18 12:13:33 buckley C>RCS Final test of Mt before submitting C>RCS C>RCS Revision 1.2 89/05/15 14:35:16 buckley C>RCS Initial Installation of MT into RCS form. C>RCS C>RCS Revision 1.1 89/01/17 16:34:33 buckley C>RCS Initial revision C>RCS C C## D E S C R I P T I O N: C C THIS ROUTINE MUST CALL A SYSTEM ROUTINE TO GET THE CURRENT TIME. C IT MUST RETURN THIS TIME IN THE CHARACTER VARIABLE CHTIME C IN THE FORM C C (HH+MM+SS) C C AS REQUIRED BY THE ROUTINE ZZDTTM. CHTIME MUST BE OF LENGTH 10. C ONLY THE SIX CHARACTERS HH MM SS ARE ACTUALLY USED. THE OTHERS C CAN BE ANYTHING, BUT THE HH, MM AND SS MUST BE IN THE CORRECT C POSITION. HH SHOULD BE BETWEEN 0 AND 23, I.E. BASED ON THE 24 HOUR C CLOCK. OF COURSE MM AND SS MUST BE IN THE RANGE 0 TO 59. C C THIS VERSION CALLS A SYSTEM DEPENDENT ROUTINE. C TO IMPLEMENT THIS ON ANOTHER SYSTEM, ONE MAY EITHER C C (A) INCORPORATE AN ALTERNATE VERSION OF ZZTIME; C C (B) USE THE "DUMMY" VERSION OF THIS ROUTINE WITH THE SINGLE C EXECUTABLE STATEMENT CHTIME=' ', IN WHICH CASE NO C TIME INFORMATION WILL APPEAR IN THE OUTPUT. C C## E N T R Y P O I N T S: The natural entry ZZTIME. C## S U B R O U T I N E S: SYSTEM ROUTINE TO GET TIME OF DAY. C## P A R A M E T E R S: NONE are defined. C## L O C A L D E C L: CHARACTER * 8 VAXTIM C## S A V E: NONE selected. C## E Q U I V A L E N C E S: NONE are defined. C## C O M M O N: NONE is defined. C## D A T A: NONE are set. C## E X E C U T I O N C## E X E C U T I O N CALL TIME (VAXTIM) CHTIME(2:9) = VAXTIM(1:8) C## E X I T 90000 RETURN C## F O R M A T S: NONE are defined. C## E N D of ZZTIME. END