C REMARK ON ALGORITHM 630, COLLECTED ALGORITHMS FROM ACM. C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, C VOL. 11, NO. 2, PP. 103-119. PROGRAM TESTBB * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: ISOLATED INTO 5 SMALL SUBROUTINES C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: REQUIRED (SEE CONVRT) C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C OCT. 30, 1988 A. BUCKLEY 1.1 C C======================== D E S C R I P T I O N ======================== C C THIS IS A ROUTINE PROVIDED TO TEST BBVSCG AND BBLNIR AFTER C INSTALLATION ON A PARTICULAR SYSTEM. IT CALLS BBVSCG AND BBLNIR C TO MINIMIZE A COLLECTION OF 10 TEST FUNCTIONS WHICH ARE PROVIDED C IN ZZFNS. C C IT ALSO SERVES AS A MODEL TO ILLUSTRATE THE USE OF SOME OF THE C FEATURES OF THE MINIMIZATION ALGORITHM IMPLEMENTATION. C C FOR AN EXAMPLE OF THE CODING OF A TEST FUNCTION, SEE THE ROUTINE C ZZFNS. TO SEE HOW TO CHANGE THE INTEGER COMMUNICATION PARAMETERS C (ESSENTIALLY LIKE ENUMERATED TYPES OF PASCAL), SEE THE EXAMPLES C BELOW AT FORTRAN LABEL 19. C C EACH FUNCTION IS MIMIMIZED SEVERAL TIMES. BOTH BBVSCG AND C BBLNIR ARE CALLED. TESTS INVOLVE ANALYTIC AND DIFFERENCED DERI- C VATIVES AND USE BOTH FORWARD AND REVERSE COMMUNICATION. BOTH THE C CONJUGATE GRADIENT AND QUASI-NEWTON CODES ARE TRIED AS WELL AS C THE NOCEDAL UPDATES. C C----- SUMMARY OF TESTS. C C 1. SIMPLE CALL TO BBVSCG, ANALYTIC DERIVATIVES, FORWARD CALLS. C 2. SIMPLE CALL TO BBVSCG, ANALYTIC DERIVATIVES, REVERSE CALLS. C 3. SIMPLE CALL TO BBVSCG, FINITE DIFFERENCES, FORWARD CALLS. C 4. SIMPLE CALL TO BBVSCG, DERIVATIVE TESTING, FORWARD CALLS. C C 5. DIRECT CALL TO BBLNIR, ANALYTIC, FORWARD, METH = 2. C 6. DIRECT CALL TO BBLNIR, ANALYTIC, REVERSE, METH = -2. C C 7. SIMPLE CALL TO BBVSCG, ANALYTIC DERIVATIVES, NOCEDAL UPDATES. C C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT TESTBB C C======================== S U B R O U T I N E S ======================== C C BBVSCG C C BBLNIR ( AND ENTRY POINTS THEREIN ) C C BBDFLT C C ZZEVAL ( AND ENTRY POINT ZZECHK THEREIN ) C C ZZFNS ( ALSO THROUGH ENTRY POINTS ZZFSET AND ZZFPAR) C ZZDATE C ZZDTTM C ZZLENG C ZZLCUC C ZZSHFT C ZZTIME C C ZZSECS C C BARD70, BIGGS6, BOX663, CRGLVY, ENGVL2! A SUBSET OF A FULL COLL- C PENAL1, PENAL2, PWSING, ROSENB, SCHMVT! ECTION OF TEST FUNCTIONS C C========================= P A R A M E T E R S ========================= * * 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-----DEFINE AMOUNT OF WORKING STORAGE. * INTEGER EXTRA, MXN, LWORK PARAMETER ( EXTRA = 20, MXN = 40, LWORK = (MXN*(MXN+7))/2 ) * C-----SET UNITS FOR TERMINAL INPUT/OUTPUT FOR CONTROL. C OUTPT IS FOR OUTPUT FROM TEST; SAVED ON A FILE. * 11 INTEGER TRMINP, TRMOUT, OUTPT PARAMETER ( TRMINP = 5, TRMOUT = 6, OUTPT = 8 ) * C-----DEFINE TOTAL NUMBER OF ALLOWABLE FUNCTION ARGUMENTS. * * INTEGER FNO PARAMETER ( FNO = 10 ) * C-----DEFINE TOTAL NUMBER OF TESTS AND PROBLEMS. * INTEGER TESTS, NPROBS, TTESTS PARAMETER ( TESTS = 7, NPROBS = 10, TTESTS = TESTS*NPROBS ) * C-----FOR ZZEVAL: NUMBER OF FUNCTION EVALUATIONS. * INTEGER MAX PARAMETER ( MAX = 300 ) * C-----FOR ZZPRNT: FIRST AND LAST FUNCTION VALUES PRINTED. * INTEGER PFREQ PARAMETER ( PFREQ = -1000 ) * C-----FOR ZZTERM: ACCURACY REQUIREMENT. * DOUBLE PRECISION ACC C!!!! REAL ACC PARAMETER ( ACC = 5.D-4 ) * C-----FOR BBLNIR: ESTIMATE OF FUNCTION REDUCTION. * DOUBLE PRECISION DECRF C!!!! REAL DECRF PARAMETER ( DECRF = -1.0D0 ) * C---- MISCELLANEOUS CONSTANTS (NOT ALL USED). * DOUBLE PRECISION ZERO, ONE, TWO, THREE C!!!! REAL ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) * DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN C!!!! REAL FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) * DOUBLE PRECISION EIGHT, NINE, TEN C!!!! REAL EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 8D0, TEN = 10D0 ) * DOUBLE PRECISION TENTH, FIFTH, HALF C!!!! REAL TENTH, FIFTH, HALF PARAMETER ( TENTH = .1D0, FIFTH = .2D0, HALF = .5D0 ) * DOUBLE PRECISION RPT9, RPT8, RD29 C!!!! REAL RPT9, RPT8, RD29 PARAMETER ( RPT9 = .9D0, RPT8 = .8D0, RD29 = 1D0/29D0 ) DOUBLE PRECISION R11, R12, R13, R14 C!!!! REAL R11, R12, R13, R14 PARAMETER ( R11 = 11D0, R12 = 12D0, R13 = 13D0,R14 = 14D0) * DOUBLE PRECISION R15, R16, R17, R18 C!!!! REAL R15, R16, R17, R18 PARAMETER ( R15 = 15D0, R16 = 16D0, R17 = 17D0,R18 = 18D0) * DOUBLE PRECISION R19, R20, R25, R29 C!!!! REAL R19, R20, R25, R29 PARAMETER ( R19 = 19D0, R20 = 20D0, R25 = 25D0,R29 = 29D0) * DOUBLE PRECISION R32, R36, R40, R42 C!!!! REAL R32, R36, R40, R42 PARAMETER ( R32 = 32D0, R36 = 36D0, R40 = 40D0,R42 = 42D0) * DOUBLE PRECISION R45, R49 C!!!! REAL R45, R49 PARAMETER ( R45 = 45D0, R49 = 49D0 ) * DOUBLE PRECISION R50, R56, R84, R90 C!!!! REAL R50, R56, R84, R90 PARAMETER ( R50 = 50D0, R56 = 56D0, R84 = 84D0,R90 = 90D0) * DOUBLE PRECISION R100, R180, R200 C!!!! REAL R100, R180, R200 PARAMETER ( R100 = 100D0, R180 = 180D0, R200 = 200D0 ) * DOUBLE PRECISION R256, R360, R400 C!!!! REAL R256, R360, R400 PARAMETER ( R256 = 256D0, R360 = 360D0, R400 = 400D0 ) * DOUBLE PRECISION R600, R681, R991 C!!!! REAL R600, R681, R991 PARAMETER ( R600 = 600D0, R681 = 681D0, R991 = 991D0 ) * DOUBLE PRECISION R1162, R2324 C!!!! REAL R1162, R2324 PARAMETER ( R1162 = 1162D0, R2324 = 2324D0 ) * DOUBLE PRECISION R10000, R40000 C!!!! REAL R10000, R40000 PARAMETER ( R10000 = 10000D0, R40000 = 40000D0 ) DOUBLE PRECISION R1PD6, R2PDM6 C!!!! REAL R1PD6, R2PDM6 PARAMETER ( R1PD6 = 1D6, R2PDM6 = 2D-6 ) * DOUBLE PRECISION RP04, RP01, R1PZ1 C!!!! REAL RP04, RP01, R1PZ1 PARAMETER ( RP04 = 4D-2, RP01 = .01D0, R1PZ1 = 1.0001D0 ) * DOUBLE PRECISION R1P2 C!!!! REAL R1P2 PARAMETER ( R1P2 = 1.2D0 ) * DOUBLE PRECISION R1P5, R2P5, R2P625 C!!!! REAL R1P5, R2P5, R2P625 PARAMETER ( R1P5 = 1.5D0, R2P5 = 2.5D0, R2P625 = 2.625D0 ) * DOUBLE PRECISION R10P1, R19P8, R20P2 C!!!! REAL R10P1, R19P8, R20P2 PARAMETER ( R10P1 = 10.1D0,R19P8 = 19.8D0,R20P2 = 20.2D0 ) * DOUBLE PRECISION R2D3, R4D3, R7D3 C!!!! REAL R2D3, R4D3, R7D3 PARAMETER ( R2D3 = 2D0/3D0,R4D3 = 4D0/3D0,R7D3 = 7D0/3D0 ) * DOUBLE PRECISION R2P25 C!!!! REAL R2P25 PARAMETER ( R2P25 = 2.25D0 ) * C======================= D E C L A R A T I O N S ======================= * C---- DEFINE THE ARRAYS FOR REVISING CONTROL PARAMETERS. * INTEGER INTS(NINTS) LOGICAL LOGS(NLOGS) * DOUBLE PRECISION REALS(NREALS) C!!!! REAL REALS(NREALS) * C---- DEFINE THE IW, RW, DW ARRAYS AND THE INNER PRODUCT ROUTINE. * INTEGER IW(EXTRA) REAL RW(EXTRA) DOUBLE PRECISION DW(EXTRA), ZZINNR EXTERNAL ZZINNR * C---- PLACES TO HOLD SOME STATISTICS AND STUFF FROM THE TESTS. * INTEGER ICNTS(TTESTS), FCNTS(TTESTS), FNCT, GRCT, ITCT * DOUBLE PRECISION FVALS(TTESTS), ACCTIM C!!!! REAL FVALS(TTESTS), ACCTIM * INTEGER DIM(NPROBS), IFNC(NPROBS), INDX(NPROBS), COMPNT(NPROBS) * C---- VALUES USED TO REDEFINE COMMUNICATION PARAMETERS. * INTEGER ANAL, DIFF, TEST, DOFG INTEGER NORMFG, NORMAL, RCSTRT, RCRPT, RCNOFG, PSTHRU INTEGER DONE, RCF, RCFG, RCG, NOSTOR, IPMIN, IPUNDF INTEGER BDMETH, LSFAIL, NODESC, XSFUNC, RABORT, USERV, PSBACK * C---- VARIOUS DECLARATIONS NEEDED TO RUN THE TESTS. * INTEGER N, STATUS, METH, ERROR, I, M, ID, IX ,UNIT INTEGER IG, IH, DERVMD, DINDX, DCOMP, CASE, CONTRL, FROM, TO INTEGER ITERS, FUNCS, FREQ, PDONE, TFNCS, TITERS * DOUBLE PRECISION X(MXN), G(MXN), WORK(LWORK+EXTRA), DERERR(NPROBS) C!!!! REAL X(MXN), G(MXN), WORK(LWORK+EXTRA), DERERR(NPROBS) * DOUBLE PRECISION FX, DERR, TIME, AVERRS(NPROBS), AVERR C!!!! REAL FX, DERR, TIME, AVERRS(NPROBS), AVERR * DOUBLE PRECISION FARG(FNO), RPAR1(NPROBS), RPAR2(NPROBS), ACCT C!!!! REAL FARG(FNO), RPAR1(NPROBS), RPAR2(NPROBS), ACCT * CHARACTER*52 TITLE(TESTS) CHARACTER*41 DATE CHARACTER*4 QUITS * EXTERNAL ZZFNS * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== * C---- DIMENSIONS OF THE TEST PROBLEMS. * DATA DIM / 3, 6, 3, 4, 3, 10, 10, 40, 2, 3 / * C---- NUMBERS OF THE TEST PROBLEMS. * DATA IFNC / 26, 11, 16, 27, 25, 40, 41, 3, 1, 24 / * C---- ARGUMENTS NEEDED FOR THE TEST PROBLEMS. * DATA RPAR1 / 0.D0, 13.D0, 10.D0, 2*0.D0, 2*1.D-5, 3*0D0/ * DATA RPAR2 / 5*0.D0, 2*1.D0, 3*0.D0 / * DATA FARG / FNO * 1.D0 / * C---- OUTPUT IDENTIFICATION. * DATA TITLE - -/ ' CALL BBVSCG, ANALYTIC MODE, FORWARD CALLS.' , - ' CALL BBVSCG, ANALYTIC MODE, REVERSE CALLS.' , - ' CALL BBVSCG, DIFFERENCING, FORWARD CALLS.' , - ' CALL BBVSCG, TESTING MODE, FORWARD CALLS.' , - ' CALL BBLNIR, ANALYTIC MODE, FORWARD CALLS; METH= 2.' , - ' CALL BBLNIR, ANALYTIC MODE, REVERSE CALLS; METH=-2.' , - ' CALL BBVSCG, ANALYTIC MODE, NOCEDAL UPDATES.' / * C========================== E X E C U T I O N ========================== * C WE BEGIN BY REDEFINING THE INTEGER (ENUMERATED) CONTROL PARAMETERS C USED FOR INTER-PROGRAM COMMUNICATION. THE VALUES SET HERE ARE C DIFFERENT THAN THE DEFAULTS. NORMALLY THEY ARE NOT CHANGED UNLESS C THE DEFAULTS CONFLICT WITH THE USER'S PROGRAMS. THEY ARE CHANGED C HERE ONLY FOR ILLUSTRATIVE PURPOSES. OF COURSE, WE MUST BE CAREFUL C TO USE THE VALUES OF THE CODES AS WE DEFINE THEM. SEE, FOR EXAMPLE C LABELS 5200 AND 5333. * C ENTRY BBLDDF ( ANAL, DIFF, TEST, SFIRST ) 19 ANAL = 2 DIFF = 3 TEST = 4 CALL BBLDDF ( ANAL, DIFF, TEST, -1 ) * C ENTRY BBLFDF ( DOF, DOG, DOFG, NONE ) DOFG = 3 CALL BBLFDF ( 1, 2, DOFG, 0 ) C REDEFINE CODES IN TEST ROUTINE ZZFNS WHICH IS PROVIDED AS WELL. CALL ZZFFDF ( 1, 2, DOFG, 0 ) * C ENTRY BBLIDF ( SNRMFG, SNORML, SRCSTR, SRCRPT, SRCNFG, SPSTHR ) CALL BBLIDF ( -1, -2, 1, 2, 0, 99 ) NORMFG = -1 NORMAL = -2 RCSTRT = 1 RCRPT = 2 RCNOFG = 0 PSTHRU = 99 * C ENTRY BBLSDF ( SDONE, SRCF, SRCFG, SRCG, SNSTOR, SIPMIN, C - SIPUNF, SBDMTH, SLSFAL, SNODSC, SXSFNC, SRABRT, SUSERV, SPSBCK) CALL BBLSDF (0, 1, 2, 3, -1, -2, -3, -4, -5, -6, -7, -8, -9, 99) DONE = 0 RCF = 1 RCFG = 2 RCG = 3 NOSTOR = -1 IPMIN = -2 IPUNDF = -3 BDMETH = -4 LSFAIL = -5 NODESC = -6 XSFUNC = -7 RABORT = -8 USERV = -9 PSBACK = 99 * C ENTRY BBLRDF ( SOK, SABORT, SLIMIT, SNOF, SNOG, SNOFG ) CALL BBLRDF ( 0, 1, 2, 3, 4, 5 ) * C---- INITIALIZE TIMING. * CALL ZZSECS (TIME) ACCTIM = ZERO * OPEN ( OUTPT, FILE = 'RESULTS' ) CALL ZZDTTM (DATE) WRITE ( OUTPT, 99993 ) ' STARTING TEST AT ', DATE( 1:10), ' ON ', - DATE(12:41) * C INITIALIZE COUNTS. * ERROR = 0 PDONE = 0 TFNCS = 0 TITERS = 0 FREQ = PFREQ * DO 20 I = 1, TTESTS FVALS(I) = ZERO FCNTS(I) = 0 ICNTS(I) = 0 20 CONTINUE * C---- ASK FOR CHANGES TO CONTROL PARAMETERS. EOF SUFFICIENT IF C NONE REQUIRED. * CALL BBRVAL ( TRMOUT, TRMINP ) * C REDEFINE THE OUTPUT UNIT BY GETTING THE CURRENT VALUES C FROM BBVALS AND RESETTING IT BY CALLING BBSVAL. THIS MAKES C SURE *ALL* OUTPUT GOES TO UNIT OUTPT. THIS IS GENERALLY C NOT NECESSARY. OUTPUT IS SENT TO A DEFAULT VALUE. * UNIT = OUTPT 22 CALL BBVALS ( INTS, LOGS, REALS ) INTS(XPTRCU) = UNIT INTS(XLTRCU) = UNIT INTS(XETRCU) = UNIT CALL BBSVAL ( INTS, LOGS, REALS ) * C---- DO MINIMIZATIONS. RUN EACH OF THE TEST TYPES. * FROM = 0 TO = NPROBS CONTRL = 0 * DO 9000 M = 1,TESTS * C WRITE TITLE, UNLESS NO OUTPUT REQUESTED. * IF ( FREQ .NE. 0 ) WRITE ( UNIT, 99999 ) M, TITLE(M) * C HERE WE HAVE A CHANCE TO CHOOSE A SUBSET OF THE PROBLEMS C TO TEST. * 50 IF ( CONTRL .NE. -3 ) THEN CONTRL = -3 WRITE(TRMOUT,*) ' CONTROL: 0 QUIT' WRITE(TRMOUT,*) ' -1 SKIP TO NEXT SET,' WRITE(TRMOUT,*) ' -2 FINISH THIS SET' WRITE(TRMOUT,*) ' -3 (OR EOF) FINISH FULL RUN' WRITE(TRMOUT,*) ' N > 0 DO PROBLEM #N' READ(TRMINP,'(BN,I2)', END=59 ) CONTRL ENDIF * 59 IF ( CONTRL .GT. 0 ) THEN FROM = CONTRL TO = CONTRL ELSE IF ( CONTRL .EQ. 0 ) THEN GOTO 10000 ELSE IF ( CONTRL .EQ. -1 ) THEN FROM = 0 TO = NPROBS GOTO 8500 ELSE IF ( CONTRL .EQ. -2 ) THEN FROM = MOD(TO,NPROBS)+1 TO = NPROBS ELSE IF ( CONTRL .EQ. -3 ) THEN FROM = MOD(TO,NPROBS)+1 TO = NPROBS ENDIF * C START TIMING. * CALL ZZSECS(TIME) ACCTIM = ACCTIM - TIME * C REPEAT FOR EACH TEST FUNCTION SELECTED. * DO 6000 I = FROM,TO * PDONE = PDONE + 1 IF (PDONE .GT. TTESTS) THEN WRITE ( UNIT, * ) ' TOO MANY TESTS: STOPPING.' GOTO 90000 ENDIF * IF ( FREQ .NE. 0 ) WRITE ( UNIT, 99994 ) I * C ---SET FUNCTION NUMBER IN ZZFNC AND SET FUNCTION ARGUMENTS. C THIS ILLUSTRATES HOW TO DEFINE THE AMOUNT OF EXTRA C STORAGE AVAILABLE. IT IS ONLY NEEDED FOR TEST 7. * IF ( I .EQ. 7 ) THEN CALL ZZFSET ( IFNC(I), EXTRA ) ELSE CALL ZZFSET ( IFNC(I), 1 ) ENDIF * FARG(1) = RPAR1(I) FARG(2) = RPAR2(I) * CALL ZZFPAR ( FARG ) * C ---SET DIMENSION. * N = DIM(I) * C ---SET STARTING POINT. * * GOTO ( 100,200,300,400,500,600,700,800,900,1000) I * 100 X(1) = ONE X(2) = ONE X(3) = ONE * GOTO 5000 * 200 X(1) = ONE X(2) = TWO X(3) = ONE X(4) = ONE X(5) = ONE X(6) = ONE * GOTO 5000 * 300 X(1) = ZERO X(2) = TEN X(3) = R20 * GOTO 5000 * 400 X(1) = ONE X(2) = TWO X(3) = TWO X(4) = TWO * GOTO 5000 * 500 X(1) = ONE X(2) = TWO X(3) = ZERO * GOTO 5000 * 600 DO 650 ID = 1,N X(ID) = ID 650 CONTINUE * GOTO 5000 * 700 DO 750 ID = 1,N X(ID) = HALF 750 CONTINUE * GOTO 5000 * 800 DO 850 ID = 1,N/4 X(4*ID-3) = THREE X(4*ID-2) = - ONE X(4*ID-1) = ZERO X(4*ID ) = ONE 850 CONTINUE * GOTO 5000 * 900 X(1) = -R1P2 X(2) = ONE * GOTO 5000 * 1000 X(1) = HALF X(2) = HALF X(3) = HALF * GOTO 5000 * C ---SET UP CALLS TO MINIMIZE. TESTS 5 AND 6 CALL C BBLNIR DIRECTLY. THE OTHERS CALL BBVSCG. * 5000 GOTO ( 5100, 5200, 5300, 5400, 5500, 5600, 5425 ) M * C TEST 1 THE SIMPLEST CALL. 5100 DERVMD = ANAL STATUS = NORMAL GOTO 5450 * C TEST 2 USING REVERSE COMMUNICATION. 5200 DERVMD = DIFF STATUS = RCSTRT * C MUST INITIALIZE BEFORE CALL TO ZZEVAL. CALL BBDFLT ( FREQ, MAX ) CASE = DOFG CALL ZZEVAL ( ZZFNS, N, X, FX, G, CASE, IW, RW, DW ) * GOTO 5450 * C TEST 3 HERE WE SEE HOW TO REDEFINE THE METHOD OF COMPUTING C DERIVATIVES. FOR CONVENIENCE, A SET OF NAMED INTEGER C INDICES IS PROVIDED FOR ACCESSING THE APPROPRIATE C ENTRIES OF EACH ARRAY. THESE ARE DOCUMENTED IN BBVALS. * 5300 CONTINUE * 5333 DERVMD = DIFF CALL BBVALS ( INTS, LOGS, REALS ) INTS(XDRVMD) = DERVMD CALL BBSVAL ( INTS, LOGS, REALS ) STATUS = NORMAL * GOTO 5450 * C TEST 4 TEST THE DERIVATIVE CALCULATIONS. 5400 DERVMD = TEST CALL BBVALS ( INTS, LOGS, REALS ) INTS(XDRVMD) = DERVMD CALL BBSVAL ( INTS, LOGS, REALS ) STATUS = NORMAL * GOTO 5450 * C TEST 7 HERE WE USE THE SAME TECHNIQUE TO RESET C THE MINIMIZATION METHOD, THE UPDATE C STRATEGY AND THE DERIVATIVE MODE. THIS C TESTS NOCEDAL'S UPDATE STRATEGY. 5425 DERVMD = ANAL * CALL BBVALS ( INTS, LOGS, REALS ) INTS(XMETH ) = 2 INTS(XUPDTT) = 2 INTS(XDRVMD) = DERVMD CALL BBSVAL ( INTS, LOGS, REALS ) STATUS = NORMAL * GOTO 5450 * 5450 CONTINUE * ITERS = FREQ FUNCS = MAX ACCT = ACC * 5460 CALL BBVSCG ( ZZFNS, N, X, FX, G, ACCT, STATUS, - ITERS, FUNCS, WORK, LWORK ) * C CHECK FOR REVERSE COMMUNICATION TEST IF ( M .EQ. 2 .AND. STATUS .EQ. RCFG ) THEN * C RE-EVALUATE F AND G. CASE = DOFG CALL ZZEVAL ( ZZFNS, N, X, FX, G, CASE, IW, RW, DW ) * C AND RE-ENTER BBVSCG. STATUS = RCRPT * GOTO 5460 * ELSE IF ( M .EQ. 4 ) THEN C GET TESTING INFO. CALL ZZECHK ( DERR, AVERR, DCOMP, DINDX ) * DERERR(I) = DERR AVERRS(I) = AVERR COMPNT(I) = DCOMP INDX (I) = DINDX * ENDIF * GOTO 5900 * C TEST 5 AGAIN WE SEE HOW TO REDEFINE THE METHOD OF COMPUTING C DERIVATIVES. FOR CONVENIENCE, A SET OF NAMED INTEGER C INDICES IS PROVIDED FOR ACCESSING THE APPROPRIATE C ENTRIES OF EACH ARRAY. THESE ARE DOCUMENTED IN BBVALS. C HERE WE ARE CALLING BBLNIR DIRECTLY. * 5500 DERVMD = ANAL CALL BBVALS ( INTS, LOGS, REALS ) INTS(XDRVMD) = DERVMD CALL BBSVAL ( INTS, LOGS, REALS ) STATUS = NORMAL C REDEFINE THE ALGORITHM STRATEGY. METH = 2 * GOTO 5650 * C TEST 6 LIKE TEST 5, BUT WITH REVERSE COMMUNICATION AND C A DIFFERENT METHOD. 5600 DERVMD = ANAL STATUS = RCSTRT METH = -2 * GOTO 5650 * C DIRECT CALL TO BBLNIR. FIRST GET CURRENT SETTINGS. 5650 CALL BBVALS ( INTS, LOGS, REALS ) * C THEN INITIALIZE ZZEVAL. CALL ZZESET ( LOGS(XTRF), LOGS(XTRG), LOGS(XTRTST), - INTS(XETRCU) ) CALL ZZESRT ( INTS(XSCALE), DERVMD, MAX ) C THEN INITIALIZE ZZPRNT. CALL ZZP1ST ( INTS(XPTRCU), LOGS(XGRAD), LOGS(XPOINT), - FREQ ) CALL ZZP2ST ( INTS(XPTRCU), LOGS(XGRAD), LOGS(XPOINT), 0 ) * C THEN INITIALIZE ZZTERM. QUITS = 'FFFF' IF ( LOGS(XTGRAD) ) QUITS(1:1) = 'T' IF ( LOGS(XTSTEP) ) QUITS(2:2) = 'T' IF ( LOGS(XTSHXG) ) QUITS(3:3) = 'T' IF ( LOGS(XTFUNC) ) QUITS(4:4) = 'T' CALL ZZTSET (INTS(XNORM), QUITS, LOGS(XTTRCE), INTS(XTTRCU)) * C INITIALIZE BBLNIR THROUGH ENTRY POINT. HERE ALL THE C VALUES ARE TAKEN FROM THOSE STORED IN BBVALS. IN C MOST APPLICATIONS, VALUES WOULD BE DIRECTLY INPUT BY C THE USER FOR THOSE VALUES HE WISHED TO CHANGE. CALL BBLSET ( METH, 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) ) * C DEFINE THE WORKING ARRAY SIZES. ID = 1 IX = ID + N IG = IX + N IH = IG + N * C INITIAL FUNC/GRAD VALUES FOR REVERSE COMMUNICATION. IF ( STATUS .EQ. RCSTRT ) THEN CASE = DOFG CALL ZZEVAL ( ZZFNS,N,X,FX, G, CASE, IW, RW, DW ) ENDIF * 5690 ACCT = ACC CALL BBLNIR(ZZFNS, N, X, FX, DECRF, G, ACCT, STATUS, ZZINNR, - WORK(ID), WORK(IX), WORK(IG), WORK(IH), LWORK-3*N, - IW, RW, DW ) * C CHECK FOR REVERSE COMMUNICATION TEST IF ( M .EQ. 6 .AND. STATUS .EQ. RCRPT ) THEN * C RE-EVALUATE F AND G. CASE = DOFG CALL ZZEVAL( ZZFNS, N, X, FX, G, CASE, IW, RW, DW ) * C AND RE-ENTER BBVSCG. STATUS = RCRPT GOTO 5690 * ENDIF * C ALL TESTS: ADD NUMBER OF ERRORS. * 5900 IF ( STATUS .NE. DONE ) THEN ERROR = ERROR + 1 ENDIF * C GET STATISTICAL COUNTS. CALL ZZEGET( FNCT, GRCT, ACCTIM ) CALL ZZPGET( ACCTIM, ITCT ) * FVALS(PDONE) = FX FCNTS(PDONE) = FNCT ICNTS(PDONE) = ITCT * TFNCS = TFNCS + FNCT TITERS = TITERS + ITCT * IF ( FREQ .NE. 0 ) WRITE ( UNIT, 99997 ) STATUS * 6000 CONTINUE CALL ZZSECS(TIME) ACCTIM = ACCTIM + TIME * 8000 IF ( M .EQ. 4 ) THEN IF ( FREQ .NE. 0 ) WRITE ( UNIT, 99998 ) - (DERERR(I),COMPNT(I),INDX(I),AVERRS(I),I = 1,NPROBS) ENDIF * 8500 IF ( TO .NE. NPROBS ) GOTO 50 * 9000 CONTINUE * 10000 WRITE ( UNIT, 99991 ) WRITE ( UNIT, 99992 ) (I,ICNTS(I),FVALS(I),FCNTS(I),I=1,PDONE) * CALL ZZSECS (TIME) WRITE ( UNIT, 99995 ) ACCTIM, TIME WRITE ( UNIT, 99996 ) PDONE, ERROR, TFNCS, TITERS WRITE ( TRMOUT, * ) ' ' WRITE ( TRMOUT, * ) ' ' WRITE ( TRMOUT, * ) ' ' WRITE ( TRMOUT, 99995 ) ACCTIM, TIME * CALL ZZDTTM (DATE) WRITE( TRMOUT, 99993 ) ' TEST ENDED AT ', DATE(1:10), ' ON ', - DATE(12:41) WRITE( UNIT, 99993 ) ' TEST ENDED AT ', DATE(1:10), ' ON ', - DATE(12:41) * C=============================== E X I T =============================== * 90000 STOP * C============================ F O R M A T S ============================ * 99991 FORMAT (// ' RN ITS FUNCT. VALUE FNS |', - ' RN ITS FUNCT. VALUE FNS |', - ' RN ITS FUNCT. VALUE FNS'/ - ' ------------------------|', - '-------------------------|', - '------------------------') * 99992 FORMAT ( (2(I3,I4,1X,E12.6,I4,' |'), (I3,I4,1X,E12.6,I4) )) * 99993 FORMAT ( 4A // ) * 99994 FORMAT ( /' FUNCTION #', I2 / ) * 99995 FORMAT (/' TIME USED WAS ', F12.3, ' SECONDS WITHOUT PROMPTS;'/ - ' ', F12.3, ' TOTAL.' ) * 99996 FORMAT ( // ' *****TEST FINISHED**** PROBLEMS DONE ',I3, - '; NUMBER OF ERRORS IS ',I2,'.' / - ' TOTAL FUNCTION CALLS = ',I4, - ' TOTAL ITERATIONS = ', I4 // ) * 99997 FORMAT ( /' ************* RUN COMPLETE, STATUS = ', I3, '.'/ ) * 99998 FORMAT ( //' TESTING MODE DERIVATIVE ESTIMATION ERRORS' // - ' MAX ERROR COMPONENT ITERATE AV. DECIMALS ' // - 10 ( E10.2, I7, 7X, I5, F9.2 /) ) * 99999 FORMAT ( '1 BEGINNING RUN #', I1, ':', A ) * C================================ E N D ================================ * END SUBROUTINE ZZDATE (CHDATE) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER *(*) CHDATE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM ROUTINE FOR DATE. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR SUN4 C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 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 C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZDATE C C======================== S U B R O U T I N E S ======================== C C SYSTEM DATE ROUTINE. C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * 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 ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C 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---- INITIALIZE CHDATE * CHDATE = '( + + )' * CALL FDATE(UNXDAT) * CHDATE(2:3) = UNXDAT(23:24) * CHDATE(8:9) = UNXDAT(9:10) * TEMP = UNXDAT(5:7) CALL ZZLCUC(TEMP) * 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZDTTM ( CHDATE ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER *(*) CHDATE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: NONE C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 1, 1985 A. BUCKLEY 1.0 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZDTTM C 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 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 A R A T I O N S ================= * 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 ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== * 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 ========================== * 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 ============================ C C THERE ARE NO FORMATS USED. C C================================ E N D ================================ * END SUBROUTINE ZZFNS ( IFG, N, X, F, G, IW, DUMMY, WORK ) C!!!! SUBROUTINE ZZFNS ( IFG, N, X, F, G, IW, WORK, DUMMY ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * INTEGER N, IFG, IW(*) * DOUBLE PRECISION F, X(N), G(N), WORK(*) C!!!! REAL F, X(N), G(N), WORK(*) * C *** NOTE THAT THESE ARE **DELIBERATELY** OPPOSITE TO OTHER PAIRS. REAL DUMMY(*) C!!!! DOUBLE PRECISION DUMMY(*) * C============================= S T A T U S ============================= 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 D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 1, 1985 A. BUCKLEY 1.0 C C======================== D E S C R I P T I O N ======================== C C THIS TEST FUNCTION EVALUATES ONE OF THE STANDARD TEST C FUNCTIONS PROVIDED WITH TESTPACK. THE ARGUMENTS IN THE CALLING C SEQUENCE HAVE PRECISELY THE SAME MEANING AS IN THE ROUTINE ZZEVAL. C C THE TEST FUNCTION TO USE IS SELECTED BY CALLING THE ENTRY C POINT ZZFSET ( FUNCNO ). THE VALUE OF THE INTEGER, FUNCNO, C SPECIFIES WHICH OF THE TEST FUNCTIONS IS TO BE USED; THE FUNCTION C IS CHOSEN USING A COMPUTED 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 FIVE ARGUMENTS ARE PROVIDED. IF THE MAXIMUM NUMBER OF C ARGUMENTS IS TO BE INCREASED, THE PARAMETER FNO SHOULD BE C INCREASED. IT MUST AGREE WITH THE VALUE USED IN ZZTP. C C ALL FUNCTION ARGUMENTS ARE REAL. INTEGER VALUES MAY BE PASSED C BY ASSIGNING THE INTEGER VALUE TO A REAL ARGUMENT AND THEN USING C 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======================= 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 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 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 ========================= * DOUBLE PRECISION ZERO, ONE, TWO, THREE C!!!! REAL ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) * DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN C!!!! REAL FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) * DOUBLE PRECISION EIGHT, NINE, TEN C!!!! REAL EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 8D0, TEN = 10D0 ) * DOUBLE PRECISION TENTH, FIFTH, HALF C!!!! REAL TENTH, FIFTH, HALF PARAMETER ( TENTH = .1D0, FIFTH = .2D0, HALF = .5D0 ) * DOUBLE PRECISION RPT9, RPT8, RD29 C!!!! REAL RPT9, RPT8, RD29 PARAMETER ( RPT9 = .9D0, RPT8 = .8D0, RD29 = 1D0/29D0 ) DOUBLE PRECISION R11, R12, R13, R14 C!!!! REAL R11, R12, R13, R14 PARAMETER ( R11 = 11D0, R12 = 12D0, R13 = 13D0,R14 = 14D0) * DOUBLE PRECISION R15, R16, R17, R18 C!!!! REAL R15, R16, R17, R18 PARAMETER ( R15 = 15D0, R16 = 16D0, R17 = 17D0,R18 = 18D0) * DOUBLE PRECISION R19, R20, R25, R29 C!!!! REAL R19, R20, R25, R29 PARAMETER ( R19 = 19D0, R20 = 20D0, R25 = 25D0,R29 = 29D0) * DOUBLE PRECISION R32, R36, R40, R42 C!!!! REAL R32, R36, R40, R42 PARAMETER ( R32 = 32D0, R36 = 36D0, R40 = 40D0,R42 = 42D0) * DOUBLE PRECISION R45, R49 C!!!! REAL R45, R49 PARAMETER ( R45 = 45D0, R49 = 49D0 ) * DOUBLE PRECISION R50, R56, R84, R90 C!!!! REAL R50, R56, R84, R90 PARAMETER ( R50 = 50D0, R56 = 56D0, R84 = 84D0,R90 = 90D0) * DOUBLE PRECISION R100, R180, R200 C!!!! REAL R100, R180, R200 PARAMETER ( R100 = 100D0, R180 = 180D0, R200 = 200D0 ) * DOUBLE PRECISION R256, R360, R400 C!!!! REAL R256, R360, R400 PARAMETER ( R256 = 256D0, R360 = 360D0, R400 = 400D0 ) * DOUBLE PRECISION R600, R681, R991 C!!!! REAL R600, R681, R991 PARAMETER ( R600 = 600D0, R681 = 681D0, R991 = 991D0 ) * DOUBLE PRECISION R1162, R2324 C!!!! REAL R1162, R2324 PARAMETER ( R1162 = 1162D0, R2324 = 2324D0 ) * DOUBLE PRECISION R10000, R40000 C!!!! REAL R10000, R40000 PARAMETER ( R10000 = 10000D0, R40000 = 40000D0 ) DOUBLE PRECISION R1PD6, R2PDM6 C!!!! REAL R1PD6, R2PDM6 PARAMETER ( R1PD6 = 1D6, R2PDM6 = 2D-6 ) * DOUBLE PRECISION RP04, RP01, R1PZ1 C!!!! REAL RP04, RP01, R1PZ1 PARAMETER ( RP04 = 4D-2, RP01 = .01D0, R1PZ1 = 1.0001D0 ) * DOUBLE PRECISION R1P2 C!!!! REAL R1P2 PARAMETER ( R1P2 = 1.2D0 ) * DOUBLE PRECISION R1P5, R2P5, R2P625 C!!!! REAL R1P5, R2P5, R2P625 PARAMETER ( R1P5 = 1.5D0, R2P5 = 2.5D0, R2P625 = 2.625D0 ) * DOUBLE PRECISION R10P1, R19P8, R20P2 C!!!! REAL R10P1, R19P8, R20P2 PARAMETER ( R10P1 = 10.1D0,R19P8 = 19.8D0,R20P2 = 20.2D0 ) * DOUBLE PRECISION R2D3, R4D3, R7D3 C!!!! REAL R2D3, R4D3, R7D3 PARAMETER ( R2D3 = 2D0/3D0,R4D3 = 4D0/3D0,R7D3 = 7D0/3D0 ) * DOUBLE PRECISION R2P25 C!!!! REAL R2P25 PARAMETER ( R2P25 = 2.25D0 ) * INTEGER ALPHA, BETA, GAMMA PARAMETER ( ALPHA = 5, BETA = 14, GAMMA = 3 ) * * INTEGER JUSTF, BOTH, JUSTG, NOOP PARAMETER ( JUSTF = 1, BOTH = 0, JUSTG = -1, NOOP = 2 ) * 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 A R A T I O N S ================= * INTEGER OK, ABORT, LIMIT, NOF, NOG, NOFG INTEGER SOK, SABORT, SLIMIT, SNOF, SNOG, SNOFG * INTEGER FUNCNO, SIZE, SDOF, SDOFG, SDOG, SNOOP INTEGER SETFNC, SETSIZ, F1 * INTEGER I, J, K, JLO, JHI, IEG, IY INTEGER I1, I2, IC, IS, IV, IA, IB, M, L INTEGER NPTS, NEQ, IP, IQ, NSYS, IMESH, IH, TT INTEGER IB0, IB1, IDB0, IDB1, ILAST, BACK, RET, P * INTEGER ALPHA2, NOVER2, DOF, DOG, DOFG, NEITHR * LOGICAL EVEN, GFIRST, FIRST, ERROR, FONLY, GONLY LOGICAL DONE, PROB13 * DOUBLE PRECISION FARG ( FNO ), SARG ( FNO ), ZZMPAR, HUGE C!!!! REAL FARG ( FNO ), SARG ( FNO ), ZZMPAR, HUGE * * C--------- VARIABLES FOR THE TEST FUNCTIONS. * * DOUBLE PRECISION X1, X2, X3, X4, X5, X6 C!!!! REAL X1, X2, X3, X4, X5, X6 * DOUBLE PRECISION X7, X8, X9, X10, X11 C!!!! REAL X7, X8, X9, X10, X11 * DOUBLE PRECISION G1, G2, G3, G4, G5, G6 C!!!! REAL G1, G2, G3, G4, G5, G6 * DOUBLE PRECISION G7, G8, G9, G10, G11 C!!!! REAL G7, G8, G9, G10, G11 * DOUBLE PRECISION W1, W2, W3, W4, W5, W6 C!!!! REAL W1, W2, W3, W4, W5, W6 * DOUBLE PRECISION W7, W8, W9, W10, W11, W12 C!!!! REAL W7, W8, W9, W10, W11, W12 * DOUBLE PRECISION R, S, T, R1, BIGGST, SMLLST C!!!! REAL R, S, T, R1, BIGGST, SMLLST * DOUBLE PRECISION R2, R3, RI, RK , SK, TI C!!!! REAL R2, R3, RI, RK , SK, TI * DOUBLE PRECISION XI, XK, YI, PI, U, SUM C!!!! REAL XI, XK, YI, PI, U, SUM * DOUBLE PRECISION XP1, XM1, R2P, RD, TPI, TPIS C!!!! REAL XP1, XM1, R2P, RD, TPI, TPIS * DOUBLE PRECISION HJ, HJJ, DELTX, SINX C!!!! REAL HJ, HJJ, DELTX, SINX * DOUBLE PRECISION U1, U2, RF1, RF2, RF3, RF4, DH, DHH C!!!! REAL U1, U2, RF1, RF2, RF3, RF4, DH, DHH * * C--------- DATA ARRAYS FOR TESTPACK FUNCTIONS * * DOUBLE PRECISION AL (50), ARGASY (15), BARD7Y (15) C!!!! REAL AL (50), ARGASY (15), BARD7Y (15) * DOUBLE PRECISION HIM32A (7), HIM32B (7) C!!!! REAL HIM32A (7), HIM32B (7) * DOUBLE PRECISION KOWOSU (11), KOWOSY (11) C!!!! REAL KOWOSU (11), KOWOSY (11) * DOUBLE PRECISION ORBETA (33), OD (33), MEY (16) C!!!! REAL ORBETA (33), OD (33), MEY (16) * DOUBLE PRECISION OSB1Y (33), OSB2Y (65) C!!!! REAL OSB1Y (33), OSB2Y (65) * INTEGER A (50), B (56) * C=============================== S A V E =============================== * SAVE FUNCNO, FARG, SIZE, GFIRST, FIRST, PI, R2P, BIGGST, SMLLST SAVE NPTS, NEQ, IP, IQ, NSYS, IA, IB, DH, DHH, HUGE SAVE IMESH, IH, IB0, IB1, IDB0, IDB1, PROB13, DONE, M SAVE DOF, DOG, DOFG, NEITHR SAVE OK, ABORT, LIMIT, NOF, NOG, NOFG * C--------- SAVE DATA ARRAYS FOR THE TEST FUNCTIONS. * * SAVE ARGASY, BARD7Y, 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 ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== * DATA FUNCNO /1/, SIZE /1/ * DATA FARG / FNO * 1.D0 / * DATA FIRST/.TRUE./, GFIRST/.TRUE./ * DATA DOF/JUSTF/, DOFG/ BOTH/, DOG/JUSTG/, NEITHR/NOOP/ DATA OK/ COK/, ABORT/CABORT/, LIMIT/CLIMIT/ DATA NOF/ CNOF/, NOG/ CNOG/, NOFG/ CNOFG/ * C--------- DATA FOR TESTPACK 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 TESTPACK 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--------- DATA FOR TESTPACK FUNCTION 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 TESTPACK 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 TESTPACK 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 TESTPACK 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 TESTPACK 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--------- DATA FOR TESTPACK 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 TESTPACK 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--------- FUNCTION DEFINITION * RD (I) = DBLE (I) C!!!! RD (I) = REAL (I) * 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) ENDIF * C--------- SET LOGICAL FLAGS AND SELECT FUNCTION. * FONLY = IFG .EQ. DOF GONLY = IFG .EQ. DOG RET = OK * GOTO( 51, 99, 50, 99, 99, 99, 99, 99, 99, - 99, 8, 99, 99, 99, 99, 10, 99, 99, 99, - 99, 99, 99, 99, 52, 22, 5, 20, 99, 99, - 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, - 44, 45, 99, 99, 99, 99, 99, 99, 99, 99, - 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, - 99, 99, 99, 99, 99, 99, 99, 99 ) - FUNCNO * C THESE DUMMY GO TO'S JUST MAKE POSSIBLE FUTURE CHANGES C MORE CONVENIENT. THE TEST FUNCTIONS APPEAR HERE IN C ALPHABETICAL ORDER. * C BARD70 5 GOTO 3600 * C BIGGS6 8 GOTO 2100 * C BOX663 10 GOTO 2600 * C CRGLVY 20 GOTO 3700 * C ENGVL2 22 GOTO 3500 * C PENAL1 44 GOTO 5000 * C PENAL2 45 GOTO 5100 * C PWSING 50 GOTO 1300 * C ROSENB 51 GOTO 1100 * C SCHMVT 52 GOTO 3400 * 99 GOTO 10000 * * C>>>>> NOTE : IF WE SUPPOSE THAT EACH OF THESE 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>>>>> ( CASE, 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. * * C--------- TESTPACK FUNCTION ROSENB * * 1100 X1 = X(1) W1 = ONE - X1 W2 = X(2) - X1*X1 * IF ( .NOT. GONLY ) THEN F = R100*W2*W2 + W1*W1 ENDIF * IF ( .NOT. FONLY ) THEN G(1) = -R400*W2*X1 - TWO*W1 G(2) = R200*W2 ENDIF * GOTO 10000 * * * C--------- TESTPACK 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 10000 * * * C--------- TESTPACK FUNCTION BIGGS6 ( N, X, F, G, IFG, NINT(FARG(1))) C--------- NINT(FARG(1)) IS M * * 2100 X1 = X(1) X2 = X(2) X3 = X(3) X4 = X(4) X5 = X(5) X6 = X(6) * IF ( .NOT. GONLY ) THEN F = ZERO ENDIF * IF ( .NOT. FONLY ) THEN G1 = ZERO G2 = ZERO G3 = ZERO G4 = ZERO G5 = ZERO G6 = ZERO ENDIF * DO 2110 I = 1, NINT(FARG(1)) T = RD(I) TI = T/TEN IF ( MAX(-T,-TI*FOUR,-TI*X1,-TI*X2,-TI*X5) .LE. BIGGST ) THEN YI = EXP(-TI) - FIVE * EXP(-T) + THREE*EXP(-FOUR*TI) W3 = EXP(-TI*X1) W4 = EXP(-TI*X2) W5 = EXP(-TI*X5) ELSE RET = NOFG GOTO 90000 ENDIF RI = X3*W3 - X4*W4 + X6*W5 - YI * IF ( .NOT. GONLY ) THEN F = F + RI*RI ENDIF * IF ( .NOT. FONLY ) THEN W1 = TI*RI G1 = G1 - W3*W1 G2 = G2 + W4*W1 G3 = G3 + W3*RI G4 = G4 - W4*RI G5 = G5 - W5*W1 G6 = G6 + W5*RI ENDIF * 2110 CONTINUE * IF ( .NOT. FONLY ) THEN G(1) = TWO*X3*G1 G(2) = TWO*X4*G2 G(3) = TWO * G3 G(4) = TWO * G4 G(5) = TWO*X6*G5 G(6) = TWO * G6 ENDIF * GOTO 10000 * * * C--------- TESTPACK 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 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 RI = W3 - W4 - W5*X(3) * IF ( .NOT. GONLY ) THEN IF ( ABS(RI) .LE. SQRT(HUGE-MAX(F,ZERO)) ) THEN F = F + RI*RI ELSE RET = NOFG GOTO 90000 ENDIF ENDIF * IF ( .NOT. FONLY ) THEN W2 = TI*RI G1 = G1 - W3*W2 G2 = G2 + W4*W2 G3 = G3 - W5*RI ENDIF * 2610 CONTINUE * IF ( .NOT. FONLY ) THEN G(1) = TWO * G1 G(2) = TWO * G2 G(3) = TWO * G3 ENDIF * GOTO 10000 * * * * C--------- TESTPACK FUNCTION SCHMVT * * 3400 IF ( FIRST ) THEN FIRST = .FALSE. PI = ACOS(-ONE) ENDIF * X1 = X(1) X2 = X(2) X3 = X(3) * W1 = X1 - X2 W2 = X1 + X3 * W3 = ONE + W1*W1 W4 = (PI*X2 + X3) / TWO W5 = (W2/X2) - TWO IF ( -W5**2 .LE. BIGGST ) THEN W6 = EXP(-W5*W5) ELSE RET = NOFG GOTO 90000 ENDIF * IF ( .NOT. GONLY ) THEN F = - ((ONE/W3) + SIN(W4) + W6 ) ENDIF * IF ( .NOT. FONLY ) THEN * W3 = TWO*W1/(W3*W3) W4 = COS(W4)/TWO W6 = TWO*W5*W6/X2 * G(1) = W3 + W6 G(2) = -W3 - PI*W4 - W6*W2/X2 G(3) = -W4 + W6 * ENDIF * GOTO 10000 * C--------- TESTPACK 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 10000 * * C--------- TESTPACK 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 10000 * C--------- TESTPACK FUNCTION CRGLVY * * 3700 X1 = X(1) X2 = X(2) X3 = X(3) X4 = X(4) * W1 = X2 - X3 W2 = X3 - X4 W3 = X4 - ONE * IF ( X1 .LE. BIGGST ) THEN W4 = EXP(X1) ELSE RET = NOFG GOTO 90000 ENDIF W5 = W4 - X2 W6 = TAN(W2) * IF ( .NOT. GONLY ) THEN F = W5**4 + R100*W1**6 + W6**4 + X1**8 + W3*W3 ENDIF * IF ( .NOT. FONLY ) THEN * W2 = COS(W2) W5 = FOUR * W5**3 W1 = R600 * W1**5 W6 = FOUR * W6**3 / (W2*W2) * G(1) = W4*W5 + EIGHT*X1**7 G(2) = -W5 + W1 G(3) = -W1 + W6 G(4) = -W6 + TWO*W3 ENDIF * GOTO 10000 * * * * C--------- TESTPACK 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 10000 * * C--------- TESTPACK 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 10000 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 10000 * * 10000 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 ) * OK = SOK ABORT = SABORT LIMIT = SLIMIT NOF = SNOF NOG = SNOG NOFG = SNOFG * RETURN * C>>>>>>>>>>>>>>>>>>>>>>>>>> E N T R Y ZZFSET <<<<<<<<<<<<<<<<<<<<<<<<<< * ENTRY ZZFSET ( SETFNC, SETSIZ ) * FUNCNO = SETFNC SIZE = SETSIZ FIRST = .TRUE. * 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 IFG = RET GFIRST = .FALSE. * RETURN * C============================ F O R M A T S ============================ C C THERE ARE NO FORMATS USED. C C================================ E N D ================================ * END SUBROUTINE ZZLCUC ( LINE ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER * (*) LINE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: THE ACTIONS DEPEND UPON THE UNDERLYING C CHARACTER SET. MOST VERSIONS ASSUME AN ASCII C OR EBCDIC CHARACTER SET WITH EACH CHARACTER C OCCUPYING ONE BYTE. THE CYBER VERSION ASSUMES 6- C 12 BIT CODES FOR UPPER/LOWER CASE. ALL THAT HAP- C PENS IS THAT THE ESCAPE CODES @ AND ^ ARE REMOVED. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR SUN4 C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C C LINE CONTAINS THE CHARACTERS TO BE CONVERTED TO UPPER CASE. C NOTE THAT ON SOME SYSTEMS (NOTABLY THE OLD ARCHITECTURE C CDC CYBERS), UPPER AND LOWER CASE CHARACTERS HAVE DIFFERENT C LENGTHS, SO THE LINE LENGTH MAY BE CHANGED BY THIS ROUTINE. C C THE ROUTINE ASSUMES THAT THE VALUE C C ICHAR ( UPPER-CASE OF LETTER ) - ICHAR ( LOWER-CASE LETTER ) C C IS FIXED, I.E. IT IS THE SAME FOR EACH LETTER =A,B,...,Z. C C THIS SHOULD BE TRUE ON MOST EBCDIC OR ASCII SYSTEMS. C C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZLCUC C C======================== S U B R O U T I N E S ======================== C C INDEX ...GENERIC C ZZLENG ...NON-BLANK LENGTH OF A LINE C C CHAR, ICHAR ...INTRINSIC C C========================= P A R A M E T E R S ========================= * CHARACTER * (*) LCALPH PARAMETER ( LCALPH = 'abcdefghijklmnopqrstuvwxyz' ) * C================= L O C A L D E C L A R A T I O N S ================= * LOGICAL FIRST * CHARACTER CH * INTEGER I, ZZLENG, WLEN, SHIFT * C=============================== S A V E =============================== SAVE FIRST, SHIFT * C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== DATA FIRST/.TRUE./ * C========================== E X E C U T I O N ========================== * WLEN = ZZLENG(LINE) * IF ( FIRST ) THEN SHIFT = ICHAR( 'A' ) - ICHAR( 'a' ) FIRST = .FALSE. ENDIF * DO 100 I = 1, WLEN * CH = LINE( I:I ) * IF ( INDEX( LCALPH, CH ) .NE. 0 ) THEN * LINE( I:I ) = CHAR( ICHAR( CH ) + SHIFT ) * ENDIF * 100 CONTINUE * GO TO 90000 * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END INTEGER FUNCTION ZZLENG (LINE) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER*(*) LINE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: NONE C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 1, 1985 A. BUCKLEY 1.0 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZLENG C C======================== S U B R O U T I N E S ======================== C C LEN ...INTRINSIC C C========================= P A R A M E T E R S ========================= * CHARACTER*(*) BLANK PARAMETER ( BLANK = ' ' ) * C================= L O C A L D E C L A R A T I O N S ================= * INTEGER I * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA VALUES. C 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 ============================ C C THERE ARE NO FORMATS USED. C C================================ E N D ================================ * END SUBROUTINE ZZSHFT (STRING, FROM, TO, NUMBER ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * INTEGER FROM, TO, NUMBER * CHARACTER *(*) STRING * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: NONE C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 1, 1985 A. BUCKLEY 1.0 C C======================== D E S C R I P T I O N ======================== C 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 C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZSHFT C C======================== S U B R O U T I N E S ======================== C C LEN MIN MAX ...INTRINSIC C C========================= P A R A M E T E R S ========================= * CHARACTER *(*) BLANK PARAMETER ( BLANK = ' ' ) * C================= L O C A L D E C L A R A T I O N S ================= * INTEGER N, SHIFT, INCR, I, IS, IE, IBS, ETO, EFROM, K, SLEN * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA VALUES. C 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 STRING(K:K) = STRING(I:I) 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 ============================ C C THERE ARE NO FORMATS USED. C C================================ E N D ================================ * END SUBROUTINE ZZTIME ( CHTIME ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER *(*) CHTIME * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR TIME OF DAY. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR SUN4 C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZTIME C C======================== S U B R O U T I N E S ======================== C C SYSTEM ROUTINE TO GET TIME OF DAY. C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * CHARACTER * 24 UNXTIM * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA STATEMENTS. C 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZEVAL ( ZZUFNC, N, X, F, G, INDIC, IW, RW, DW ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * EXTERNAL ZZUFNC * INTEGER INDIC, N, IW(*) * DOUBLE PRECISION F, X(N), G(N), ZZUFNC C!!!! REAL F, X(N), G(N) * DOUBLE PRECISION DW(*) REAL RW(*) * C============================= S T A T U S ============================= 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 D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C MAY. 21, 1987 A. BUCKLEY 1.2 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 ZZSCAL. 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, 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 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 ======================= C C ZZEVAL THE NATURAL ENTRY POINT. C C ZZESRT AN ENTRY TO INITIALIZE FOR TESTING EACH FUNCTION. C ZZESET AN ENTRY TO INITIALIZE CONTROL PARAMETERS. C C ZZEDDF AN ENTRY TO REDEFINE CODES FOR DERIVATIVE CALCULATIONS. C ZZEFDF AN ENTRY TO REDEFINE CODES FOR FUNCTION EVALUATIONS. C ZZERDF AN ENTRY TO REDEFINE CODES FOR RETURN CODES. C C ZZEGET AN ENTRY 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 C ZZSECS ...FOR FUNCTION TIMING. C ZZMPAR ...FOR MACHINE PARAMETERS. C ZZUFNC ...THE USER ROUTINE. C ZZSCAL ...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 ========================= * DOUBLE PRECISION ZERO, ONE, TWO, THREE C!!!! REAL ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) * DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN C!!!! REAL FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) * DOUBLE PRECISION EIGHT, NINE, TEN C!!!! REAL EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 8D0, TEN = 10D0 ) DOUBLE PRECISION R11, R12, R13, R14 C!!!! REAL R11, R12, R13, R14 PARAMETER ( R11 = 11D0, R12 = 12D0, R13 = 13D0,R14 = 14D0) * DOUBLE PRECISION R15, R16, R17, R18 C!!!! REAL R15, R16, R17, R18 PARAMETER ( R15 = 15D0, R16 = 16D0, R17 = 17D0,R18 = 18D0) * DOUBLE PRECISION R19, R20, R25, R29 C!!!! REAL R19, R20, R25, R29 PARAMETER ( R19 = 19D0, R20 = 20D0, R25 = 25D0,R29 = 29D0) * DOUBLE PRECISION R32, R36, R40, R42 C!!!! REAL R32, R36, R40, R42 PARAMETER ( R32 = 32D0, R36 = 36D0, R40 = 40D0,R42 = 42D0) * DOUBLE PRECISION R45, R49 C!!!! REAL R45, R49 PARAMETER ( R45 = 45D0, R49 = 49D0 ) * DOUBLE PRECISION R50, R56, R84, R90 C!!!! REAL R50, R56, R84, R90 PARAMETER ( R50 = 50D0, R56 = 56D0, R84 = 84D0,R90 = 90D0) * DOUBLE PRECISION R100, R180, R200 C!!!! REAL R100, R180, R200 PARAMETER ( R100 = 100D0, R180 = 180D0, R200 = 200D0 ) * DOUBLE PRECISION R256, R360, R400 C!!!! REAL R256, R360, R400 PARAMETER ( R256 = 256D0, R360 = 360D0, R400 = 400D0 ) * DOUBLE PRECISION R600, R681, R991 C!!!! REAL R600, R681, R991 PARAMETER ( R600 = 600D0, R681 = 681D0, R991 = 991D0 ) * DOUBLE PRECISION R1162, R2324 C!!!! REAL R1162, R2324 PARAMETER ( R1162 = 1162D0, R2324 = 2324D0 ) * DOUBLE PRECISION R10000, R40000 C!!!! REAL 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 A R A T I O N S ================= * LOGICAL TRF, TRG, FIRST, FONLY, GONLY, VALID, BAD, TRTEST, FCALL * INTEGER I, IFNCT, FSCALE, IGRCT, SDRVMD INTEGER ITRUN, MAXFN, DERVMD INTEGER CASE, CALLS, COUNT, INDEX, GCNT, DCNT * DOUBLE PRECISION FT, FV, FTIME, TT, SCALE, SERR, RH C!!!! REAL FT, FV, FTIME, TT, SCALE, SERR, RH * DOUBLE PRECISION FVAL, FVAL2, ERR, ETA, EPS, H, ZZMPAR, TERR C!!!! REAL FVAL, FVAL2, ERR, ETA, EPS, H, ZZMPAR, TERR * C-----DECLARATIONS FOR ENTRY POINT DUMMY ARGUMENTS. * INTEGER DITRUN, FSCAL, MAXM, FNCT, GRCT 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 * DOUBLE PRECISION TIME, ERROR, AVERR C!!!! REAL TIME, ERROR, AVERR * C=============================== S A V E =============================== * SAVE ITRUN, FSCALE, IFNCT, IGRCT, SERR, DCNT 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 ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C 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-----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. * 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 CASE = INDIC * 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 DETERMINE 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 INDIC = CASE GOTO 90000 ENDIF * IF ( INDIC .NE. DOG ) THEN FT = FVAL ENDIF * C AFTER FIRST CALL, FUNCTION VALUES ONLY. * C-----DO EXTRA CALLS, IF REQUIRED. * 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 INDIC = CASE GOTO 90000 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 INDIC = CASE GOTO 90000 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. * SERR = SERR - LOG10 (TERR) DCNT = DCNT + 1 * IF (TRTEST) WRITE(ITRUN,99994) TERR,-LOG10(TERR) * IF ( TERR .GT. ABS(ERR) ) THEN * INDEX = COUNT GCNT = IGRCT ERR = SIGN (TERR, ERR) ENDIF * ELSE * C FLAG CASE WHERE THERE IS EXCESSIVE CANCELLATION. * ERR = - ABS(ERR) 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 INSTANCES C THIS MAY REQUIRE AN EXTRA CALL TO GET THE FUNCTION C VALUE WHEN INDIC = DOG; THIS WAS DONE IN THE CALLS C ABOVE. * IF ( FSCALE .NE. 0 ) THEN CALL ZZSCAL( 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 DO 5100 I=1,N G(I) = G(I) * SCALE 5100 CONTINUE ENDIF * INDIC = OK * GOTO 90000 * * C>>>>>>>>>>>>>>>>>>>>>>>>>> E N T R Y ZZESRT <<<<<<<<<<<<<<<<<<<<<<<<<< * ENTRY ZZESRT ( FSCAL, DDERV, MAXM ) * FCALL = .TRUE. * FSCALE = FSCAL SDRVMD = DDERV MAXFN = MAXM * 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 ============================ * 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 ================================ * END SUBROUTINE ZZPRNT ( N, X, F, G, NRMG, INCR ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * INTEGER N, INCR * DOUBLE PRECISION F, X(N), G(N), NRMG C!!!! REAL F, X(N), G(N), NRMG * C============================= S T A T U S ============================= 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 D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C MAY 21, 1987 A. BUCKLEY 1.2 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 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 ========================= * DOUBLE PRECISION ZERO, ONE, TWO, THREE C!!!! REAL ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) * DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN C!!!! REAL FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) * DOUBLE PRECISION EIGHT, NINE, TEN C!!!! REAL EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 8D0, TEN = 10D0 ) * C================= L O C A L D E C L A R A T I O N S ================= * INTEGER IFNCT, IGRCT, ITCT INTEGER PRPT1, PLEV1, UNIT1, LSTIT1, LSTUN1 INTEGER PRPT2, PLEV2, UNIT2, LSTIT2, LSTUN2 * LOGICAL GRAD1, LSTGR1, POINT1, LSTPT1 LOGICAL GRAD2, LSTGR2, POINT2, LSTPT2 LOGICAL FORCE, GOT * DOUBLE PRECISION SECS, PRTIME, DTIME C!!!! REAL SECS, PRTIME, DTIME * C-----DECLARATIONS FOR ENTRY POINT DUMMY ARGUMENTS. * LOGICAL DGRAD1, DPINT1 LOGICAL DGRAD2, DPINT2 * INTEGER DPRUN1, DPRNT1 INTEGER DPRUN2, DPRNT2 * INTEGER ITER * DOUBLE PRECISION TIME C!!!! REAL TIME * C=============================== S A V E =============================== * SAVE PRTIME, ITCT * 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 ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== * DATA PLEV1/0/, PLEV2/0/, UNIT1/6/, UNIT2/0/ * 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 * C ------IF PLEV2 > 0 , ALSO PRINT X AND G. * IF ( PLEV2 .GT. 0 ) THEN * IF ( POINT2) THEN WRITE (UNIT2,99988) X ENDIF * IF ( GRAD2 ) THEN WRITE (UNIT2,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 PRTIME = ZERO * RETURN * C>>>>>>>>>>>>>>>>>>>>>>>>>> E N T R Y ZZP2ST <<<<<<<<<<<<<<<<<<<<<<<<<< * ENTRY ZZP2ST ( DPRUN2, DGRAD2, DPINT2, DPRNT2 ) * UNIT2 = DPRUN2 GRAD2 = DGRAD2 POINT2 = DPINT2 PLEV2 = DPRNT2 * 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 ================================ * END SUBROUTINE ZZSCAL ( FT, FV, SCALE, FSCALE, FONLY, GONLY ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * INTEGER FSCALE * LOGICAL FONLY, GONLY * DOUBLE PRECISION FT, FV, SCALE C!!!! REAL FT, FV, SCALE * C============================= S T A T U S ============================= 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 D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C DEC. 15, 1986 A. BUCKLEY 1.0 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 C GONLY - IF TRUE ONLY THE GRADIENT IS EVALUATED. C C-----ON EXIT: C C FV - THE SCALED FUNCTION VALUE. C C SCALE - GRADIENT SCALING FACTOR. C C======================= E N T R Y P O I N T S ======================= C C NONE ARE USED. C C======================== S U B R O U T I N E S ======================== C C SQRT... INTRINSIC C C========================= P A R A M E T E R S ========================= * DOUBLE PRECISION ZERO, ONE, TWO, THREE C!!!! REAL ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) * DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN C!!!! REAL FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) * DOUBLE PRECISION EIGHT, NINE, TEN C!!!! REAL EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 8D0, TEN = 10D0 ) * C================= L O C A L D E C L A R A T I O N S ================= C C THERE ARE NO LOCAL DECLARATIONS. C C=============================== S A V E =============================== C C THERE ARE NO VARIABLES TO BE SAVED. C C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C NO DATA STATEMENTS ARE USED. C 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================================ E N D ================================ * END SUBROUTINE ZZTERM ( FIRST, N, F, G, XI, XIM1, EPS, LESS ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * INTEGER N * LOGICAL LESS, FIRST * DOUBLE PRECISION EPS, G(N), XI(N), XIM1(N), F C!!!! REAL EPS, G(N), XI(N), XIM1(N), F * C============================= S T A T U S ============================= 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 D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C MAR. 12, 1987 A. BUCKLEY 1.1 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 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 !F! <= EPS * !F0! 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 (F0, 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 F0 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 F0 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 ======================= C C ZZTERM ...THE NATURAL ENTRY. C ZZTGET ...TO RETURN NORMS. C ZZTSET ...TO SET THE CONTROL VALUES. C ZZTINT ...TO SET INITIAL SCALING VALUES. C C======================== S U B R O U T I N E S ======================== C C INTRINSIC FUNCTIONS: ABS AND MAX . C C========================= P A R A M E T E R S ========================= * DOUBLE PRECISION ZERO, ONE, TWO, THREE C!!!! REAL ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) * DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN C!!!! REAL FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) * DOUBLE PRECISION EIGHT, NINE, TEN C!!!! REAL EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 8D0, TEN = 10D0 ) * C---- DEFINITIONS FOR THE 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 A R A T I O N S ================= * INTEGER I * DOUBLE PRECISION GSQ, XSQ, DIFFSQ C!!!! REAL 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 * DOUBLE PRECISION VGSQ, VXSQ, VDIFSQ, F0, SF0, NG0, SNG0 C!!!! REAL VGSQ, VXSQ, VDIFSQ, F0, SF0, NG0, SNG0 * C=============================== S A V E =============================== * SAVE GSQ, XSQ, DIFFSQ, F0, NG0, GRAD, STEP, SHXG, FUNC, NORM SAVE TRACE, TRACUN * C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== * DATA F0/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 ========================== * 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 * 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(F) .LE. EPS * ABS(F0) LESS = LESS .AND. LIST IF (TRACE) WRITE(TRACUN,99998) - LIST, '(FUNC) F, F0, EPS=',F, F0, 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 ) * F0 = 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 ============================ * 99999 FORMAT ( A ) * 99998 FORMAT ( ' [TERM] LESS=',L1,'; ',A,3G14.3 ) * 99997 FORMAT ( ' [TERM] LESS=',L1,'; ',A,4G11.3 ) * C================================ E N D ================================ * END SUBROUTINE BBCUBC ( T, F, FP, TA, FA, FPA, LEFT, RIGHT, X, INTER ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * LOGICAL INTER * DOUBLE PRECISION T, F, FP, TA, FA, FPA, LEFT, RIGHT, X C!!!! REAL T, F, FP, TA, FA, FPA, LEFT, RIGHT, X * C============================= S T A T U S ============================= 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 D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C FEB. 10, 1987 A. BUCKLEY 1.0 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 ======================= C C 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 ========================= * DOUBLE PRECISION ZERO, ONE, TWO, THREE C!!!! REAL ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) * DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN C!!!! REAL FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) * DOUBLE PRECISION EIGHT, NINE, TEN C!!!! REAL EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 8D0, TEN = 10D0 ) * INTEGER XEPS, XSMALL, XBIG PARAMETER ( XEPS = 1, XSMALL = 2, XBIG = 3 ) * C================= L O C A L D E C L A R A T I O N S ================= * INTEGER TRU, STRU * LOGICAL EXTREM, TRACE, STRACE, ORDER, ABIGGR, FIRST, PBIGGR * DOUBLE PRECISION P, DISC C!!!! REAL P, DISC * DOUBLE PRECISION SGN, APR, BPR, NUM, XC, RD, EPS, BIGGST, ZZMPAR C!!!! REAL SGN, APR, BPR, NUM, XC, RD, EPS, BIGGST, ZZMPAR * DOUBLE PRECISION ALEFT, ARIGHT C!!!! REAL 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 ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== * DATA TRU/6/, TRACE/.FALSE./, FIRST/.TRUE./ * C========================== E X E C U T I O N ========================== * C---- DEFINE A STATEMENT FUNCTION. * RD(P) = DBLE(P) C!!!! RD(P) = REAL(P) * 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) - THREE*DBLE(FA-F)/DBLE(TA-T) * IF ( SIGN(ONE,FPA) .NE. SIGN(ONE,FP) ) THEN DISC = 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 = P**2 - DBLE(FP)*DBLE(FPA) IF (TRACE) WRITE(TRU,*) ' [CUBC] P,DISC->', P, DISC ELSE IF ( PBIGGR ) THEN DISC = P - (DBLE(FPA)/P)*FP ELSE IF ( ABIGGR ) THEN DISC = (P/DBLE(FPA))*P - FP ELSE DISC = (P/DBLE(FP))*P - 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) + TWO*P BPR = DBLE(FP) + 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 ============================ C C THERE ARE NO FORMATS USED. C C================================ E N D ================================ * END * * SUBROUTINE BBDFLT ( PFREQ, MAXF ) * C================ A R G U M E N T D E C L A R A T I O N S ============ * INTEGER PFREQ, MAXF * C============================= S T A T U S ============================= 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 D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 20, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C C THIS ROUTINE OBTAINS THE DEFAULT VALUES FOR INITIALIZING C THE ROUTINES ZZPRNT, ZZEVAL, ZZTERM AND BBLNIR. IT 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 ======================= C C ONLY THE NATURAL ENTRY POINT 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 A R A T I O N S ================= * CHARACTER*(4) TESTS * INTEGER INTS(NINTS) LOGICAL LOGS(NLOGS) * DOUBLE PRECISION REALS(NREALS) C!!!! REAL REALS(NREALS) * C=============================== S A V E =============================== C C THERE ARE NO SAVE VALUES. C C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA VALUES. C C========================== E X E C U T I O N ========================== * C-----OBTAIN DEFAULTS. * CALL BBVALS ( INTS, LOGS, REALS ) * C-----INITIALIZE ZZEVAL. * CALL ZZESET ( LOGS(XTRF),LOGS(XTRG),LOGS(XTRTST),INTS(XETRCU) ) * CALL ZZESRT ( INTS(XSCALE), INTS(XDRVMD), MAXF ) * C-----INITIALIZE ZZPRNT. * CALL ZZP1ST ( INTS(XPTRCU),LOGS(XGRAD),LOGS(XPOINT), PFREQ ) CALL ZZP2ST ( INTS(XPTRCU),LOGS(XGRAD),LOGS(XPOINT), 0 ) * C-----INITIALIZE 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-----PRESET 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 ============================ C C THERE ARE NO FORMATS USED. C C================================ E N D ================================ * END SUBROUTINE BBDIAG ( N, X, G, H, D, NRMG, INNER, DGCURR, IDENTY, - IW, RW, DW ) * C================ A R G U M E N T D E C L A R A T I O N S ============ * INTEGER N, IW(*) * LOGICAL IDENTY * DOUBLE PRECISION X(N), G(N), H(N), D(N), NRMG, DGCURR C!!!! REAL X(N), G(N), H(N), D(N), NRMG, DGCURR * EXTERNAL INNER DOUBLE PRECISION INNER, DW(*) REAL RW(*) * C============================= S T A T U S ============================= 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 D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 17, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C C THE MAIN PURPOSE OF THIS ROUTINE IS TO DEFINE A DIAGONAL C SCALING; THIS IS STORED IN THE FIRST N LOCATIONS OF THE C ARRAY H. 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 IN ADDITION, A SEARCH DIRECTION D IS COMPUTED, ALONG WITH C ITS 2-NORM, AND BOTH ARE RETURNED TO THE CALLING ROUTINE. C HERE, D IS COMPUTED AS D = -H*G, SO THAT D(I) = - H(I)*G(I). C FINALLY, THE INNER PRODUCT OF D WITH G MUST BE C COMPUTED AND RETURNED. 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 ON ENTRY, THE CURRENT POINT X AND THE GRADIENT G AT X C MUST BE DEFINED, ALONG WITH THE 2-NORM (NRMG) OF G. THE NORM C OF G IS USED TO COMPUTE THE NORM OF D WHEN H = I. C C BOTH X AND G ARE USED TO COMPUTE THE DIAGONAL SCALING C ENTRIES OF H. 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 WHETHER SCALING IS DONE OR NOT, THE VALUES FOR H, D C AND DGCURR MUST BE DEFINED BEFORE EXITING. C C-----NOTE THAT THE PARAMETER SCDIAG WILL BE THE SAME FOR EACH CALL C TO BBDIAG DURING THE PROCESSING OF ANY PARTICULAR MINIMIZATION C PROBLEM IT IS SET JUST ONCE THROUGH AN ENTRY POINT. C C======================= E N T R Y P O I N T S ======================= C C BBDIAG THE NATURAL ENTRY POINT. C BBSDAG AN ENTRY TO DEFINE THE FIXED PARAMETERS. C C======================== S U B R O U T I N E S ======================== C C ABS INTRINSIC FUNCTION. C C INNER TO COMPUTE THE 2-NORM OF A VECTOR WITHOUT OVERFLOW. C C========================= P A R A M E T E R S ========================= * * LOGICAL DONORM, NONORM PARAMETER ( DONORM = .TRUE., NONORM = .FALSE. ) DOUBLE PRECISION ZERO, ONE, TWO, THREE C!!!! REAL ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) * DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN C!!!! REAL FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) * DOUBLE PRECISION EIGHT, NINE, TEN C!!!! REAL EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 8D0, TEN = 10D0 ) * C================= L O C A L D E C L A R A T I O N S ================= * INTEGER J * C-----TO SET THROUGH THE ENTRY POINT. * LOGICAL SCDIAG, SSCDAG * C=============================== S A V E =============================== * SAVE SCDIAG * C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA VALUES. C 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 * D(J) = -H(J)*G(J) * 1200 CONTINUE * DGCURR = INNER ( N, D, G, NONORM, IW, RW, DW ) * ELSE C H IS JUST THE IDENTITY * DO 1400 J = 1,N D(J) = -G(J) 1400 CONTINUE * DGCURR = -NRMG**2 * ENDIF * GOTO 90000 * C>>>>>>>>>>>>>>>>>>>>>>>>>> E N T R Y BBSDAG <<<<<<<<<<<<<<<<<<<<<<<<<< * ENTRY BBSDAG ( SSCDAG ) * SCDIAG = SSCDAG * RETURN * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NO FORMATS USED. C C================================ E N D ================================ * END DOUBLE PRECISION FUNCTION ZZINNR ( N, U, V, NRMFLG, IW, RW, DW ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * INTEGER N, IW(*) * LOGICAL NRMFLG * DOUBLE PRECISION U(N), V(N) C!!!! REAL U(N), V(N) * DOUBLE PRECISION DW(*) REAL RW(*) * C============================= S T A T U S ============================= 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 D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C APR. 1, 1987 A. BUCKLEY 1.0 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. NOTE THAT THE RESULT PASSED BACK IS C *ALWAYS* DOUBLE PRECISION. IF NRMFLG IS SET ON ENTRY, THEN C THE 2-NORM OF U IS COMPUTED BY CALLING ZZNRM2 TO DO THE C COMPUTATION WITHOUT OVERFLOW. IN THIS CASE, V IS IGNORED AND C THE NORM IS COMPUTED IN SINGLE OR DOUBLE PRECISION AS APPROPRIATE. C C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZINNR C C======================== S U B R O U T I N E S ======================== C C ZZNRM2 FOR NO OVERFLOW 2-NORMS C DBLE ...INTRINSIC C C========================= P A R A M E T E R S ========================= * DOUBLE PRECISION ZERO, ONE, TWO, THREE C!!!! REAL ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) * DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN C!!!! REAL FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) * DOUBLE PRECISION EIGHT, NINE, TEN C!!!! REAL EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 8D0, TEN = 10D0 ) * C================= L O C A L D E C L A R A T I O N S ================= * INTEGER I * DOUBLE PRECISION ZZNRM2 C!!!! REAL ZZNRM2 * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA VALUES. C 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 ============================ C C THERE ARE NO FORMATS USED. C C================================ E N D ================================ * END * * SUBROUTINE BBLINS (ALPHA, F, DG, VALIDF, F0, DG0, AP, FP, DGP, - WIDTH, NOUPS, LSDONE, CT, NCALLS, QUADON, UPDATT ) * C================ A R G U M E N T D E C L A R A T I O N S ============ * LOGICAL NOUPS, LSDONE, QUADON, VALIDF * INTEGER CT, NCALLS, UPDATT * DOUBLE PRECISION F, DG, ALPHA, F0, DG0, DGP, FP, AP, WIDTH C!!!! REAL F, DG, ALPHA, F0, DG0, DGP, FP, AP, WIDTH * C============================= S T A T U S ============================= 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 D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C JAN. 11, 1985 A. BUCKLEY 1.0 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 F 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 ======================= C C BBLINS ... THE NATURAL ENTRY POINT. C BBSLNS ... AN ENTRY TO INITIALIZE FIXED ARGUMENTS. C C======================== S U B R O U T I N E S ======================== C C BBCUBC FOR CUBIC INTERPOLATION. C C========================= P A R A M E T E R S ========================= * DOUBLE PRECISION ZERO, ONE, TWO, THREE C!!!! REAL ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) * DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN C!!!! REAL FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) * DOUBLE PRECISION EIGHT, NINE, TEN C!!!! REAL EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 8D0, TEN = 10D0 ) * DOUBLE PRECISION NERLY1, BITSML, SMALL C!!!! REAL NERLY1, BITSML, SMALL PARAMETER ( NERLY1=.9D0, BITSML=.1D0, SMALL = .0001D0 ) * DOUBLE PRECISION EXTRAP, INITMG, XPNDMG C!!!! REAL EXTRAP, INITMG, XPNDMG PARAMETER ( EXTRAP = 10.D0, INITMG = .01D0, XPNDMG = 3.0D0 ) * DOUBLE PRECISION MAXMG C!!!! REAL MAXMG PARAMETER ( MAXMG = .3D0 ) * * INTEGER SUMFRM, PRDFRM, MJDFRM PARAMETER ( SUMFRM = 1, PRDFRM = 2, MJDFRM = 3 ) * C================= L O C A L D E C L A R A T I O N S ================= * 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 * DOUBLE PRECISION ACC, SACC C!!!! REAL ACC, SACC * C-----GENERAL DECLARATIONS. * LOGICAL ACCEPT, FORCEQ, QNSTEP, QDONE, INTPT, TEST1 LOGICAL FIRST, LDATA, UDATA, INTERP, GOODP, TEST2 * DOUBLE PRECISION LB, FLB, DGLB, UB, FUB, DGUB, TP0, AT C!!!! REAL LB, FLB, DGLB, UB, FUB, DGUB, TP0, AT * DOUBLE PRECISION LEFT, RIGHT, SLICE, CURRMG C!!!! REAL LEFT, RIGHT, SLICE, CURRMG * C=============================== S A V E =============================== * SAVE M, QUADIN, TRU, CURRMG SAVE CG, USESHN, LMSTQN, FQUAD, TR4, TR5, TR6 SAVE ACC, LB, FLB, DGLB, LDATA, UB, FUB, DGUB, UDATA, GOODP * C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA VALUES. C 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, F, DG * FIRST = NCALLS .EQ. 1 * IF ( FIRST ) THEN * LB = ZERO FLB = F0 DGLB = DG0 * UB = ZERO * GOODP = .TRUE. CURRMG = INITMG * ENDIF * C TEST WHETHER THE STEPLENGTH CRITERIA HAVE BEEN MET. * TP0 = F0 + SMALL*ALPHA*DG0 TEST1 = F .LT. TP0 TEST2 = DG .GE. NERLY1*DG0 * IF (TR5) WRITE (TRU,*) ' [LINS] TP0->',TP0 * IF ( VALIDF ) THEN ACCEPT = TEST1 .AND. TEST2 ELSE ACCEPT = .FALSE. 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 = .TRUE. * ELSE IF ( CG .AND. UPDATT .EQ. SUMFRM ) THEN * QNSTEP = .NOT. NOUPS - .AND. ( QUADIN .GT. 0 ) - .AND. ( CT .LT. M+QUADIN ) * FORCEQ = .NOT. QNSTEP .AND. QUADIN .LE. 3 * ELSE IF ( CG .AND. UPDATT .EQ. PRDFRM ) THEN * FORCEQ = .FALSE. * 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 = .TRUE. FUB = F DGUB = DG ELSE LB = ALPHA LDATA = .TRUE. FLB = F DGLB = DG ENDIF ENDIF * ELSE * IF ( TR6 ) THEN WRITE(TRU,*) ' [LINS] NOT ACCEPTED; F ', TEST1, TEST2, UDATA WRITE(TRU,99998) ' [LINS] REQ''D REDUCTION, F0-F, SLOPE' - // ' LIMIT->', F0-TP0,F0-F,NERLY1*DG0 ENDIF * LSDONE = .FALSE. * IF ( .NOT. VALIDF ) THEN UB = ALPHA UDATA = .FALSE. ELSE IF ( F .GE. TP0 ) THEN UB = ALPHA FUB = F DGUB = DG UDATA = VALIDF ELSE LB = ALPHA FLB = F 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 = .FALSE. ELSE INTERP = .TRUE. IF ( AP .GT. UB .AND. LDATA ) THEN AP = LB FP = FLB DGP = DGLB ENDIF ENDIF * ELSE * INTERP = .FALSE. LEFT = ALPHA * (ONE+INITMG) RIGHT = EXTRAP * ALPHA * CALL BBCUBC (ALPHA,F,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, F, 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 = F DGP = DG * ALPHA = AT GOODP = VALIDF ELSE ALPHA = AT GOODP = .FALSE. 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 ================================ * END 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 D E C L A R A T I O N S ============ * EXTERNAL FUNCNM, INNER * INTEGER N, HDIM, STATUS, IW(*) * DOUBLE PRECISION X(N), G(N), D(N), XX(N), GG(N), H(*) C!!!! REAL X(N), G(N), D(N), XX(N), GG(N), H(*) * DOUBLE PRECISION FX, ACC, DECRF C!!!! REAL FX, ACC, DECRF * DOUBLE PRECISION DW(*), INNER, FUNCNM REAL RW(*) * C============================= S T A T U S ============================= 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 D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 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 (T) 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 CURRENTLY UNUSED. 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 C FUNCNM, INNER EXTERNAL PROCEDURES PASSED AS ARGUMENTS. C C HERE, A NAME IN [..] IS AN ENTRY POINT IN THE GIVEN ROUTINE. C C BBDIAG [BBSDAG] 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 ) * DOUBLE PRECISION RTRUE, RFALSE C!!!! REAL RTRUE, RFALSE PARAMETER ( RTRUE = 1.D0, RFALSE = 0.D0 ) * INTEGER XEPS, XSMALL, XBIG PARAMETER ( XEPS = 1, XSMALL = 2, XBIG = 3 ) DOUBLE PRECISION ZERO, ONE, TWO, THREE C!!!! REAL ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) * DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN C!!!! REAL FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) * DOUBLE PRECISION EIGHT, NINE, TEN C!!!! REAL EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 8D0, TEN = 10D0 ) * DOUBLE PRECISION TENTH, FIFTH, HALF C!!!! REAL TENTH, FIFTH, HALF PARAMETER ( TENTH = .1D0, FIFTH = .2D0, HALF = .5D0 ) * DOUBLE PRECISION RPT9, RPT8, RD29 C!!!! REAL RPT9, RPT8, RD29 PARAMETER ( RPT9 = .9D0, RPT8 = .8D0, RD29 = 1D0/29D0 ) DOUBLE PRECISION R11, R12, R13, R14 C!!!! REAL R11, R12, R13, R14 PARAMETER ( R11 = 11D0, R12 = 12D0, R13 = 13D0,R14 = 14D0) * DOUBLE PRECISION R15, R16, R17, R18 C!!!! REAL R15, R16, R17, R18 PARAMETER ( R15 = 15D0, R16 = 16D0, R17 = 17D0,R18 = 18D0) * DOUBLE PRECISION R19, R20, R25, R29 C!!!! REAL R19, R20, R25, R29 PARAMETER ( R19 = 19D0, R20 = 20D0, R25 = 25D0,R29 = 29D0) * DOUBLE PRECISION R32, R36, R40, R42 C!!!! REAL R32, R36, R40, R42 PARAMETER ( R32 = 32D0, R36 = 36D0, R40 = 40D0,R42 = 42D0) * DOUBLE PRECISION R45, R49 C!!!! REAL R45, R49 PARAMETER ( R45 = 45D0, R49 = 49D0 ) * DOUBLE PRECISION R50, R56, R84, R90 C!!!! REAL R50, R56, R84, R90 PARAMETER ( R50 = 50D0, R56 = 56D0, R84 = 84D0,R90 = 90D0) * DOUBLE PRECISION R100, R180, R200 C!!!! REAL R100, R180, R200 PARAMETER ( R100 = 100D0, R180 = 180D0, R200 = 200D0 ) * DOUBLE PRECISION R256, R360, R400 C!!!! REAL R256, R360, R400 PARAMETER ( R256 = 256D0, R360 = 360D0, R400 = 400D0 ) * DOUBLE PRECISION R600, R681, R991 C!!!! REAL R600, R681, R991 PARAMETER ( R600 = 600D0, R681 = 681D0, R991 = 991D0 ) * DOUBLE PRECISION R1162, R2324 C!!!! REAL R1162, R2324 PARAMETER ( R1162 = 1162D0, R2324 = 2324D0 ) * DOUBLE PRECISION R10000, R40000 C!!!! REAL 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 ) * DOUBLE PRECISION NERLY1 C!!!! REAL NERLY1 PARAMETER ( NERLY1 = RPT9 ) * C================= L O C A L D E C L A R A T I O N S ================= * 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 * DOUBLE PRECISION RO, BETA, SRO, SBETA C!!!! REAL 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 * DOUBLE PRECISION FP, FMIN, ALPHA, AP, DGLAST, DG0, ZZMPAR, ANGLE C!!!! REAL FP, FMIN, ALPHA, AP, DGLAST, DG0, ZZMPAR, ANGLE DOUBLE PRECISION DGP, DGAL, NRMD, NRMG, FLAST, EPS, NDLAST, RD C!!!! REAL DGP, DGAL, NRMD, NRMG, FLAST, EPS, NDLAST, RD DOUBLE PRECISION TP0, TP1, TP2, NRMX, ACOS, PI, RADS, WIDTH C!!!! REAL TP0, TP1, TP2, NRMX, ACOS, PI, RADS, WIDTH DOUBLE PRECISION STS, STY, YTY, YTHY C!!!! REAL STS, STY, YTY, YTHY * CHARACTER*5 TESTS * 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 ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== * 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 TESTS /' FTTF'/ * 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-----DEFINE THREE STATEMENT FUNCTIONS. * BAD() = CASE .EQ. ABORT .OR. CASE .EQ. LIMIT .OR. CASE .EQ. NOF - .OR. CASE .EQ. NOFG .OR. CASE .EQ. NOG * ANGLE(AP) = RADS*ACOS(AP) * RD(AP) = DBLE (AP) C!!!! RD(AP) = REAL (AP) 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 INITIALIZE STATUS, CNTRST, ETC. * CNTRST = 0 OTSTAT = OK 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 INCR = 2*N + 1 ENDIF * M = (HDIM - BASE) / INCR * IF ( METH .EQ. 0 ) THEN IF ( HDIM .GE. STORAG ) THEN CG = F 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 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 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 BBSDAG ( SCDIAG ) * 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 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) 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 BBDIAG ( N, X, G, H, D, NRMG, INNER, DG0, IDENTY, IW,RW,DW) NRMD = INNER ( N, D, D, DONORM, 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, INNER (N,X,X,DONORM,IW,RW,DW) ) C!!!! NRMX = MAX ( ONE, RD(INNER (N,X,X,DONORM,IW,RW,DW)) ) IF ( TR8 ) WRITE (TRU,*) ' [LNIR] NORM OF X->', NRMX IF ( TR8 ) WRITE (TRU,*) ' [LNIR] NORM OF D->', NRMD QUADON = F * IF ( TR9 ) WRITE(TRU,*) ' [LNIR] D->',D IF ( TR9 ) WRITE(TRU,*) ' [LNIR] X->',X * 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.<<<<<<<<<<<< * 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 NDLAST = NRMD FLAST = FMIN * C STORE THE CURRENT X AND G. * DO 1800 J=1,N XX(J) = X(J) GG(J) = G(J) 1800 CONTINUE * 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. * DO 2100 J=1,N X(J) = XX(J) + ALPHA*D(J) 2100 CONTINUE * 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. * DO 2700 J=1,N D(J) = ALPHA*D(J) 2700 CONTINUE * C CHECK IF A RESTART IS TO BE FORCED. * FORCER = CG .AND. UPDATT .EQ. SUMFRM - .AND. ( .NOT. LMSTQN ) - .AND. ( (CT .GE. LASTPT) .OR. (STEEPD .AND. FORCEF) ) * IF ( TR7 ) WRITE(TRU,*) ' [LNIR] FORCER->',FORCER * 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 * 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, 1, 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 BBUPDT (N, G, D, XX, GG, H, CT, CNTRST, LASTPT, IDENTY, NUPS, - STEEPD, RSTEP, QNPART, UPDATT, INNER, IW, RW, DW ) * C>>>>>>>>>> P H A S E XI: COMPUTE NEW DIRECTION.<<<<<<<<<<<<<<<<<<<<< * IF ( CG ) THEN * C CALCULATE THE DERIVATIVE DG0 ALONG THE NEW SEARCH VECTOR D. C THE NEW D IS AVAILABLE IN XX, AND IS TRANSFERRED TO D. * DO 7500 K=1,N D(K) = -XX(K) 7500 CONTINUE * 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 *PASSED TO* C FUNCTION EVALUATION ROUTINE. * ENTRY BBLFDF ( SDOF, SDOG, SDOFG, SNONE ) * DOF = SDOF DOG = SDOG DOFG = SDOFG NONE = SNONE * CALL ZZEFDF ( SDOF, SDOG, SDOFG, SNONE ) * 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 MUPS = M 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.' ) * 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 ================================ * END * SUBROUTINE BBMJDP ( DIAG, SHAT, W, Z, PHI, V, DELT, GAM, S, R, - U, HU, N, NUPS, I, M, IDENTY, INNER, IW, RW, DW, TR,TRU ) * C================ A R G U M E N T D E C L A R A T I O N S ============ * EXTERNAL INNER * INTEGER N, NUPS, I, M, TRU, IW(*) * LOGICAL IDENTY, TR * DOUBLE PRECISION U(N), HU(N), DIAG(*), SHAT(*), W(*), Z(*) C!!!! REAL U(N), HU(N), DIAG(*), SHAT(*), W(*), Z(*) * DOUBLE PRECISION PHI(0:*), V(N,0:*), DELT(N,0:*), GAM(N,0:*) C!!!! REAL PHI(0:*), V(N,0:*), DELT(N,0:*), GAM(N,0:*) * DOUBLE PRECISION S(N,0:*), R(0:*) C!!!! REAL S(N,0:*), R(0:*) * DOUBLE PRECISION DW(*), INNER REAL RW(*) * C============================= S T A T U S ============================= 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 D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C JUNE 2, 1987 A. BUCKLEY 1.0 C C======================== D E S C R I P T I O N ======================== C C GIVEN THE QUASI NEWTON UPDATE MATRIX H (IN ZZ^T FORM) AND C GIVEN THE VECTOR V, THIS ROUTINE COMPUTES C C HV = H * V . C C IT ALSO RETURNS THE INTERMEDIATE VALUE SHAT = Z^T * V. C C-----NOTE THAT A NUMBER OF PARAMETERS WHICH WILL BE THE SAME C FOR EACH CALL TO BBMJDP DURING ANY PARTICULAR MINIMIZATION C PROBLEM ARE SET JUST ONCE THROUGH AN ENTRY POINT. C C------EACH UPDATE TERM OF H REQUIRES 3N+1 ENTRIES OF H. THE ORDER IS C C ETA(I), S(I), Y(I) AND SHAT(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 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 SEE BBMULT REGARDING THE USE OF INNER. 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------BETA IS THE PARAMETER DEFINING THE BROYDEN FAMILY C OF UPDATES. THE FORM USED IS C H! = H(DFP) + BETA * NU * W'W C SO THAT BETA = 1 GIVES THE BFGS UPDATE. C NOTE THAT H! DENOTES THE MATRIX OBTAINED BY C UPDATING H. BETA MUST BE 1 FOR PRODUCT UPDATES. C C------IF SCDIAG = .TRUE., H0 IS TAKEN TO BE A DIAGONAL MATRIX C WHICH IS AVAILABLE IN THE FIRST N C LOCATIONS OF THE ARRAY H. OTHERWISE, C H0 = I, AND IT IS OF COURSE NOT STORED. C C------IF SCGAMM = 2, THEN THE SO-CALLED GAMMA SCALING OF C OREN AND SPEDICATO, WHICH IS DESCRIBED C BY SHANNO, IS USED AT EACH UPDATE STEP. C THIS CAN IN FACT BE DONE ONLY IF THE C BFGS UPDATE IS BEING USED, I.E. IF C BETA = 1. NO EXTRA STORAGE IS NEEDED C TO IMPLEMENT THIS SCALING. IT IS NOT ALLOWED C WITH PRODUCT FORM UPDATES. C C------IF SCGAMM = 1, THEN SCALING IS DONE, AS JUST DESCRIBED C FOR SCGAMM=2, BUT IT ONLY APPLIES TO C THE FIRST UPDATE TERM. IT IS ALLOWED WITH C PRODUCT FORM UPDATES. C C-------IDENTY IS TRUE TO INDICATE THAT H0 = I; THIS MAY BE TRUE C EVEN IF SCDIAG IS TRUE. C C------INCR IS THE CONSTANT 2N+1, THE LENGTH OF EACH TERM. C BASE IS THE NO. OF LOCATIONS FOR THE DIAG. H0, EITHER 0 OR N. C COUNT NO OF TERMS DONE (INTERNAL COUNTER). C PTNU POINTER TO CURRENT RANK 2 TERM (INTERNAL POINTER). C C------TRACES: TURN ON TR TO SEE NU, ETA, GAMMA, HV AND S'V. C THESE 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 ======================= C C BBMJDP THE NATURAL ENTRY POINT. C C======================== S U B R O U T I N E S ======================== C C NO SUBROUTINES OR FUNCTIONS ARE CALLED C C========================= P A R A M E T E R S ========================= * * * LOGICAL DONORM, NONORM PARAMETER ( DONORM = .TRUE., NONORM = .FALSE. ) DOUBLE PRECISION ZERO, ONE, TWO, THREE C!!!! REAL ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) * DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN C!!!! REAL FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) * DOUBLE PRECISION EIGHT, NINE, TEN C!!!! REAL EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 8D0, TEN = 10D0 ) * C================= L O C A L D E C L A R A T I O N S ================= * INTEGER COUNT, K, IS, L, J, IY, IETA, LAST * DOUBLE PRECISION SV, GAMMA, BETAK, NU, ZETA, TMP C!!!! REAL SV, GAMMA, BETAK, NU, ZETA, TMP * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA VALUES. C C========================== E X E C U T I O N ========================== * IF ( TR ) WRITE (TRU,*) ' ***[MJDP ENTERED]***' * DO 4000 K = N,2,-(I-1) * DO 3000 J = MAX(0,-K+1), MIN(I,N-K-1) * ZETA = SQRT( PHI(J)/(PHI(J)+S(K+J-1,J)) ) * IF ( J .EQ. 0 ) THEN * DO 300 L = 1,N W(L) = - GAM(K-1,0) * DELT(L,0) 300 CONTINUE W(K-1) = W(K-1) + ONE * ELSE IF ( K-1+J .EQ. 1 ) THEN * TMP = INNER (N, GAM(1,J), DELT(1,J-1), NONORM,IW,RW,DW) DO 400 L = 1,N W(L) = (DELT(L,J-1) - TMP * DELT(L,J)) / R(J-1) 400 CONTINUE * ELSE TMP = INNER (N, GAM(1,J), Z, NONORM,IW,RW,DW) DO 500 L = 1,N W(L) = Z(L) - TMP * DELT(L,J) 500 CONTINUE ENDIF * DO 600 L = 1,N Z(L) = ZETA*(W(L) + S(K+J-1,J)*V(L,J))/PHI(J) V(L,J) = V(L,J) + S(K+J-1,J)*W(L) 600 CONTINUE * PHI(J) = PHI(J) + S(K+J-1,J)**2 * 3000 CONTINUE * IF ( K+I .GT. N ) THEN * IF ( K .EQ. N ) THEN DO 1100 L = 1,N V(L,0) = S(N,0)*GAM(N,0)* DELT(L,N-K) HU(L) = ZERO 1100 CONTINUE V(N,0) = V(N,0) + S(N,0) PHI(0) = S(N,0)**2 ELSE TMP = INNER(N, GAM(1,N-K), Z, NONORM,IW,RW,DW) DO 1200 L = 1,N V(L,J+1) = S(N,N-K)*(Z(L) - TMP * DELT(L,N-K)) 1200 CONTINUE PHI(J) = S(N,J)**2 ENDIF ELSE SHAT(K+J) = INNER (N, Z, U, NONORM, IW, RW, DW ) DO 2000 L = 1,N HU(L) = HU(L) + SHAT(K+J) + Z(L) 2000 CONTINUE ENDIF * 4000 CONTINUE * SHAT(1) = INNER( N, DELT(1,I), U, NONORM, IW, RW, DW )/R(I) * DO 5000 L = 1,N HU(L) = HU(L) + SHAT(1) * DELT(L,1)/R(1) 5000 CONTINUE * GOTO 90000 * C=============================== E X I T =============================== * 90000 IF ( TR ) WRITE (TRU,*) ' ===[LEAVING MJDP].' * RETURN * C============================ F O R M A T S ============================ C C THERE ARE NO FORMATS. C C================================ E N D ================================ * END SUBROUTINE BBMULT ( H, V, HV, N, NUPS, ICOMP, IDENTY, INNER, - IW, RW, DW ) * C================ A R G U M E N T D E C L A R A T I O N S ============ * EXTERNAL INNER * INTEGER N, NUPS, ICOMP, IW(*) * LOGICAL IDENTY * DOUBLE PRECISION H(*), V(N), HV(N) C!!!! REAL H(*), V(N), HV(N) * DOUBLE PRECISION DW(*), INNER REAL RW(*) * C============================= S T A T U S ============================= 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 D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C APR. 2, 1987 A. BUCKLEY 1.1 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 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 ARE COMPUTED BY CALLING THE C 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. 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--BETA IS THE PARAMETER DEFINING THE BROYDEN FAMILY OF UPDATES. C THE FORM USED IS H! = H(DFP) + BETA * NU * W'W C SO THAT BETA = 1 GIVES THE BFGS UPDATE. NOTE THAT H! C DENOTES THE MATRIX OBTAINED BY UPDATING H. 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 IF = 2, 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 IF SCGAMM = 1, THEN SCALING IS DONE, AS JUST DESCRIBED C FOR SCGAMM=2, BUT IT ONLY APPLIES TO THE FIRST UPDATE TERM. C C--ICOMP IS A FLAG WHICH CONTROLS THE COMPUTATION TO BE DONE. C =1 COMPUTE H*V USING ALL THE TERMS WHICH DEFINE H. C =2 COMPUTE BY ADDING JUST ONE LAST TERM; I.E. WE COMPUTE C (H!)*V, ASSUMING THAT H*V WAS DONE EARLIER AND THAT C 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--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 COUNT NO OF TERMS DONE (INTERNAL COUNTER). C PTNU POINTER TO CURRENT RANK 2 TERM (INTERNAL POINTER). C C--TRACES TURN ON TR TO SEE NU, ETA, GAMMA, HV AND S'V. C THESE 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 ======================= C C BBMULT THE NATURAL ENTRY POINT. C BBSMLT AN ENTRY TO SET FIXED PARAMETERS. C C======================== S U B R O U T I N E S ======================== C C NO SUBROUTINES OR FUNCTIONS ARE CALLED C C========================= P A R A M E T E R S ========================= * DOUBLE PRECISION ZERO, ONE, TWO, THREE C!!!! REAL ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) * DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN C!!!! REAL FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) * DOUBLE PRECISION EIGHT, NINE, TEN C!!!! REAL EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 8D0, TEN = 10D0 ) * LOGICAL DONORM, NONORM PARAMETER ( DONORM = .TRUE., NONORM = .FALSE. ) * C================= L O C A L D E C L A R A T I O N S ================= * INTEGER COUNT, IU, K, PTNU, IS, I * DOUBLE PRECISION NU, ETA, UV, SV, GAMMA, MU, SIGMA C!!!! REAL NU, ETA, UV, SV, GAMMA, MU, SIGMA * C-----VARIABLES FOR THE ENTRY POINT. * LOGICAL TR, STR, TRV, STRV, SCDIAG, SSCDAG * INTEGER SCGAMM, INCR, BASE, TRACUN INTEGER SSCGAM, SINCR, SBASE, STRACN * DOUBLE PRECISION BETA, SBETA C!!!! REAL BETA, SBETA * C=============================== S A V E =============================== * SAVE TR, TRV, SCDIAG, SCGAMM, INCR, BASE, TRACUN, BETA * C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA VALUES. C 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 (ICOMP .NE. 1) 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 DO 300 K = 1,N HV(K) = V(K) 300 CONTINUE ENDIF * PTNU = BASE + 1 COUNT = 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 = 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 * 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. 2 ) * - .OR. (SCGAMM .EQ. 1 .AND. I .EQ. 1)) ) THEN * GAMMA = ETA/NU IF ( TR ) WRITE (TRACUN, * ) ' [MULT] GAMMA->',GAMMA * DO 2000 K=1,N HV(K) = GAMMA*HV(K) 2000 CONTINUE * 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 * DO 3000 K=1,N C PRINT*,'K,IU,IS,H(IU+K),H(IS+K)',K,IU,IS,H(IU+K),H(IS+K) HV(K) = HV(K) + MU*H(IU+K) + SIGMA*H(IS+K) 3000 CONTINUE * 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 ============================ C C THERE ARE NO FORMATS. C C================================ E N D ================================ * END SUBROUTINE BBNOCE ( H, V, HV, N, NUPS, ITER, M, IDENTY, ARO, - INNER, IW, RW, DW ) * C================ A R G U M E N T D E C L A R A T I O N S ============ * EXTERNAL INNER * INTEGER N, NUPS, ITER, M, IW(*) * LOGICAL IDENTY * DOUBLE PRECISION H(*), V(N), HV(N), ARO(N) C!!!! REAL H(*), V(N), HV(N), ARO(N) * DOUBLE PRECISION DW(*), INNER REAL RW(*) * C============================= S T A T U S ============================= 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 D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C APR. 1, 1987 A. BUCKLEY 1.0 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 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 SEE BBMULT REGARDING THE USE OF INNER. 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--BETA IS THE PARAMETER DEFINING THE BROYDEN FAMILY C OF UPDATES. THE FORM USED IS H! = H(DFP) + BETA * NU * W'W C SO THAT BETA = 1 GIVES THE BFGS UPDATE. NOTE THAT H! C DENOTES THE MATRIX OBTAINED BY UPDATING H.BETA MUST BE 1 C FOR PRODUCT UPDATES. 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 IF = 2, 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. IT IS NOT ALLOWED C WITH PRODUCT FORM UPDATES. C C IF SCGAMM = 1, THEN SCALING IS DONE, AS JUST DESCRIBED C FOR SCGAMM=2, BUT IT ONLY APPLIES TO THE FIRST UPDATE TERM. C IT IS ALLOWED WITH PRODUCT FORM UPDATES. C C--IDENTY IS TRUE TO INDICATE THAT H0 = I; THIS MAY BE TRUE C EVEN IF SCDIAG IS TRUE. C C------INCR IS THE CONSTANT 2N+1, THE LENGTH OF EACH TERM. C BASE IS THE NO. OF LOCATIONS FOR THE DIAG. H0, EITHER 0 OR N. C COUNT NO OF TERMS DONE (INTERNAL COUNTER). C PTNU POINTER TO CURRENT RANK 2 TERM (INTERNAL POINTER). 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 ======================= C C BBNOCE THE NATURAL ENTRY POINT. C BBSNOC AN ENTRY TO SET FIXED PARAMETERS. C C======================== S U B R O U T I N E S ======================== C C NO SUBROUTINES OR FUNCTIONS ARE CALLED C C========================= P A R A M E T E R S ========================= * * LOGICAL DONORM, NONORM PARAMETER ( DONORM = .TRUE., NONORM = .FALSE. ) * C================= L O C A L D E C L A R A T I O N S ================= * INTEGER COUNT, K, IS, I, IY, IETA, LAST * DOUBLE PRECISION SV, GAMMA, BETAK, NU C!!!! REAL SV, GAMMA, BETAK, NU * C-----VARIABLES FOR THE ENTRY POINT. * LOGICAL TR, STR, TRV, STRV, SCDIAG, 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 ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA VALUES. C C========================== E X E C U T I O N ========================== * IF ( TR ) WRITE (TRACUN,*) ' ***[NOCE ENTERED]***' * C INITIALIZE COUNTERS. * IF ( ITER .GT. M ) THEN COUNT = M ELSE COUNT = NUPS ENDIF * IF ( NUPS .GT. 0 ) THEN * C DO THE FIRST ITERATION OF THE FIRST HALF OF NOCEDAL'S RECURSION * IETA = (NUPS-1)*INCR +1 IS = IETA + 1 IY = IS + N - 1 * SV = INNER ( N, H(IS), V, NONORM, IW, RW, DW ) * ARO(NUPS) = SV / H(IETA) * DO 130 I = 1,N HV(I) = V(I) - ARO(NUPS)*H(IY+I) 130 CONTINUE * LAST = NUPS * DO 200 I = 1,COUNT-1 * IETA = IETA - INCR IF ( IETA .LE. 0 ) IETA = IETA + M*INCR IS = IETA + 1 IY = IS + N - 1 * LAST = LAST - 1 IF ( LAST .EQ. 0 ) LAST = M * C DO THE REMAINING ITERATIONS OF THE FIRST HALF. * SV = INNER ( N, H(IS), HV, NONORM, IW, RW, DW ) * ARO(LAST) = SV/H(IETA) * DO 180 K = 1,N HV(K) = HV(K) - ARO(LAST)*H(IY+K) 180 CONTINUE * 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 ( NUPS .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. 1 ) THEN NU = INNER ( N, H(IY+1), H(IY+1), NONORM, IW, RW, DW ) DO 225 K = 1,N HV(K) = HV(K)*H(IETA)/NU 225 CONTINUE ENDIF ELSE IF ( .NOT. IDENTY ) THEN DO 230 K=1,N HV(K) = H(K) * V(K) 230 CONTINUE ELSE DO 240 K = 1,N HV(K) = V(K) 240 CONTINUE 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 ) * DO 3000 K=1,N HV(K) = HV(K) + (ARO(LAST) - BETAK/H(IETA)) * H(IS+K) 3000 CONTINUE * LAST = MOD(LAST,M) + 1 IETA = IETA + INCR IF ( IETA .GT. M*INCR ) IETA = 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 ============================ C C THERE ARE NO FORMATS. C C================================ E N D ================================ * END DOUBLE PRECISION FUNCTION ZZNRM2 ( N, V ) C!!!! REAL FUNCTION ZZNRM2 ( N, V ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * INTEGER N * DOUBLE PRECISION V(N) C!!!! REAL V(N) * C============================= S T A T U S ============================= 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 D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C JAN. 26, 1987 A. BUCKLEY 1.1 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZNRM2 C C======================== S U B R O U T I N E S ======================== 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 ========================= * INTEGER NULL, SMALL, NORMAL, LARGE PARAMETER ( NULL = 0, SMALL = 1, NORMAL = 2, LARGE = 2 ) * DOUBLE PRECISION ZERO, ONE, TWO, THREE C!!!! REAL ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) * DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN C!!!! REAL FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) * DOUBLE PRECISION EIGHT, NINE, TEN C!!!! REAL EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 8D0, TEN = 10D0 ) * INTEGER XEPS, XSMALL, XBIG PARAMETER ( XEPS = 1, XSMALL = 2, XBIG = 3 ) * C================= L O C A L D E C L A R A T I O N S ================= * INTEGER I, CASE * LOGICAL FIRST * DOUBLE PRECISION CUTLO, CUTHI, MAX, SUM, ZZMPAR, RD, XMAX C!!!! REAL CUTLO, CUTHI, MAX, SUM, ZZMPAR, RD, XMAX * C=============================== S A V E =============================== * SAVE FIRST, MAX * C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== * DATA FIRST / .TRUE. / * C========================== E X E C U T I O N ========================== * C----DEFINE A STATEMENT FUNCTION. * RD(I) = DBLE (I) C!!!! RD(I) = REAL (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 ============================ C C THERE ARE NO FORMATS USED. C C================================ E N D ================================ * END SUBROUTINE ZZPOWL ( H, U, HU, N, NUPS, I, M, IDENTY, - INNER, IW, RW, DW ) * C================ A R G U M E N T D E C L A R A T I O N S ============ * EXTERNAL INNER * INTEGER N, NUPS, I, M, IW(*) * LOGICAL IDENTY * DOUBLE PRECISION H(*), U(N), HU(N) C!!!! REAL H(*), U(N), HU(N) * DOUBLE PRECISION DW(*), INNER REAL RW(*) * C============================= S T A T U S ============================= 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 D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C JUNE 2, 1987 A. BUCKLEY 1.0 C C======================== D E S C R I P T I O N ======================== C C GIVEN THE QUASI NEWTON UPDATE MATRIX H (IN ZZ^T FORM) AND C GIVEN THE VECTOR U, THIS ROUTINE COMPUTES C C HU = H * U . C C IT ALSO RETURNS THE INTERMEDIATE VALUE SHAT = Z^T * U. C C-----NOTE THAT A NUMBER OF PARAMETERS WHICH WILL BE THE SAME C FOR EACH CALL TO BBMJDP DURING ANY PARTICULAR MINIMIZATION C PROBLEM ARE SET JUST ONCE THROUGH AN ENTRY POINT. C C------EACH UPDATE TERM OF H REQUIRES 3N+1 ENTRIES OF H. THE ORDER IS C C ETA(I), S(I), Y(I) AND SHAT(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 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 SEE BBMULT REGARDING THE USE OF INNER. 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------BETA IS THE PARAMETER DEFINING THE BROYDEN FAMILY C OF UPDATES. THE FORM USED IS C H! = H(DFP) + BETA * NU * W'W C SO THAT BETA = 1 GIVES THE BFGS UPDATE. C NOTE THAT H! DENOTES THE MATRIX OBTAINED BY C UPDATING H. BETA MUST BE 1 FOR PRODUCT UPDATES. C C------IF SCDIAG = .TRUE., H0 IS TAKEN TO BE A DIAGONAL MATRIX C WHICH IS AVAILABLE IN THE FIRST N C LOCATIONS OF THE ARRAY H. OTHERWISE, C H0 = I, AND IT IS OF COURSE NOT STORED. C C------IF SCGAMM = 2, THEN THE SO-CALLED GAMMA SCALING OF C OREN AND SPEDICATO, WHICH IS DESCRIBED C BY SHANNO, IS USED AT EACH UPDATE STEP. C THIS CAN IN FACT BE DONE ONLY IF THE C BFGS UPDATE IS BEING USED, I.E. IF C BETA = 1. NO EXTRA STORAGE IS NEEDED C TO IMPLEMENT THIS SCALING. IT IS NOT ALLOWED C WITH PRODUCT FORM UPDATES. C C------IF SCGAMM = 1, THEN SCALING IS DONE, AS JUST DESCRIBED C FOR SCGAMM=2, BUT IT ONLY APPLIES TO C THE FIRST UPDATE TERM. IT IS ALLOWED WITH C PRODUCT FORM UPDATES. C C-------IDENTY IS TRUE TO INDICATE THAT H0 = I; THIS MAY BE TRUE C EVEN IF SCDIAG IS TRUE. C C------INCR IS THE CONSTANT 2N+1, THE LENGTH OF EACH TERM. C BASE IS THE NO. OF LOCATIONS FOR THE DIAG. H0, EITHER 0 OR N. C COUNT NO OF TERMS DONE (INTERNAL COUNTER). C PTNU POINTER TO CURRENT RANK 2 TERM (INTERNAL POINTER). C C------TRACES: TURN ON TR TO SEE NU, ETA, GAMMA, HV AND S'V. C THESE 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 ======================= C C BBPOWL THE NATURAL ENTRY POINT. C BBSMJD AN ENTRY TO SET FIXED POINTERS. C C======================== S U B R O U T I N E S ======================== C C ZZMJDP A ROUTINE WHICH ACTUALLY IMPLEMENTS THE UPDATES. C C========================= P A R A M E T E R S ========================= C C NONE. C C================= L O C A L D E C L A R A T I O N S ================= * INTEGER PTDIAG, PTSHAT, PTW, PTZ, PTPHI, PTV, PTDELT, PTGAM, PTS INTEGER DIAG, SHAT, W, Z, PHI, V, DELT, GAM, S INTEGER PTR, R * C-----VARIABLES FOR THE ENTRY POINT. * LOGICAL TR, STR, TRV, STRV, SCDIAG, SSCDAG * INTEGER SCGAMM, TRACUN INTEGER SSCGAM, STRACN * C=============================== S A V E =============================== * SAVE TR, TRV, SCDIAG, SCGAMM, TRACUN SAVE W, SHAT, DIAG, Z, PHI, V, DELT, GAM, S, R * C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C NO DATA VALUES. C C========================== E X E C U T I O N ========================== * * CALL BBMJDP ( H(DIAG), H(SHAT), H(W), H(Z), H(PHI), H(V), - H(DELT), H(GAM), H(S), H(R), - U, HU, N, NUPS, I, M, IDENTY, INNER, IW, RW, DW ) * GOTO 90000 * C>>>>>>>>>>>>>>>>>>>>>>>>>>> E N T R Y BBSMJD >>>>>>>>>>>>>>>>>>>>>>>> * ENTRY BBSMJD ( STR, STRV, SSCDAG, PTDIAG, PTSHAT, PTW, - PTZ, PTPHI, PTV, PTDELT, PTGAM, PTS, PTR, SSCGAM, STRACN) * TR = STR TRV = STRV SCDIAG = SSCDAG * DIAG = PTDIAG SHAT = PTSHAT W = PTW Z = PTZ PHI = PTPHI V = PTV DELT = PTDELT GAM = PTGAM S = PTS R = PTR * SCGAMM = SSCGAM TRACUN = STRACN * RETURN * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NO FORMATS. C C================================ E N D ================================ * END SUBROUTINE BBUPDT ( N, G, S, XX, GG, H,CT, CNTRST, LASTPT, - IDENTY, NUPS, STEEPD, RSTEP, QNPART, - UPDATT, INNER, IW, RW, DW ) * C================ A R G U M E N T D E C L A R A T I O N S ============ * EXTERNAL INNER * INTEGER N, CT, CNTRST, LASTPT, NUPS, UPDATT, IW(*) * DOUBLE PRECISION G(N), S(N), XX(N), GG(N), H(*) C!!!! REAL G(N), S(N), XX(N), GG(N), H(*) * LOGICAL STEEPD, RSTEP, QNPART, IDENTY * DOUBLE PRECISION DW(*), INNER REAL RW(*) * C============================= S T A T U S ============================= 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 D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C APR. 1, 1987 A. BUCKLEY 1.1 C 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. IF CG IS TRUE, C THEN, IN ADDITION, THE NEGATIVE OF THE NEW SEARCH DIRECTION MUST C BE COMPUTED AND RETURNED IN XX. 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 GG THE GRADIENT AT THE PREVIOUS POINT. C S THE STEP TAKEN ON THE LAST ITERATION. C H THE CURRENT MATRIX H. 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 UPDATT TO INDICATE WHAT TYPE OF QN UPDATES ARE BEING STORED, C I.E. SUM FORM (BBLNIR) OR PRODUCT FORM (NOCEDAL). 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 CNTRST THE NUMBER OF RESTARTS FORCED BY THE TEST DESCRIBED C UNDER HTEST. C NUPS THE NUMBER OF SUM TERMS DEFINING THE CURRENT C UPDATE MATRIX. C QNPART A FLAG WHICH IS TRUE WHEN WE ARE IN THE QUASI-NEWTON C PART OF THE CODE. C C THE VECTOR GG WILL ALSO BE USED AS A SCRATCH VECTOR. 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, OR ELSE, IN THE C EVENT OF A RESTART, H WILL HAVE REDEFINED BY A SINGLE UPDATE TERM. C THUS, THE FOLLOWING VALUES MUST BE SET BEFORE RETURNING: C C XX THE NEGATIVE OF THE NEW SEARCH DIRECTION. 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 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 ======================= C C BBUPDT ... THE NATURAL ENTRY POINT. C BBSUPD ... AN ENTRY TO INITIALIZE FIXED ARGUMENTS. C C======================== S U B R O U T I N E S ======================== C C BBMULT TO MULTIPLY BY A SUM FORM H. C BBNOCE TO MULTIPLY BY A PRODUCT FORM H. C MOD ... AN INTRINSIC. C INNER AN EXTERNAL ARGUMENT. C C========================= P A R A M E T E R S ========================= * * INTEGER SUMFRM, PRDFRM, MJDFRM PARAMETER ( SUMFRM = 1, PRDFRM = 2, MJDFRM = 3 ) DOUBLE PRECISION ZERO, ONE, TWO, THREE C!!!! REAL ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) * DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN C!!!! REAL FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) * DOUBLE PRECISION EIGHT, NINE, TEN C!!!! REAL EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 8D0, TEN = 10D0 ) * LOGICAL DONORM, NONORM PARAMETER ( DONORM = .TRUE., NONORM = .FALSE. ) * C================= L O C A L D E C L A R A T I O N S ================= * C-----CONTROL PARAMETERS FOR ENTRY BBSUPD. * INTEGER M, BASE, INCR, SCGAMM, TRU, SHAT INTEGER SM, SBASE, SINCR, SSGAMM, STRU, SSHAT * 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, ISHAT * DOUBLE PRECISION SIGMA, TP1, TP2, MU, GAMMA, NU, ETA C!!!! REAL SIGMA, TP1, TP2, MU, GAMMA, NU, ETA * C=============================== S A V E =============================== * SAVE M, BASE, INCR, INU, SCGAMM, TRU, - CG, SCDIAG, USESHN, FROMRS, TR7, TR10, TRV * C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA VALUES. C 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 ( 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 AT WHICH TO FORCE THE NEXT RESTART. * IF ( FROMRS .AND. .NOT. USESHN ) THEN LASTPT = 1 + N ELSE LASTPT = M + 1 + N ENDIF * C SINCE A RESTART IS INDICATED, SAVE THE CURRENT S C AND U = H*Y = I*Y = Y = G - GG (THE BEALE RESTART C VECTORS) AND SAVE NU = Y'*H*Y = Y'Y AND ETA = S'Y IN C H(INU) AND H(IETA). I.E. DEFINE H[1]. AFTER A RESTART THE C DIAGONAL SCALING MATRIX IS ALWAYS JUST I. IF M = 0 WE C CAN NOT SAVE UPDATES SO REVERT TO A STEEPEST DESCENT C RESTART. * IF ( M .EQ. 0 ) THEN * DO 2950 J = 1,N XX(J) = G(J) 2950 CONTINUE * CT = 0 NUPS = 0 * ELSE * CT = 1 NUPS = 1 * ENDIF * QNPART = .TRUE. * IF ( SCDIAG ) THEN IDENTY = .TRUE. ENDIF * IF ( M .NE. 0 ) THEN * INU = BASE + 1 IETA = INU + 1 IU = IETA IS = IU + N * DO 3200 J=1,N H(IU+J) = G(J) - GG(J) H(IS+J) = S(J) 3200 CONTINUE * H(INU) = INNER ( N, H(IU+1), H(IU+1), NONORM, IW, RW, DW ) H(IETA) = INNER ( N, H(IU+1), S , NONORM, IW, RW, DW ) * IF(TR7)WRITE(TRU,*) ' [UPDT] SAVED NU, ETA->',H(INU),H(IETA) * ENDIF * C NOW H! IS DEFINED, SO COMPUTE H!*G FOR THE NEXT C SEARCH DIRECTION AND SAVE IT IN XX. CAN'T PUT XX INTO THE C SEARCH DIRECTION JUST YET BECAUSE OF THE "IF SAVE" IN C PHASE X-B. * CALL BBMULT ( H, G, XX, N, NUPS, 1, IDENTY, INNER, IW, RW, DW ) * E L S E I F ( CG .AND. UPDATT .EQ. SUMFRM ) T H E N * C >>>>>>>>>> P H A S E X - B: CG, SUM FORM UPDATE. <<<<<<<<< * C FIRST COMPUTE Y; PUT TEMPORARILY INTO XX. THEN WE MUST C COMPUTE H*Y (INTO GG). NOTE THAT H*Y IS CALLED U. WE C ALSO COMPUTE S'G (IN TP1) AND U'G (IN TP2), 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. * DO 3300 J = 1,N XX(J) = G(J) - GG(J) 3300 CONTINUE * CALL BBMULT ( H, XX, GG, N, NUPS, 1, IDENTY, INNER, IW, RW, DW) * NU = INNER( N, XX, GG, NONORM, IW, RW, DW ) ETA = INNER( N, S, XX, NONORM, IW, RW, DW ) TP1 = INNER( N, G, S, NONORM, IW, RW, DW ) TP2 = INNER( N, G, GG, NONORM, IW, RW, DW ) * C COMPUTE H!*G BY PUTTING H*G INTO XX 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 = 2. * CALL BBMULT (H, G, XX, N, NUPS, 1, IDENTY, INNER, IW, RW, DW ) * IF ( SCGAMM .EQ. 2 ) THEN SIGMA = ( TWO*TP1/ETA) - (TP2/NU) MU = -TP1/NU GAMMA = ETA/NU ELSE SIGMA = ( (ONE + NU/ETA)*TP1 - TP2 ) / ETA MU = -TP1/ETA GAMMA = ONE ENDIF * C NOW COMPUTE H!*G INTO XX. * DO 3700 J = 1,N XX(J) = GAMMA*XX(J) + SIGMA*S(J) + MU*GG(J) 3700 CONTINUE * IF ( QNPART ) THEN * NUPS = NUPS + 1 * C SAVE UPDATE TERMS: PUT NU,ETA,U AND S IN THE ARRAY H. * INU = INU + INCR IETA = INU + 1 IU = IETA IS = IU + N * DO 3900 J = 1,N H(IU+J) = GG(J) H(IS+J) = S(J) 3900 CONTINUE * H(INU) = NU H(IETA) = ETA * IF ( TR7 .OR. TR10 ) WRITE(TRU,*) ' [UPDT] NO RESTART;' - //' NUPS->',NUPS * IF ( TR7 ) WRITE(TRU,*) ' [UPDT] SAVING 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...". * E L S E I F ( CG .AND. UPDATT .EQ. PRDFRM ) T H E N * C >>>>>>>>>> P H A S E X - C: CG, PRODUCT FORM UPDATE. <<<<<<<<< * NUPS = MOD(NUPS,M) IETA = BASE + NUPS*INCR + 1 NUPS = NUPS + 1 IS = IETA IY = IS + N * DO 4100 J = 1,N H(IS+J) = S(J) H(IY+J) = G(J) - GG(J) 4100 CONTINUE * H(IETA) = INNER ( N, S, H(IY+1), NONORM, IW, RW, DW ) * IF ( TR7 .OR. TR10 ) WRITE(TRU,*) ' [UPDT] SAVING NOCEDAL' - //' UPDATE TERM.' * CALL BBNOCE ( H, G, XX, N, NUPS, CT, M, IDENTY, GG, - INNER, IW, RW, DW) * E L S E * C >>>>>>>>>> P H A S E X - D: Q N C A S E.<<<<<<<<<<<<<<<<<< * C A VARIABLE METRIC ALGORITHM IS BEING USED. CALCULATE GRADIENT C DIFFERENCE Y AND ETA = S'Y. SAVE Y IN GG. C S IS THE STEP . * DO 5000 J=1,N GG(J) = G(J) - GG(J) 5000 CONTINUE * ETA = INNER ( N, S, GG, NONORM, IW, RW, DW ) * 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. Y IS IN GG * NU = INNER ( N, GG, GG, NONORM, IW, RW, DW ) * C STORE THE INITIAL HESSIAN, WHICH IS H = (S'Y/Y'Y)*I = C (ETA/NU)*I. SO WE NEED TO RECALCULATE THE INITIAL C NU = Y'*H*Y = (ETA/NU)*(NU ABOVE) = ETA, AND TO C FIND XX = H*Y. Y IS IN GG. * 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*GG(K) * 6000 CONTINUE * NU = ETA * ELSE * C CALCULATE XX[CT] = H*Y AND NU = Y'*H*Y. Y IS IN GG. C REMEMBER THAT ONLY THE SYMMETRIC UPPER HALF OF H IS STORED C (IN ROW ORDER). * NU = ZERO * DO 6500 K = 1,N * TP1 = ZERO KJ = K * DO 6200 J=1,K-1 TP1 = TP1 + H(KJ)*GG(J) KJ = KJ + (N-J) 6200 CONTINUE * DO 6400 J=K,N TP1 = TP1 + H(KJ)*GG(J) KJ = KJ+1 6400 CONTINUE * NU = NU + TP1*GG(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 * DO 7000 K=1,N GG(K) = TP1*S(K) - XX(K) 7000 CONTINUE * 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*GG(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 ============================ C C THERE ARE NO FORMATS USED. C C================================ E N D ================================ * END SUBROUTINE BBVALS ( INTS, LOGS, REALS ) * C================ A R G U M E N T D E C L A R A T I O N S ============ * INTEGER INTS(*) * LOGICAL LOGS(*) * DOUBLE PRECISION REALS(*) C!!!! REAL REALS(*) * C============================= S T A T U S ============================= 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 D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 1 CONTROL OF DERIVATIVE MODE; SEE SECTION 3.13 C XNORM 2 NORM 2 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 TRACUN 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 1 SEE BBLSET IN LISTING OF BBLNIR C XALPS1 10 ALPIS1 1 SEE BBLSET IN LISTING OF BBLNIR C XSCGMM 11 SCGAMM 1 SEE BBLSET IN LISTING OF BBLNIR C XHTEST 12 HTEST 1 SEE BBLSET IN LISTING OF BBLNIR C XUPDTT 13 UPDATT 1 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 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 XRO 33 FLETSC F 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 ======================= C C BBVALS THE NATURAL ENTRY POINT TO RETURN THE VALUES. C BBSVAL AN ENTRY TO RESET THE VALUES. C BBRVAL AN ENTRY TO RESET THE VALUES BY READING NEW DATA IN. C C======================== S U B R O U T I N E S ======================== C C THERE ARE NO SUBROUTINES CALLED. C C========================= P A R A M E T E R S ========================= * * CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) * CHARACTER*(*) PERIOD, DASH, EQUALS PARAMETER ( PERIOD = '.', DASH = '-', EQUALS = '=' ) * 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 ) * DOUBLE PRECISION RTRUE, RFALSE C!!!! REAL RTRUE, RFALSE PARAMETER ( RTRUE = 1.D0, RFALSE = 0.D0 ) * C-----FOR ZZEVAL. * LOGICAL TRF, TRG, TRTEST PARAMETER ( TRF = F, TRG = F, TRTEST = F ) * INTEGER ETRACU, SCALE, DERVMD PARAMETER ( ETRACU = 6, SCALE = 0, DERVMD = 1 ) * C-----FOR ZZPRNT. * LOGICAL GRAD, POINT PARAMETER ( GRAD = T, POINT = T ) * INTEGER PTRACU PARAMETER ( PTRACU = 6 ) * C-----FOR ZZTERM. * INTEGER NORM, TTRACU PARAMETER ( NORM = 2, 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-----FOR BBLNIR. * INTEGER METH, QUADIN, ALPIS1, STSTEP PARAMETER ( METH = 0, QUADIN = 1, ALPIS1 = 1, STSTEP = 2 ) * INTEGER SCGAMM, HTEST, UPDATT PARAMETER ( SCGAMM = 1, HTEST = 1, UPDATT = 1 ) * DOUBLE PRECISION RO, BETA C!!!! REAL 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 PARAMETER ( LTRACU = ETRACU ) * LOGICAL TRACE, TRCCUB PARAMETER ( TRACE = F, TRCCUB = F ) * C================= L O C A L D E C L A R A T I O N S ================= * INTEGER KEEPI(NINTS), SINTS(NINTS), I, RUNIT, WUNIT, SANAL * LOGICAL KEEPL(NLOGS), SLOGS(NLOGS), ON, OFF * CHARACTER*(NLOGS) CHECK * DOUBLE PRECISION KEEPR(NREALS), SREALS(NREALS) C!!!! REAL KEEPR(NREALS), SREALS(NREALS) * C=============================== S A V E =============================== * SAVE * C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== * 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----DEFINE A 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 * DO 300 I = 1,NREALS REALS(I) = KEEPR(I) 300 CONTINUE * GOTO 90000 * C>>>>>>>>>>>>>>>>>>>>>>>>>> E N T R Y BBRVAL <<<<<<<<<<<<<<<<<<<<<<<<<< * 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. * ENTRY BBRVAL (WUNIT, RUNIT) * 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 ZZLCUC (CHECK) * 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 * DO 600 I = 1,NREALS KEEPR(I) = SREALS(I) 600 CONTINUE * 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 ============================ C C THERE ARE NO FORMATS USED. C C================================ E N D ================================ * END SUBROUTINE BBVSCG( FUNCNM, N, X, F, G, ACCT, STATUS, ITERS, FNCCT, - WORK, LWORK ) * C================ A R G U M E N T D E C L A R A T I O N S ============ * EXTERNAL FUNCNM * INTEGER N, STATUS, ITERS, FNCCT, LWORK * DOUBLE PRECISION X(N), F, G(N), ACCT, WORK(LWORK+1), FUNCNM C!!!! REAL X(N), F, G(N), ACCT, WORK(LWORK+1) * C============================= S T A T U S ============================= 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 D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C APR. 2, 1987 A. BUCKLEY 1.1 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 IMPROVE 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. 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 C======================= E N T R Y P O I N T S ======================= C C BBVSCG ... THE NATURAL ENTRY POINT. C BBVIDF ... AN ENTRY TO REDEFINE THE ENTRY STATUS CODES. C BBVSDF ... AN ENTRY TO 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 ZZINNR ...FOR COMPUTING EUCLIDEAN INNER PRODUCTS. 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 ) DOUBLE PRECISION ZERO, ONE, TWO, THREE C!!!! REAL ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0D0, ONE = 1D0, TWO = 2D0, THREE = 3D0) * DOUBLE PRECISION FOUR, FIVE, SIX, SEVEN C!!!! REAL FOUR, FIVE, SIX, SEVEN PARAMETER ( FOUR = 4D0, FIVE = 5D0,SIX = 6D0, SEVEN = 7D0) * DOUBLE PRECISION EIGHT, NINE, TEN C!!!! REAL EIGHT, NINE, TEN PARAMETER ( EIGHT = 8D0, NINE = 8D0, TEN = 10D0 ) * C================= L O C A L D E C L A R A T I O N S ================= * EXTERNAL ZZINNR * 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! REAL RW(1) C1!!! DOUBLE PRECISION DW(1) * DOUBLE PRECISION ZZINNR * DOUBLE PRECISION DECRF, TT, TIME C!!!! REAL 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 ============================= C C THERE ARE NO COMMON BLOCKS. C 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 ========================== * 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,RW,WORK(LWORK+1)) C!!!!- WORK(ID), WORK(IX), WORK(IG), WORK(IH),HDIM,IW,WORK(LWORK+1),DW) * C-----RESET TIME, ITERATION COUNT AND FUNCTION COUNT BEFORE RETURN. * IF ( STATUS .NE. RCF .AND. STATUS .NE. RCFG - .AND. STATUS .NE. PSBACK .AND. STATUS .NE. RCG ) THEN * CALL ZZEGET( FNCT, GRCT, TIME ) CALL ZZPGET( TIME, ITCT ) CALL ZZSECS( TIME ) ACCT = TIME - TT FNCCT = FNCT ITERS = ITCT ENDIF * GOTO 90000 * C>>>>>>>>>>>>>>>>>>>>>>>>>> E N T R Y BBVIDF <<<<<<<<<<<<<<<<<<<<<<<<<< * C 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 ============================ C C THERE ARE NO FORMATS USED. C C================================ E N D ================================ * END DOUBLE PRECISION FUNCTION ZZMPAR(I) C!!!! REAL FUNCTION ZZMPAR(I) * C============== A R G U M E N T D E C L A R A T I O N S ============== * INTEGER I * C============================= S T A T U S ============================= 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 CONVERSION FOR SINGLE OR DOUBLE PRECISION: REQUIRED (SEE CONVRT) C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZMPAR C C======================== S U B R O U T I N E S ======================== C C NO SUBROUTINES OR FUNCTIONS ARE CALLED C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * 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(4) C!!!! INTEGER MCHEPS(2) * INTEGER MINMAG(4) C!!!! INTEGER MINMAG(2) * INTEGER MAXMAG(4) C!!!! INTEGER MAXMAG(2) * DOUBLE PRECISION DMACH(3) C!!!! REAL RMACH(3) * C=============================== S A V E =============================== * SAVE DMACH C!!!! SAVE RMACH * C======================= E Q U I V A L E N C E S ======================= * EQUIVALENCE (DMACH(1),MCHEPS(1)) C!!!! EQUIVALENCE (RMACH(1),MCHEPS(1)) * EQUIVALENCE (DMACH(2),MINMAG(1)) C!!!! EQUIVALENCE (RMACH(2),MINMAG(1)) * EQUIVALENCE (DMACH(3),MAXMAG(1)) C!!!! EQUIVALENCE (RMACH(3),MAXMAG(1)) * C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C-----MACHINE CONSTANTS FOR THE SUN-4. * DATA DMACH(1) /1.11022302D-16 / C!!!! DATA MCHEPS(1),MCHEPS(2) / 9472, 0 / C!!!! DATA MCHEPS(1) / 13568 / * DATA DMACH(2) /4.94065646D-324 / C!!!! DATA MINMAG(1),MINMAG(2) / 128, 0 / C!!!! DATA MINMAG(1) / 128 / * DATA DMACH(3) /1.79769313D+308 / C!!!! DATA MAXMAG(1),MAXMAG(2) / -32769, -1 / C!!!! DATA MAXMAG(1) / -32769 / * C========================== E X E C U T I O N ========================== * ZZMPAR = DMACH(I) C!!!! ZZMPAR = RMACH(I) * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZSECS(SECS) * C============== A R G U M E N T D E C L A R A T I O N S ============== * DOUBLE PRECISION SECS C!!!! REAL SECS * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR CPU USAGE. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR SUN4 C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: REQUIRED (SEE CONVRT) C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C 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 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 C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZSECS C C======================== S U B R O U T I N E S ======================== C C A SYSTEM CLOCK. C 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 A R A T I O N S ================= * 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 ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== * DATA FIRST/.TRUE./ * 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 = DBLE(SEC) C!!!! SECS = SEC * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END PROGRAM TESTBB * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: ISOLATED INTO 5 SMALL SUBROUTINES 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 REVISION STATUS: DATE AUTHOR VERSION C C OCT. 30, 1988 A. BUCKLEY 1.1 C C======================== D E S C R I P T I O N ======================== C C THIS IS A ROUTINE PROVIDED TO TEST BBVSCG AND BBLNIR AFTER C INSTALLATION ON A PARTICULAR SYSTEM. IT CALLS BBVSCG AND BBLNIR C TO MINIMIZE A COLLECTION OF 10 TEST FUNCTIONS WHICH ARE PROVIDED C IN ZZFNS. C C IT ALSO SERVES AS A MODEL TO ILLUSTRATE THE USE OF SOME OF THE C FEATURES OF THE MINIMIZATION ALGORITHM IMPLEMENTATION. C C FOR AN EXAMPLE OF THE CODING OF A TEST FUNCTION, SEE THE ROUTINE C ZZFNS. TO SEE HOW TO CHANGE THE INTEGER COMMUNICATION PARAMETERS C (ESSENTIALLY LIKE ENUMERATED TYPES OF PASCAL), SEE THE EXAMPLES C BELOW AT FORTRAN LABEL 19. C C EACH FUNCTION IS MIMIMIZED SEVERAL TIMES. BOTH BBVSCG AND C BBLNIR ARE CALLED. TESTS INVOLVE ANALYTIC AND DIFFERENCED DERI- C VATIVES AND USE BOTH FORWARD AND REVERSE COMMUNICATION. BOTH THE C CONJUGATE GRADIENT AND QUASI-NEWTON CODES ARE TRIED AS WELL AS C THE NOCEDAL UPDATES. C C----- SUMMARY OF TESTS. C C 1. SIMPLE CALL TO BBVSCG, ANALYTIC DERIVATIVES, FORWARD CALLS. C 2. SIMPLE CALL TO BBVSCG, ANALYTIC DERIVATIVES, REVERSE CALLS. C 3. SIMPLE CALL TO BBVSCG, FINITE DIFFERENCES, FORWARD CALLS. C 4. SIMPLE CALL TO BBVSCG, DERIVATIVE TESTING, FORWARD CALLS. C C 5. DIRECT CALL TO BBLNIR, ANALYTIC, FORWARD, METH = 2. C 6. DIRECT CALL TO BBLNIR, ANALYTIC, REVERSE, METH = -2. C C 7. SIMPLE CALL TO BBVSCG, ANALYTIC DERIVATIVES, NOCEDAL UPDATES. C C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT TESTBB C C======================== S U B R O U T I N E S ======================== C C BBVSCG C C BBLNIR ( AND ENTRY POINTS THEREIN ) C C BBDFLT C C ZZEVAL ( AND ENTRY POINT ZZECHK THEREIN ) C C ZZFNS ( ALSO THROUGH ENTRY POINTS ZZFSET AND ZZFPAR) C ZZDATE C ZZDTTM C ZZLENG C ZZLCUC C ZZSHFT C ZZTIME C C ZZSECS C C BARD70, BIGGS6, BOX663, CRGLVY, ENGVL2! A SUBSET OF A FULL COLL- C PENAL1, PENAL2, PWSING, ROSENB, SCHMVT! ECTION OF TEST FUNCTIONS C C========================= P A R A M E T E R S ========================= * * 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-----DEFINE AMOUNT OF WORKING STORAGE. * INTEGER EXTRA, MXN, LWORK PARAMETER ( EXTRA = 20, MXN = 40, LWORK = (MXN*(MXN+7))/2 ) * C-----SET UNITS FOR TERMINAL INPUT/OUTPUT FOR CONTROL. C OUTPT IS FOR OUTPUT FROM TEST; SAVED ON A FILE. * 11 INTEGER TRMINP, TRMOUT, OUTPT PARAMETER ( TRMINP = 5, TRMOUT = 6, OUTPT = 8 ) * C-----DEFINE TOTAL NUMBER OF ALLOWABLE FUNCTION ARGUMENTS. * * INTEGER FNO PARAMETER ( FNO = 10 ) * C-----DEFINE TOTAL NUMBER OF TESTS AND PROBLEMS. * INTEGER TESTS, NPROBS, TTESTS PARAMETER ( TESTS = 7, NPROBS = 10, TTESTS = TESTS*NPROBS ) * C-----FOR ZZEVAL: NUMBER OF FUNCTION EVALUATIONS. * INTEGER MAX PARAMETER ( MAX = 300 ) * C-----FOR ZZPRNT: FIRST AND LAST FUNCTION VALUES PRINTED. * INTEGER PFREQ PARAMETER ( PFREQ = -1000 ) * C-----FOR ZZTERM: ACCURACY REQUIREMENT. * REAL ACC C!!!! DOUBLE PRECISION ACC PARAMETER ( ACC = 5.D-4 ) * C-----FOR BBLNIR: ESTIMATE OF FUNCTION REDUCTION. * REAL DECRF C!!!! DOUBLE PRECISION DECRF PARAMETER ( DECRF = -1.0D0 ) * C---- MISCELLANEOUS CONSTANTS (NOT ALL USED). * 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 = 8D0, 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 C!!!! DOUBLE PRECISION R1P2 PARAMETER ( R1P2 = 1.2D0 ) * 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======================= D E C L A R A T I O N S ======================= * C---- DEFINE THE ARRAYS FOR REVISING CONTROL PARAMETERS. * INTEGER INTS(NINTS) LOGICAL LOGS(NLOGS) * REAL REALS(NREALS) C!!!! DOUBLE PRECISION REALS(NREALS) * C---- DEFINE THE IW, RW, DW ARRAYS AND THE INNER PRODUCT ROUTINE. * INTEGER IW(EXTRA) REAL RW(EXTRA) DOUBLE PRECISION DW(EXTRA), ZZINNR EXTERNAL ZZINNR * C---- PLACES TO HOLD SOME STATISTICS AND STUFF FROM THE TESTS. * INTEGER ICNTS(TTESTS), FCNTS(TTESTS), FNCT, GRCT, ITCT * REAL FVALS(TTESTS), ACCTIM C!!!! DOUBLE PRECISION FVALS(TTESTS), ACCTIM * INTEGER DIM(NPROBS), IFNC(NPROBS), INDX(NPROBS), COMPNT(NPROBS) * C---- VALUES USED TO REDEFINE COMMUNICATION PARAMETERS. * INTEGER ANAL, DIFF, TEST, DOFG INTEGER NORMFG, NORMAL, RCSTRT, RCRPT, RCNOFG, PSTHRU INTEGER DONE, RCF, RCFG, RCG, NOSTOR, IPMIN, IPUNDF INTEGER BDMETH, LSFAIL, NODESC, XSFUNC, RABORT, USERV, PSBACK * C---- VARIOUS DECLARATIONS NEEDED TO RUN THE TESTS. * INTEGER N, STATUS, METH, ERROR, I, M, ID, IX ,UNIT INTEGER IG, IH, DERVMD, DINDX, DCOMP, CASE, CONTRL, FROM, TO INTEGER ITERS, FUNCS, FREQ, PDONE, TFNCS, TITERS * REAL X(MXN), G(MXN), WORK(LWORK+EXTRA), DERERR(NPROBS) C!!!! DOUBLE PRECISION X(MXN), G(MXN), WORK(LWORK+EXTRA), DERERR(NPROBS) * REAL FX, DERR, TIME, AVERRS(NPROBS), AVERR C!!!! DOUBLE PRECISION FX, DERR, TIME, AVERRS(NPROBS), AVERR * REAL FARG(FNO), RPAR1(NPROBS), RPAR2(NPROBS), ACCT C!!!! DOUBLE PRECISION FARG(FNO), RPAR1(NPROBS), RPAR2(NPROBS), ACCT * CHARACTER*52 TITLE(TESTS) CHARACTER*41 DATE CHARACTER*4 QUITS * EXTERNAL ZZFNS * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== * C---- DIMENSIONS OF THE TEST PROBLEMS. * DATA DIM / 3, 6, 3, 4, 3, 10, 10, 40, 2, 3 / * C---- NUMBERS OF THE TEST PROBLEMS. * DATA IFNC / 26, 11, 16, 27, 25, 40, 41, 3, 1, 24 / * C---- ARGUMENTS NEEDED FOR THE TEST PROBLEMS. * DATA RPAR1 / 0.D0, 13.D0, 10.D0, 2*0.D0, 2*1.D-5, 3*0D0/ * DATA RPAR2 / 5*0.D0, 2*1.D0, 3*0.D0 / * DATA FARG / FNO * 1.D0 / * C---- OUTPUT IDENTIFICATION. * DATA TITLE - -/ ' CALL BBVSCG, ANALYTIC MODE, FORWARD CALLS.' , - ' CALL BBVSCG, ANALYTIC MODE, REVERSE CALLS.' , - ' CALL BBVSCG, DIFFERENCING, FORWARD CALLS.' , - ' CALL BBVSCG, TESTING MODE, FORWARD CALLS.' , - ' CALL BBLNIR, ANALYTIC MODE, FORWARD CALLS; METH= 2.' , - ' CALL BBLNIR, ANALYTIC MODE, REVERSE CALLS; METH=-2.' , - ' CALL BBVSCG, ANALYTIC MODE, NOCEDAL UPDATES.' / * C========================== E X E C U T I O N ========================== * C WE BEGIN BY REDEFINING THE INTEGER (ENUMERATED) CONTROL PARAMETERS C USED FOR INTER-PROGRAM COMMUNICATION. THE VALUES SET HERE ARE C DIFFERENT THAN THE DEFAULTS. NORMALLY THEY ARE NOT CHANGED UNLESS C THE DEFAULTS CONFLICT WITH THE USER'S PROGRAMS. THEY ARE CHANGED C HERE ONLY FOR ILLUSTRATIVE PURPOSES. OF COURSE, WE MUST BE CAREFUL C TO USE THE VALUES OF THE CODES AS WE DEFINE THEM. SEE, FOR EXAMPLE C LABELS 5200 AND 5333. * C ENTRY BBLDDF ( ANAL, DIFF, TEST, SFIRST ) 19 ANAL = 2 DIFF = 3 TEST = 4 CALL BBLDDF ( ANAL, DIFF, TEST, -1 ) * C ENTRY BBLFDF ( DOF, DOG, DOFG, NONE ) DOFG = 3 CALL BBLFDF ( 1, 2, DOFG, 0 ) C REDEFINE CODES IN TEST ROUTINE ZZFNS WHICH IS PROVIDED AS WELL. CALL ZZFFDF ( 1, 2, DOFG, 0 ) * C ENTRY BBLIDF ( SNRMFG, SNORML, SRCSTR, SRCRPT, SRCNFG, SPSTHR ) CALL BBLIDF ( -1, -2, 1, 2, 0, 99 ) NORMFG = -1 NORMAL = -2 RCSTRT = 1 RCRPT = 2 RCNOFG = 0 PSTHRU = 99 * C ENTRY BBLSDF ( SDONE, SRCF, SRCFG, SRCG, SNSTOR, SIPMIN, C - SIPUNF, SBDMTH, SLSFAL, SNODSC, SXSFNC, SRABRT, SUSERV, SPSBCK) CALL BBLSDF (0, 1, 2, 3, -1, -2, -3, -4, -5, -6, -7, -8, -9, 99) DONE = 0 RCF = 1 RCFG = 2 RCG = 3 NOSTOR = -1 IPMIN = -2 IPUNDF = -3 BDMETH = -4 LSFAIL = -5 NODESC = -6 XSFUNC = -7 RABORT = -8 USERV = -9 PSBACK = 99 * C ENTRY BBLRDF ( SOK, SABORT, SLIMIT, SNOF, SNOG, SNOFG ) CALL BBLRDF ( 0, 1, 2, 3, 4, 5 ) * C---- INITIALIZE TIMING. * CALL ZZSECS (TIME) ACCTIM = ZERO * OPEN ( OUTPT, FILE = 'RESULTS' ) CALL ZZDTTM (DATE) WRITE ( OUTPT, 99993 ) ' STARTING TEST AT ', DATE( 1:10), ' ON ', - DATE(12:41) * C INITIALIZE COUNTS. * ERROR = 0 PDONE = 0 TFNCS = 0 TITERS = 0 FREQ = PFREQ * DO 20 I = 1, TTESTS FVALS(I) = ZERO FCNTS(I) = 0 ICNTS(I) = 0 20 CONTINUE * C---- ASK FOR CHANGES TO CONTROL PARAMETERS. EOF SUFFICIENT IF C NONE REQUIRED. * CALL BBRVAL ( TRMOUT, TRMINP ) * C REDEFINE THE OUTPUT UNIT BY GETTING THE CURRENT VALUES C FROM BBVALS AND RESETTING IT BY CALLING BBSVAL. THIS MAKES C SURE *ALL* OUTPUT GOES TO UNIT OUTPT. THIS IS GENERALLY C NOT NECESSARY. OUTPUT IS SENT TO A DEFAULT VALUE. * UNIT = OUTPT 22 CALL BBVALS ( INTS, LOGS, REALS ) INTS(XPTRCU) = UNIT INTS(XLTRCU) = UNIT INTS(XETRCU) = UNIT CALL BBSVAL ( INTS, LOGS, REALS ) * C---- DO MINIMIZATIONS. RUN EACH OF THE TEST TYPES. * FROM = 0 TO = NPROBS CONTRL = 0 * DO 9000 M = 1,TESTS * C WRITE TITLE, UNLESS NO OUTPUT REQUESTED. * IF ( FREQ .NE. 0 ) WRITE ( UNIT, 99999 ) M, TITLE(M) * C HERE WE HAVE A CHANCE TO CHOOSE A SUBSET OF THE PROBLEMS C TO TEST. * 50 IF ( CONTRL .NE. -3 ) THEN CONTRL = -3 WRITE(TRMOUT,*) ' CONTROL: 0 QUIT' WRITE(TRMOUT,*) ' -1 SKIP TO NEXT SET,' WRITE(TRMOUT,*) ' -2 FINISH THIS SET' WRITE(TRMOUT,*) ' -3 (OR EOF) FINISH FULL RUN' WRITE(TRMOUT,*) ' N > 0 DO PROBLEM #N' READ(TRMINP,'(BN,I2)', END=59 ) CONTRL ENDIF * 59 IF ( CONTRL .GT. 0 ) THEN FROM = CONTRL TO = CONTRL ELSE IF ( CONTRL .EQ. 0 ) THEN GOTO 10000 ELSE IF ( CONTRL .EQ. -1 ) THEN FROM = 0 TO = NPROBS GOTO 8500 ELSE IF ( CONTRL .EQ. -2 ) THEN FROM = MOD(TO,NPROBS)+1 TO = NPROBS ELSE IF ( CONTRL .EQ. -3 ) THEN FROM = MOD(TO,NPROBS)+1 TO = NPROBS ENDIF * C START TIMING. * CALL ZZSECS(TIME) ACCTIM = ACCTIM - TIME * C REPEAT FOR EACH TEST FUNCTION SELECTED. * DO 6000 I = FROM,TO * PDONE = PDONE + 1 IF (PDONE .GT. TTESTS) THEN WRITE ( UNIT, * ) ' TOO MANY TESTS: STOPPING.' GOTO 90000 ENDIF * IF ( FREQ .NE. 0 ) WRITE ( UNIT, 99994 ) I * C ---SET FUNCTION NUMBER IN ZZFNC AND SET FUNCTION ARGUMENTS. C THIS ILLUSTRATES HOW TO DEFINE THE AMOUNT OF EXTRA C STORAGE AVAILABLE. IT IS ONLY NEEDED FOR TEST 7. * IF ( I .EQ. 7 ) THEN CALL ZZFSET ( IFNC(I), EXTRA ) ELSE CALL ZZFSET ( IFNC(I), 1 ) ENDIF * FARG(1) = RPAR1(I) FARG(2) = RPAR2(I) * CALL ZZFPAR ( FARG ) * C ---SET DIMENSION. * N = DIM(I) * C ---SET STARTING POINT. * * GOTO ( 100,200,300,400,500,600,700,800,900,1000) I * 100 X(1) = ONE X(2) = ONE X(3) = ONE * GOTO 5000 * 200 X(1) = ONE X(2) = TWO X(3) = ONE X(4) = ONE X(5) = ONE X(6) = ONE * GOTO 5000 * 300 X(1) = ZERO X(2) = TEN X(3) = R20 * GOTO 5000 * 400 X(1) = ONE X(2) = TWO X(3) = TWO X(4) = TWO * GOTO 5000 * 500 X(1) = ONE X(2) = TWO X(3) = ZERO * GOTO 5000 * 600 DO 650 ID = 1,N X(ID) = ID 650 CONTINUE * GOTO 5000 * 700 DO 750 ID = 1,N X(ID) = HALF 750 CONTINUE * GOTO 5000 * 800 DO 850 ID = 1,N/4 X(4*ID-3) = THREE X(4*ID-2) = - ONE X(4*ID-1) = ZERO X(4*ID ) = ONE 850 CONTINUE * GOTO 5000 * 900 X(1) = -R1P2 X(2) = ONE * GOTO 5000 * 1000 X(1) = HALF X(2) = HALF X(3) = HALF * GOTO 5000 * C ---SET UP CALLS TO MINIMIZE. TESTS 5 AND 6 CALL C BBLNIR DIRECTLY. THE OTHERS CALL BBVSCG. * 5000 GOTO ( 5100, 5200, 5300, 5400, 5500, 5600, 5425 ) M * C TEST 1 THE SIMPLEST CALL. 5100 DERVMD = ANAL STATUS = NORMAL GOTO 5450 * C TEST 2 USING REVERSE COMMUNICATION. 5200 DERVMD = DIFF STATUS = RCSTRT * C MUST INITIALIZE BEFORE CALL TO ZZEVAL. CALL BBDFLT ( FREQ, MAX ) CASE = DOFG CALL ZZEVAL ( ZZFNS, N, X, FX, G, CASE, IW, RW, DW ) * GOTO 5450 * C TEST 3 HERE WE SEE HOW TO REDEFINE THE METHOD OF COMPUTING C DERIVATIVES. FOR CONVENIENCE, A SET OF NAMED INTEGER C INDICES IS PROVIDED FOR ACCESSING THE APPROPRIATE C ENTRIES OF EACH ARRAY. THESE ARE DOCUMENTED IN BBVALS. * 5300 CONTINUE * 5333 DERVMD = DIFF CALL BBVALS ( INTS, LOGS, REALS ) INTS(XDRVMD) = DERVMD CALL BBSVAL ( INTS, LOGS, REALS ) STATUS = NORMAL * GOTO 5450 * C TEST 4 TEST THE DERIVATIVE CALCULATIONS. 5400 DERVMD = TEST CALL BBVALS ( INTS, LOGS, REALS ) INTS(XDRVMD) = DERVMD CALL BBSVAL ( INTS, LOGS, REALS ) STATUS = NORMAL * GOTO 5450 * C TEST 7 HERE WE USE THE SAME TECHNIQUE TO RESET C THE MINIMIZATION METHOD, THE UPDATE C STRATEGY AND THE DERIVATIVE MODE. THIS C TESTS NOCEDAL'S UPDATE STRATEGY. 5425 DERVMD = ANAL * CALL BBVALS ( INTS, LOGS, REALS ) INTS(XMETH ) = 2 INTS(XUPDTT) = 2 INTS(XDRVMD) = DERVMD CALL BBSVAL ( INTS, LOGS, REALS ) STATUS = NORMAL * GOTO 5450 * 5450 CONTINUE * ITERS = FREQ FUNCS = MAX ACCT = ACC * 5460 CALL BBVSCG ( ZZFNS, N, X, FX, G, ACCT, STATUS, - ITERS, FUNCS, WORK, LWORK ) * C CHECK FOR REVERSE COMMUNICATION TEST IF ( M .EQ. 2 .AND. STATUS .EQ. RCFG ) THEN * C RE-EVALUATE F AND G. CASE = DOFG CALL ZZEVAL ( ZZFNS, N, X, FX, G, CASE, IW, RW, DW ) * C AND RE-ENTER BBVSCG. STATUS = RCRPT * GOTO 5460 * ELSE IF ( M .EQ. 4 ) THEN C GET TESTING INFO. CALL ZZECHK ( DERR, AVERR, DCOMP, DINDX ) * DERERR(I) = DERR AVERRS(I) = AVERR COMPNT(I) = DCOMP INDX (I) = DINDX * ENDIF * GOTO 5900 * C TEST 5 AGAIN WE SEE HOW TO REDEFINE THE METHOD OF COMPUTING C DERIVATIVES. FOR CONVENIENCE, A SET OF NAMED INTEGER C INDICES IS PROVIDED FOR ACCESSING THE APPROPRIATE C ENTRIES OF EACH ARRAY. THESE ARE DOCUMENTED IN BBVALS. C HERE WE ARE CALLING BBLNIR DIRECTLY. * 5500 DERVMD = ANAL CALL BBVALS ( INTS, LOGS, REALS ) INTS(XDRVMD) = DERVMD CALL BBSVAL ( INTS, LOGS, REALS ) STATUS = NORMAL C REDEFINE THE ALGORITHM STRATEGY. METH = 2 * GOTO 5650 * C TEST 6 LIKE TEST 5, BUT WITH REVERSE COMMUNICATION AND C A DIFFERENT METHOD. 5600 DERVMD = ANAL STATUS = RCSTRT METH = -2 * GOTO 5650 * C DIRECT CALL TO BBLNIR. FIRST GET CURRENT SETTINGS. 5650 CALL BBVALS ( INTS, LOGS, REALS ) * C THEN INITIALIZE ZZEVAL. CALL ZZESET ( LOGS(XTRF), LOGS(XTRG), LOGS(XTRTST), - INTS(XETRCU) ) CALL ZZESRT ( INTS(XSCALE), DERVMD, MAX ) C THEN INITIALIZE ZZPRNT. CALL ZZP1ST ( INTS(XPTRCU), LOGS(XGRAD), LOGS(XPOINT), - FREQ ) CALL ZZP2ST ( INTS(XPTRCU), LOGS(XGRAD), LOGS(XPOINT), 0 ) * C THEN INITIALIZE ZZTERM. QUITS = 'FFFF' IF ( LOGS(XTGRAD) ) QUITS(1:1) = 'T' IF ( LOGS(XTSTEP) ) QUITS(2:2) = 'T' IF ( LOGS(XTSHXG) ) QUITS(3:3) = 'T' IF ( LOGS(XTFUNC) ) QUITS(4:4) = 'T' CALL ZZTSET (INTS(XNORM), QUITS, LOGS(XTTRCE), INTS(XTTRCU)) * C INITIALIZE BBLNIR THROUGH ENTRY POINT. HERE ALL THE C VALUES ARE TAKEN FROM THOSE STORED IN BBVALS. IN C MOST APPLICATIONS, VALUES WOULD BE DIRECTLY INPUT BY C THE USER FOR THOSE VALUES HE WISHED TO CHANGE. CALL BBLSET ( METH, 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) ) * C DEFINE THE WORKING ARRAY SIZES. ID = 1 IX = ID + N IG = IX + N IH = IG + N * C INITIAL FUNC/GRAD VALUES FOR REVERSE COMMUNICATION. IF ( STATUS .EQ. RCSTRT ) THEN CASE = DOFG CALL ZZEVAL ( ZZFNS,N,X,FX, G, CASE, IW, RW, DW ) ENDIF * 5690 ACCT = ACC CALL BBLNIR(ZZFNS, N, X, FX, DECRF, G, ACCT, STATUS, ZZINNR, - WORK(ID), WORK(IX), WORK(IG), WORK(IH), LWORK-3*N, - IW, RW, DW ) * C CHECK FOR REVERSE COMMUNICATION TEST IF ( M .EQ. 6 .AND. STATUS .EQ. RCRPT ) THEN * C RE-EVALUATE F AND G. CASE = DOFG CALL ZZEVAL( ZZFNS, N, X, FX, G, CASE, IW, RW, DW ) * C AND RE-ENTER BBVSCG. STATUS = RCRPT GOTO 5690 * ENDIF * C ALL TESTS: ADD NUMBER OF ERRORS. * 5900 IF ( STATUS .NE. DONE ) THEN ERROR = ERROR + 1 ENDIF * C GET STATISTICAL COUNTS. CALL ZZEGET( FNCT, GRCT, ACCTIM ) CALL ZZPGET( ACCTIM, ITCT ) * FVALS(PDONE) = FX FCNTS(PDONE) = FNCT ICNTS(PDONE) = ITCT * TFNCS = TFNCS + FNCT TITERS = TITERS + ITCT * IF ( FREQ .NE. 0 ) WRITE ( UNIT, 99997 ) STATUS * 6000 CONTINUE CALL ZZSECS(TIME) ACCTIM = ACCTIM + TIME * 8000 IF ( M .EQ. 4 ) THEN IF ( FREQ .NE. 0 ) WRITE ( UNIT, 99998 ) - (DERERR(I),COMPNT(I),INDX(I),AVERRS(I),I = 1,NPROBS) ENDIF * 8500 IF ( TO .NE. NPROBS ) GOTO 50 * 9000 CONTINUE * 10000 WRITE ( UNIT, 99991 ) WRITE ( UNIT, 99992 ) (I,ICNTS(I),FVALS(I),FCNTS(I),I=1,PDONE) * CALL ZZSECS (TIME) WRITE ( UNIT, 99995 ) ACCTIM, TIME WRITE ( UNIT, 99996 ) PDONE, ERROR, TFNCS, TITERS WRITE ( TRMOUT, * ) ' ' WRITE ( TRMOUT, * ) ' ' WRITE ( TRMOUT, * ) ' ' WRITE ( TRMOUT, 99995 ) ACCTIM, TIME * CALL ZZDTTM (DATE) WRITE( TRMOUT, 99993 ) ' TEST ENDED AT ', DATE(1:10), ' ON ', - DATE(12:41) WRITE( UNIT, 99993 ) ' TEST ENDED AT ', DATE(1:10), ' ON ', - DATE(12:41) * C=============================== E X I T =============================== * 90000 STOP * C============================ F O R M A T S ============================ * 99991 FORMAT (// ' RN ITS FUNCT. VALUE FNS |', - ' RN ITS FUNCT. VALUE FNS |', - ' RN ITS FUNCT. VALUE FNS'/ - ' ------------------------|', - '-------------------------|', - '------------------------') * 99992 FORMAT ( (2(I3,I4,1X,E12.6,I4,' |'), (I3,I4,1X,E12.6,I4) )) * 99993 FORMAT ( 4A // ) * 99994 FORMAT ( /' FUNCTION #', I2 / ) * 99995 FORMAT (/' TIME USED WAS ', F12.3, ' SECONDS WITHOUT PROMPTS;'/ - ' ', F12.3, ' TOTAL.' ) * 99996 FORMAT ( // ' *****TEST FINISHED**** PROBLEMS DONE ',I3, - '; NUMBER OF ERRORS IS ',I2,'.' / - ' TOTAL FUNCTION CALLS = ',I4, - ' TOTAL ITERATIONS = ', I4 // ) * 99997 FORMAT ( /' ************* RUN COMPLETE, STATUS = ', I3, '.'/ ) * 99998 FORMAT ( //' TESTING MODE DERIVATIVE ESTIMATION ERRORS' // - ' MAX ERROR COMPONENT ITERATE AV. DECIMALS ' // - 10 ( E10.2, I7, 7X, I5, F9.2 /) ) * 99999 FORMAT ( '1 BEGINNING RUN #', I1, ':', A ) * C================================ E N D ================================ * END SUBROUTINE ZZDATE (CHDATE) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER *(*) CHDATE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM ROUTINE FOR DATE. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR CYBER/FTN5 C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 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 C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZDATE C C======================== S U B R O U T I N E S ======================== C C SYSTEM DATE ROUTINE. C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * CHARACTER * 10 DATE * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA VALUES. C 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZDTTM ( CHDATE ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER *(*) CHDATE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: NONE C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 1, 1985 A. BUCKLEY 1.0 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZDTTM C 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 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 A R A T I O N S ================= * 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 ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== * 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 ========================== * 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 ============================ C C THERE ARE NO FORMATS USED. C C================================ E N D ================================ * END 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 D E C L A R A T I O N S ============== * INTEGER N, IFG, IW(*) * REAL F, X(N), G(N), WORK(*) C!!!! DOUBLE PRECISION F, X(N), G(N), WORK(*) * C *** NOTE THAT THESE ARE **DELIBERATELY** OPPOSITE TO OTHER PAIRS. DOUBLE PRECISION DUMMY(*) C!!!! REAL DUMMY(*) * C============================= S T A T U S ============================= 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 REVISION STATUS: DATE AUTHOR VERSION C C JUN. 1, 1985 A. BUCKLEY 1.0 C C======================== D E S C R I P T I O N ======================== C C THIS TEST FUNCTION EVALUATES ONE OF THE STANDARD TEST C FUNCTIONS PROVIDED WITH TESTPACK. THE ARGUMENTS IN THE CALLING C SEQUENCE HAVE PRECISELY THE SAME MEANING AS IN THE ROUTINE ZZEVAL. C C THE TEST FUNCTION TO USE IS SELECTED BY CALLING THE ENTRY C POINT ZZFSET ( FUNCNO ). THE VALUE OF THE INTEGER, FUNCNO, C SPECIFIES WHICH OF THE TEST FUNCTIONS IS TO BE USED; THE FUNCTION C IS CHOSEN USING A COMPUTED 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 FIVE ARGUMENTS ARE PROVIDED. IF THE MAXIMUM NUMBER OF C ARGUMENTS IS TO BE INCREASED, THE PARAMETER FNO SHOULD BE C INCREASED. IT MUST AGREE WITH THE VALUE USED IN ZZTP. C C ALL FUNCTION ARGUMENTS ARE REAL. INTEGER VALUES MAY BE PASSED C BY ASSIGNING THE INTEGER VALUE TO A REAL ARGUMENT AND THEN USING C 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======================= 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 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 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 = 8D0, 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 C!!!! DOUBLE PRECISION R1P2 PARAMETER ( R1P2 = 1.2D0 ) * 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 ) * * INTEGER JUSTF, BOTH, JUSTG, NOOP PARAMETER ( JUSTF = 1, BOTH = 0, JUSTG = -1, NOOP = 2 ) * 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 A R A T I O N S ================= * INTEGER OK, ABORT, LIMIT, NOF, NOG, NOFG INTEGER SOK, SABORT, SLIMIT, SNOF, SNOG, SNOFG * INTEGER FUNCNO, SIZE, SDOF, SDOFG, SDOG, SNOOP INTEGER SETFNC, SETSIZ, F1 * INTEGER I, J, K, JLO, JHI, IEG, IY INTEGER I1, I2, IC, IS, IV, IA, IB, M, L INTEGER NPTS, NEQ, IP, IQ, NSYS, IMESH, IH, TT INTEGER IB0, IB1, IDB0, IDB1, ILAST, BACK, RET, P * INTEGER ALPHA2, NOVER2, DOF, DOG, DOFG, NEITHR * LOGICAL EVEN, GFIRST, FIRST, ERROR, FONLY, GONLY LOGICAL DONE, PROB13 * REAL FARG ( FNO ), SARG ( FNO ), ZZMPAR, HUGE C!!!! DOUBLE PRECISION FARG ( FNO ), SARG ( FNO ), 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 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, W10, W11, W12 C!!!! DOUBLE PRECISION W7, W8, W9, W10, W11, W12 * REAL R, S, T, R1, BIGGST, SMLLST C!!!! DOUBLE PRECISION R, S, T, R1, BIGGST, SMLLST * REAL R2, R3, RI, RK , SK, TI C!!!! DOUBLE PRECISION R2, R3, RI, RK , SK, TI * REAL XI, XK, YI, PI, U, SUM C!!!! DOUBLE PRECISION XI, XK, YI, PI, U, SUM * REAL XP1, XM1, R2P, RD, TPI, TPIS C!!!! DOUBLE PRECISION XP1, XM1, R2P, RD, TPI, TPIS * REAL HJ, HJJ, DELTX, SINX C!!!! DOUBLE PRECISION HJ, HJJ, DELTX, SINX * REAL U1, U2, RF1, RF2, RF3, RF4, DH, DHH C!!!! DOUBLE PRECISION U1, U2, RF1, RF2, RF3, RF4, DH, DHH * * C--------- DATA ARRAYS FOR TESTPACK FUNCTIONS * * REAL AL (50), ARGASY (15), BARD7Y (15) C!!!! DOUBLE PRECISION AL (50), ARGASY (15), BARD7Y (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 FUNCNO, FARG, SIZE, GFIRST, FIRST, PI, R2P, BIGGST, SMLLST SAVE NPTS, NEQ, IP, IQ, NSYS, IA, IB, DH, DHH, HUGE SAVE IMESH, IH, IB0, IB1, IDB0, IDB1, PROB13, DONE, M SAVE DOF, DOG, DOFG, NEITHR SAVE OK, ABORT, LIMIT, NOF, NOG, NOFG * C--------- SAVE DATA ARRAYS FOR THE TEST FUNCTIONS. * * SAVE ARGASY, BARD7Y, 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 ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== * DATA FUNCNO /1/, SIZE /1/ * DATA FARG / FNO * 1.D0 / * DATA FIRST/.TRUE./, GFIRST/.TRUE./ * DATA DOF/JUSTF/, DOFG/ BOTH/, DOG/JUSTG/, NEITHR/NOOP/ DATA OK/ COK/, ABORT/CABORT/, LIMIT/CLIMIT/ DATA NOF/ CNOF/, NOG/ CNOG/, NOFG/ CNOFG/ * C--------- DATA FOR TESTPACK 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 TESTPACK 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--------- DATA FOR TESTPACK FUNCTION 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 TESTPACK 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 TESTPACK 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 TESTPACK 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 TESTPACK 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--------- DATA FOR TESTPACK 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 TESTPACK 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--------- FUNCTION DEFINITION * RD (I) = REAL (I) C!!!! RD (I) = DBLE (I) * 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) ENDIF * C--------- SET LOGICAL FLAGS AND SELECT FUNCTION. * FONLY = IFG .EQ. DOF GONLY = IFG .EQ. DOG RET = OK * GOTO( 51, 99, 50, 99, 99, 99, 99, 99, 99, - 99, 8, 99, 99, 99, 99, 10, 99, 99, 99, - 99, 99, 99, 99, 52, 22, 5, 20, 99, 99, - 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, - 44, 45, 99, 99, 99, 99, 99, 99, 99, 99, - 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, - 99, 99, 99, 99, 99, 99, 99, 99 ) - FUNCNO * C THESE DUMMY GO TO'S JUST MAKE POSSIBLE FUTURE CHANGES C MORE CONVENIENT. THE TEST FUNCTIONS APPEAR HERE IN C ALPHABETICAL ORDER. * C BARD70 5 GOTO 3600 * C BIGGS6 8 GOTO 2100 * C BOX663 10 GOTO 2600 * C CRGLVY 20 GOTO 3700 * C ENGVL2 22 GOTO 3500 * C PENAL1 44 GOTO 5000 * C PENAL2 45 GOTO 5100 * C PWSING 50 GOTO 1300 * C ROSENB 51 GOTO 1100 * C SCHMVT 52 GOTO 3400 * 99 GOTO 10000 * * C>>>>> NOTE : IF WE SUPPOSE THAT EACH OF THESE 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>>>>> ( CASE, 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. * * C--------- TESTPACK FUNCTION ROSENB * * 1100 X1 = X(1) W1 = ONE - X1 W2 = X(2) - X1*X1 * IF ( .NOT. GONLY ) THEN F = R100*W2*W2 + W1*W1 ENDIF * IF ( .NOT. FONLY ) THEN G(1) = -R400*W2*X1 - TWO*W1 G(2) = R200*W2 ENDIF * GOTO 10000 * * * C--------- TESTPACK 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 10000 * * * C--------- TESTPACK FUNCTION BIGGS6 ( N, X, F, G, IFG, NINT(FARG(1))) C--------- NINT(FARG(1)) IS M * * 2100 X1 = X(1) X2 = X(2) X3 = X(3) X4 = X(4) X5 = X(5) X6 = X(6) * IF ( .NOT. GONLY ) THEN F = ZERO ENDIF * IF ( .NOT. FONLY ) THEN G1 = ZERO G2 = ZERO G3 = ZERO G4 = ZERO G5 = ZERO G6 = ZERO ENDIF * DO 2110 I = 1, NINT(FARG(1)) T = RD(I) TI = T/TEN IF ( MAX(-T,-TI*FOUR,-TI*X1,-TI*X2,-TI*X5) .LE. BIGGST ) THEN YI = EXP(-TI) - FIVE * EXP(-T) + THREE*EXP(-FOUR*TI) W3 = EXP(-TI*X1) W4 = EXP(-TI*X2) W5 = EXP(-TI*X5) ELSE RET = NOFG GOTO 90000 ENDIF RI = X3*W3 - X4*W4 + X6*W5 - YI * IF ( .NOT. GONLY ) THEN F = F + RI*RI ENDIF * IF ( .NOT. FONLY ) THEN W1 = TI*RI G1 = G1 - W3*W1 G2 = G2 + W4*W1 G3 = G3 + W3*RI G4 = G4 - W4*RI G5 = G5 - W5*W1 G6 = G6 + W5*RI ENDIF * 2110 CONTINUE * IF ( .NOT. FONLY ) THEN G(1) = TWO*X3*G1 G(2) = TWO*X4*G2 G(3) = TWO * G3 G(4) = TWO * G4 G(5) = TWO*X6*G5 G(6) = TWO * G6 ENDIF * GOTO 10000 * * * C--------- TESTPACK 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 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 RI = W3 - W4 - W5*X(3) * IF ( .NOT. GONLY ) THEN IF ( ABS(RI) .LE. SQRT(HUGE-MAX(F,ZERO)) ) THEN F = F + RI*RI ELSE RET = NOFG GOTO 90000 ENDIF ENDIF * IF ( .NOT. FONLY ) THEN W2 = TI*RI G1 = G1 - W3*W2 G2 = G2 + W4*W2 G3 = G3 - W5*RI ENDIF * 2610 CONTINUE * IF ( .NOT. FONLY ) THEN G(1) = TWO * G1 G(2) = TWO * G2 G(3) = TWO * G3 ENDIF * GOTO 10000 * * * * C--------- TESTPACK FUNCTION SCHMVT * * 3400 IF ( FIRST ) THEN FIRST = .FALSE. PI = ACOS(-ONE) ENDIF * X1 = X(1) X2 = X(2) X3 = X(3) * W1 = X1 - X2 W2 = X1 + X3 * W3 = ONE + W1*W1 W4 = (PI*X2 + X3) / TWO W5 = (W2/X2) - TWO IF ( -W5**2 .LE. BIGGST ) THEN W6 = EXP(-W5*W5) ELSE RET = NOFG GOTO 90000 ENDIF * IF ( .NOT. GONLY ) THEN F = - ((ONE/W3) + SIN(W4) + W6 ) ENDIF * IF ( .NOT. FONLY ) THEN * W3 = TWO*W1/(W3*W3) W4 = COS(W4)/TWO W6 = TWO*W5*W6/X2 * G(1) = W3 + W6 G(2) = -W3 - PI*W4 - W6*W2/X2 G(3) = -W4 + W6 * ENDIF * GOTO 10000 * C--------- TESTPACK 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 10000 * * C--------- TESTPACK 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 10000 * C--------- TESTPACK FUNCTION CRGLVY * * 3700 X1 = X(1) X2 = X(2) X3 = X(3) X4 = X(4) * W1 = X2 - X3 W2 = X3 - X4 W3 = X4 - ONE * IF ( X1 .LE. BIGGST ) THEN W4 = EXP(X1) ELSE RET = NOFG GOTO 90000 ENDIF W5 = W4 - X2 W6 = TAN(W2) * IF ( .NOT. GONLY ) THEN F = W5**4 + R100*W1**6 + W6**4 + X1**8 + W3*W3 ENDIF * IF ( .NOT. FONLY ) THEN * W2 = COS(W2) W5 = FOUR * W5**3 W1 = R600 * W1**5 W6 = FOUR * W6**3 / (W2*W2) * G(1) = W4*W5 + EIGHT*X1**7 G(2) = -W5 + W1 G(3) = -W1 + W6 G(4) = -W6 + TWO*W3 ENDIF * GOTO 10000 * * * * C--------- TESTPACK 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 10000 * * C--------- TESTPACK 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 10000 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 10000 * * 10000 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 ) * OK = SOK ABORT = SABORT LIMIT = SLIMIT NOF = SNOF NOG = SNOG NOFG = SNOFG * RETURN * C>>>>>>>>>>>>>>>>>>>>>>>>>> E N T R Y ZZFSET <<<<<<<<<<<<<<<<<<<<<<<<<< * ENTRY ZZFSET ( SETFNC, SETSIZ ) * FUNCNO = SETFNC SIZE = SETSIZ FIRST = .TRUE. * 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 IFG = RET GFIRST = .FALSE. * RETURN * C============================ F O R M A T S ============================ C C THERE ARE NO FORMATS USED. C C================================ E N D ================================ * END SUBROUTINE ZZLCUC ( LINE ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER * (*) LINE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: THE ACTIONS DEPEND UPON THE UNDERLYING C CHARACTER SET. MOST VERSIONS ASSUME AN ASCII C OR EBCDIC CHARACTER SET WITH EACH CHARACTER C OCCUPYING ONE BYTE. THE CYBER VERSION ASSUMES 6- C 12 BIT CODES FOR UPPER/LOWER CASE. ALL THAT HAP- C PENS IS THAT THE ESCAPE CODES @ AND ^ ARE REMOVED. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR CYBER/FTN5 C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C C LINE CONTAINS THE CHARACTERS TO BE CONVERTED TO UPPER CASE. C NOTE THAT ON SOME SYSTEMS (NOTABLY THE OLD ARCHITECTURE C CDC CYBERS), UPPER AND LOWER CASE CHARACTERS HAVE DIFFERENT C LENGTHS, SO THE LINE LENGTH MAY BE CHANGED BY THIS ROUTINE. C C NOTE THAT IF IT HAPPENS THAT THE CONVERTED PART IS SHORTER AFTER C THE CONVERSION, THEN THE UNCONVERTED PART IS LEFT SHIFTED TO C FILL IN THE SPACE CREATED AS FOLLOWS (HERE WLEN IS THE C LENGTH OF THE WHOLE LINE. C C BEFORE CONVERSION C +----------------------------+-----------------------+ C ! CHARACTERS BEING CONVERTED ! SUBSEQUENT CHARACTERS ! C +----------------------------+-----------------------+ C 1 .. LENGTH LENGTH+1 .. WLEN C C AFTER CONVERSION C +----------------------+ +-----------------------+ C ! CONVERTED CHARACTERS ! <== ! SUBSEQUENT CHARACTERS ! C +----------------------+ +-----------------------+ C 1 .. J J+1 .. N C C WHERE J <= LENGTH AND ( WLEN - LENGTH ) = ( N - J ). C C THE RIGHT HAND SIDE IS BLANK FILLED IF THERE IS A SHIFT. C C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZLCUC C C======================== S U B R O U T I N E S ======================== C C INDEX ...GENERIC C ZZLENG ...NON-BLANK LENGTH OF A LINE C C MIN ...INTRINSIC C ZZSHFT ...TO SHIFT A STRING C C========================= P A R A M E T E R S ========================= * CHARACTER * (*) SPEC, BLANK PARAMETER ( SPEC = '^@', BLANK = ' ' ) * C================= L O C A L D E C L A R A T I O N S ================= * INTEGER I, J, L, ZZLENG, WLEN * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C C THERE ARE NO DATA VALUES. C * IF ( WLEN .NE. 0 ) THEN * I = 0 J = 0 * L = WLEN * 100 I = I + 1 J = J + 1 * IF ( I .LT. L .AND. INDEX( SPEC, LINE(I:I) ) .NE. 0 ) THEN * I = I + 1 * ENDIF * IF ( J .NE. I ) THEN LINE(J:J) = LINE(I:I) ENDIF * IF ( I .LT. L ) THEN GOTO 100 ENDIF C BLANK FILL. IF ( J .LT. L ) THEN LINE(J+1:L) = BLANK ENDIF * ENDIF * GO TO 90000 * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END INTEGER FUNCTION ZZLENG (LINE) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER*(*) LINE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: NONE C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 1, 1985 A. BUCKLEY 1.0 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZLENG C C======================== S U B R O U T I N E S ======================== C C LEN ...INTRINSIC C C========================= P A R A M E T E R S ========================= * CHARACTER*(*) BLANK PARAMETER ( BLANK = ' ' ) * C================= L O C A L D E C L A R A T I O N S ================= * INTEGER I * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA VALUES. C 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 ============================ C C THERE ARE NO FORMATS USED. C C================================ E N D ================================ * END SUBROUTINE ZZSHFT (STRING, FROM, TO, NUMBER ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * INTEGER FROM, TO, NUMBER * CHARACTER *(*) STRING * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: NONE C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 1, 1985 A. BUCKLEY 1.0 C C======================== D E S C R I P T I O N ======================== C 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 C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZSHFT C C======================== S U B R O U T I N E S ======================== C C LEN MIN MAX ...INTRINSIC C C========================= P A R A M E T E R S ========================= * CHARACTER *(*) BLANK PARAMETER ( BLANK = ' ' ) * C================= L O C A L D E C L A R A T I O N S ================= * INTEGER N, SHIFT, INCR, I, IS, IE, IBS, ETO, EFROM, K, SLEN * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA VALUES. C 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 STRING(K:K) = STRING(I:I) 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 ============================ C C THERE ARE NO FORMATS USED. C C================================ E N D ================================ * END SUBROUTINE ZZTIME ( CHTIME ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER *(*) CHTIME * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR TIME OF DAY. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR CYBER/FTN5 C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZTIME C C======================== S U B R O U T I N E S ======================== C C SYSTEM ROUTINE TO GET TIME OF DAY. C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * CHARACTER * 10 TIME * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA STATEMENTS. C 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZEVAL ( ZZUFNC, N, X, F, G, INDIC, IW, RW, DW ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * EXTERNAL ZZUFNC * INTEGER INDIC, N, IW(*) * REAL F, X(N), G(N) C!!!! DOUBLE PRECISION F, X(N), G(N), ZZUFNC * DOUBLE PRECISION DW(*) REAL RW(*) * C============================= S T A T U S ============================= 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 REVISION STATUS: DATE AUTHOR VERSION C C MAY. 21, 1987 A. BUCKLEY 1.2 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 ZZSCAL. 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, 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 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 ======================= C C ZZEVAL THE NATURAL ENTRY POINT. C C ZZESRT AN ENTRY TO INITIALIZE FOR TESTING EACH FUNCTION. C ZZESET AN ENTRY TO INITIALIZE CONTROL PARAMETERS. C C ZZEDDF AN ENTRY TO REDEFINE CODES FOR DERIVATIVE CALCULATIONS. C ZZEFDF AN ENTRY TO REDEFINE CODES FOR FUNCTION EVALUATIONS. C ZZERDF AN ENTRY TO REDEFINE CODES FOR RETURN CODES. C C ZZEGET AN ENTRY 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 C ZZSECS ...FOR FUNCTION TIMING. C ZZMPAR ...FOR MACHINE PARAMETERS. C ZZUFNC ...THE USER ROUTINE. C ZZSCAL ...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 = 8D0, 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 A R A T I O N S ================= * LOGICAL TRF, TRG, FIRST, FONLY, GONLY, VALID, BAD, TRTEST, FCALL * INTEGER I, IFNCT, FSCALE, IGRCT, SDRVMD INTEGER ITRUN, MAXFN, DERVMD INTEGER CASE, CALLS, COUNT, INDEX, GCNT, DCNT * REAL FT, FV, FTIME, TT, SCALE, SERR, RH C!!!! DOUBLE PRECISION FT, FV, FTIME, TT, SCALE, SERR, RH * 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 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 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 ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C 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-----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. * 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 CASE = INDIC * 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 DETERMINE 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 INDIC = CASE GOTO 90000 ENDIF * IF ( INDIC .NE. DOG ) THEN FT = FVAL ENDIF * C AFTER FIRST CALL, FUNCTION VALUES ONLY. * C-----DO EXTRA CALLS, IF REQUIRED. * 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 INDIC = CASE GOTO 90000 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 INDIC = CASE GOTO 90000 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. * SERR = SERR - LOG10 (TERR) DCNT = DCNT + 1 * IF (TRTEST) WRITE(ITRUN,99994) TERR,-LOG10(TERR) * IF ( TERR .GT. ABS(ERR) ) THEN * INDEX = COUNT GCNT = IGRCT ERR = SIGN (TERR, ERR) ENDIF * ELSE * C FLAG CASE WHERE THERE IS EXCESSIVE CANCELLATION. * ERR = - ABS(ERR) 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 INSTANCES C THIS MAY REQUIRE AN EXTRA CALL TO GET THE FUNCTION C VALUE WHEN INDIC = DOG; THIS WAS DONE IN THE CALLS C ABOVE. * IF ( FSCALE .NE. 0 ) THEN CALL ZZSCAL( 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 DO 5100 I=1,N G(I) = G(I) * SCALE 5100 CONTINUE ENDIF * INDIC = OK * GOTO 90000 * * C>>>>>>>>>>>>>>>>>>>>>>>>>> E N T R Y ZZESRT <<<<<<<<<<<<<<<<<<<<<<<<<< * ENTRY ZZESRT ( FSCAL, DDERV, MAXM ) * FCALL = .TRUE. * FSCALE = FSCAL SDRVMD = DDERV MAXFN = MAXM * 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 ============================ * 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 ================================ * END SUBROUTINE ZZPRNT ( N, X, F, G, NRMG, INCR ) * C============== A R G U M E N T D E C L A R A T I O N 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 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 REVISION STATUS: DATE AUTHOR VERSION C C MAY 21, 1987 A. BUCKLEY 1.2 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 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 = 8D0, TEN = 10D0 ) * C================= L O C A L D E C L A R A T I O N S ================= * INTEGER IFNCT, IGRCT, ITCT INTEGER PRPT1, PLEV1, UNIT1, LSTIT1, LSTUN1 INTEGER PRPT2, PLEV2, UNIT2, LSTIT2, LSTUN2 * LOGICAL GRAD1, LSTGR1, POINT1, LSTPT1 LOGICAL GRAD2, LSTGR2, POINT2, LSTPT2 LOGICAL FORCE, GOT * REAL SECS, PRTIME, DTIME C!!!! DOUBLE PRECISION SECS, PRTIME, DTIME * C-----DECLARATIONS FOR ENTRY POINT DUMMY ARGUMENTS. * LOGICAL DGRAD1, DPINT1 LOGICAL DGRAD2, DPINT2 * INTEGER DPRUN1, DPRNT1 INTEGER DPRUN2, DPRNT2 * INTEGER ITER * REAL TIME C!!!! DOUBLE PRECISION TIME * C=============================== S A V E =============================== * SAVE PRTIME, ITCT * 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 ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== * DATA PLEV1/0/, PLEV2/0/, UNIT1/6/, UNIT2/0/ * 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 * C ------IF PLEV2 > 0 , ALSO PRINT X AND G. * IF ( PLEV2 .GT. 0 ) THEN * IF ( POINT2) THEN WRITE (UNIT2,99988) X ENDIF * IF ( GRAD2 ) THEN WRITE (UNIT2,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 PRTIME = ZERO * RETURN * C>>>>>>>>>>>>>>>>>>>>>>>>>> E N T R Y ZZP2ST <<<<<<<<<<<<<<<<<<<<<<<<<< * ENTRY ZZP2ST ( DPRUN2, DGRAD2, DPINT2, DPRNT2 ) * UNIT2 = DPRUN2 GRAD2 = DGRAD2 POINT2 = DPINT2 PLEV2 = DPRNT2 * 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 ================================ * END SUBROUTINE ZZSCAL ( FT, FV, SCALE, FSCALE, FONLY, GONLY ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * INTEGER FSCALE * LOGICAL FONLY, GONLY * REAL FT, FV, SCALE C!!!! DOUBLE PRECISION FT, FV, SCALE * C============================= S T A T U S ============================= 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 REVISION STATUS: DATE AUTHOR VERSION C C DEC. 15, 1986 A. BUCKLEY 1.0 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 C GONLY - IF TRUE ONLY THE GRADIENT IS EVALUATED. C C-----ON EXIT: C C FV - THE SCALED FUNCTION VALUE. C C SCALE - GRADIENT SCALING FACTOR. C C======================= E N T R Y P O I N T S ======================= C C NONE ARE USED. C C======================== S U B R O U T I N E S ======================== C C SQRT... 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 = 8D0, TEN = 10D0 ) * C================= L O C A L D E C L A R A T I O N S ================= C C THERE ARE NO LOCAL DECLARATIONS. C C=============================== S A V E =============================== C C THERE ARE NO VARIABLES TO BE SAVED. C C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C NO DATA STATEMENTS ARE USED. C 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================================ E N D ================================ * END SUBROUTINE ZZTERM ( FIRST, N, F, G, XI, XIM1, EPS, LESS ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * INTEGER N * LOGICAL LESS, FIRST * REAL EPS, G(N), XI(N), XIM1(N), F C!!!! DOUBLE PRECISION EPS, G(N), XI(N), XIM1(N), F * C============================= S T A T U S ============================= 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 REVISION STATUS: DATE AUTHOR VERSION C C MAR. 12, 1987 A. BUCKLEY 1.1 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 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 !F! <= EPS * !F0! 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 (F0, 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 F0 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 F0 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 ======================= C C ZZTERM ...THE NATURAL ENTRY. C ZZTGET ...TO RETURN NORMS. C ZZTSET ...TO SET THE CONTROL VALUES. C ZZTINT ...TO SET INITIAL SCALING VALUES. C C======================== S U B R O U T I N E S ======================== C C INTRINSIC FUNCTIONS: ABS AND MAX . 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 = 8D0, TEN = 10D0 ) * C---- DEFINITIONS FOR THE 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 A R A T I O N S ================= * 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, F0, SF0, NG0, SNG0 C!!!! DOUBLE PRECISION VGSQ, VXSQ, VDIFSQ, F0, SF0, NG0, SNG0 * C=============================== S A V E =============================== * SAVE GSQ, XSQ, DIFFSQ, F0, NG0, GRAD, STEP, SHXG, FUNC, NORM SAVE TRACE, TRACUN * C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== * DATA F0/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 ========================== * 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 * 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(F) .LE. EPS * ABS(F0) LESS = LESS .AND. LIST IF (TRACE) WRITE(TRACUN,99998) - LIST, '(FUNC) F, F0, EPS=',F, F0, 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 ) * F0 = 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 ============================ * 99999 FORMAT ( A ) * 99998 FORMAT ( ' [TERM] LESS=',L1,'; ',A,3G14.3 ) * 99997 FORMAT ( ' [TERM] LESS=',L1,'; ',A,4G11.3 ) * C================================ E N D ================================ * END SUBROUTINE BBCUBC ( T, F, FP, TA, FA, FPA, LEFT, RIGHT, X, INTER ) * C============== A R G U M E N T D E C L A R A T I O N 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 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 REVISION STATUS: DATE AUTHOR VERSION C C FEB. 10, 1987 A. BUCKLEY 1.0 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 ======================= C C 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 = 8D0, TEN = 10D0 ) * INTEGER XEPS, XSMALL, XBIG PARAMETER ( XEPS = 1, XSMALL = 2, XBIG = 3 ) * C================= L O C A L D E C L A R A T I O N S ================= * INTEGER TRU, STRU * LOGICAL EXTREM, TRACE, STRACE, ORDER, ABIGGR, FIRST, PBIGGR * REAL P, DISC C!!!! DOUBLE PRECISION P, DISC * 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 ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== * DATA TRU/6/, TRACE/.FALSE./, FIRST/.TRUE./ * C========================== E X E C U T I O N ========================== * C---- DEFINE A STATEMENT FUNCTION. * RD(P) = REAL(P) C!!!! RD(P) = DBLE(P) * 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) - THREE*DBLE(FA-F)/DBLE(TA-T) * IF ( SIGN(ONE,FPA) .NE. SIGN(ONE,FP) ) THEN DISC = 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 = P**2 - DBLE(FP)*DBLE(FPA) IF (TRACE) WRITE(TRU,*) ' [CUBC] P,DISC->', P, DISC ELSE IF ( PBIGGR ) THEN DISC = P - (DBLE(FPA)/P)*FP ELSE IF ( ABIGGR ) THEN DISC = (P/DBLE(FPA))*P - FP ELSE DISC = (P/DBLE(FP))*P - 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) + TWO*P BPR = DBLE(FP) + 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 ============================ C C THERE ARE NO FORMATS USED. C C================================ E N D ================================ * END * * SUBROUTINE BBDFLT ( PFREQ, MAXF ) * C================ A R G U M E N T D E C L A R A T I O N S ============ * INTEGER PFREQ, MAXF * C============================= S T A T U S ============================= 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 REVISION STATUS: DATE AUTHOR VERSION C C JUN. 20, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C C THIS ROUTINE OBTAINS THE DEFAULT VALUES FOR INITIALIZING C THE ROUTINES ZZPRNT, ZZEVAL, ZZTERM AND BBLNIR. IT 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 ======================= C C ONLY THE NATURAL ENTRY POINT 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 A R A T I O N S ================= * CHARACTER*(4) TESTS * INTEGER INTS(NINTS) LOGICAL LOGS(NLOGS) * REAL REALS(NREALS) C!!!! DOUBLE PRECISION REALS(NREALS) * C=============================== S A V E =============================== C C THERE ARE NO SAVE VALUES. C C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA VALUES. C C========================== E X E C U T I O N ========================== * C-----OBTAIN DEFAULTS. * CALL BBVALS ( INTS, LOGS, REALS ) * C-----INITIALIZE ZZEVAL. * CALL ZZESET ( LOGS(XTRF),LOGS(XTRG),LOGS(XTRTST),INTS(XETRCU) ) * CALL ZZESRT ( INTS(XSCALE), INTS(XDRVMD), MAXF ) * C-----INITIALIZE ZZPRNT. * CALL ZZP1ST ( INTS(XPTRCU),LOGS(XGRAD),LOGS(XPOINT), PFREQ ) CALL ZZP2ST ( INTS(XPTRCU),LOGS(XGRAD),LOGS(XPOINT), 0 ) * C-----INITIALIZE 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-----PRESET 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 ============================ C C THERE ARE NO FORMATS USED. C C================================ E N D ================================ * END SUBROUTINE BBDIAG ( N, X, G, H, D, NRMG, INNER, DGCURR, IDENTY, - IW, RW, DW ) * C================ A R G U M E N T D E C L A R A T I O N S ============ * INTEGER N, IW(*) * LOGICAL IDENTY * REAL X(N), G(N), H(N), D(N), NRMG, DGCURR C!!!! DOUBLE PRECISION X(N), G(N), H(N), D(N), NRMG, DGCURR * EXTERNAL INNER DOUBLE PRECISION INNER, DW(*) REAL RW(*) * C============================= S T A T U S ============================= 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 REVISION STATUS: DATE AUTHOR VERSION C C JUN. 17, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C C THE MAIN PURPOSE OF THIS ROUTINE IS TO DEFINE A DIAGONAL C SCALING; THIS IS STORED IN THE FIRST N LOCATIONS OF THE C ARRAY H. 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 IN ADDITION, A SEARCH DIRECTION D IS COMPUTED, ALONG WITH C ITS 2-NORM, AND BOTH ARE RETURNED TO THE CALLING ROUTINE. C HERE, D IS COMPUTED AS D = -H*G, SO THAT D(I) = - H(I)*G(I). C FINALLY, THE INNER PRODUCT OF D WITH G MUST BE C COMPUTED AND RETURNED. 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 ON ENTRY, THE CURRENT POINT X AND THE GRADIENT G AT X C MUST BE DEFINED, ALONG WITH THE 2-NORM (NRMG) OF G. THE NORM C OF G IS USED TO COMPUTE THE NORM OF D WHEN H = I. C C BOTH X AND G ARE USED TO COMPUTE THE DIAGONAL SCALING C ENTRIES OF H. 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 WHETHER SCALING IS DONE OR NOT, THE VALUES FOR H, D C AND DGCURR MUST BE DEFINED BEFORE EXITING. C C-----NOTE THAT THE PARAMETER SCDIAG WILL BE THE SAME FOR EACH CALL C TO BBDIAG DURING THE PROCESSING OF ANY PARTICULAR MINIMIZATION C PROBLEM IT IS SET JUST ONCE THROUGH AN ENTRY POINT. C C======================= E N T R Y P O I N T S ======================= C C BBDIAG THE NATURAL ENTRY POINT. C BBSDAG AN ENTRY TO DEFINE THE FIXED PARAMETERS. C C======================== S U B R O U T I N E S ======================== C C ABS INTRINSIC FUNCTION. C C INNER TO COMPUTE THE 2-NORM OF A VECTOR WITHOUT OVERFLOW. C 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 = 8D0, TEN = 10D0 ) * C================= L O C A L D E C L A R A T I O N S ================= * INTEGER J * C-----TO SET THROUGH THE ENTRY POINT. * LOGICAL SCDIAG, SSCDAG * C=============================== S A V E =============================== * SAVE SCDIAG * C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA VALUES. C 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 * D(J) = -H(J)*G(J) * 1200 CONTINUE * DGCURR = INNER ( N, D, G, NONORM, IW, RW, DW ) * ELSE C H IS JUST THE IDENTITY * DO 1400 J = 1,N D(J) = -G(J) 1400 CONTINUE * DGCURR = -NRMG**2 * ENDIF * GOTO 90000 * C>>>>>>>>>>>>>>>>>>>>>>>>>> E N T R Y BBSDAG <<<<<<<<<<<<<<<<<<<<<<<<<< * ENTRY BBSDAG ( SSCDAG ) * SCDIAG = SSCDAG * RETURN * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NO FORMATS USED. C C================================ E N D ================================ * END DOUBLE PRECISION FUNCTION ZZINNR ( N, U, V, NRMFLG, IW, RW, DW ) * C============== A R G U M E N T D E C L A R A T I O N 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 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 REVISION STATUS: DATE AUTHOR VERSION C C APR. 1, 1987 A. BUCKLEY 1.0 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. NOTE THAT THE RESULT PASSED BACK IS C *ALWAYS* DOUBLE PRECISION. IF NRMFLG IS SET ON ENTRY, THEN C THE 2-NORM OF U IS COMPUTED BY CALLING ZZNRM2 TO DO THE C COMPUTATION WITHOUT OVERFLOW. IN THIS CASE, V IS IGNORED AND C THE NORM IS COMPUTED IN SINGLE OR DOUBLE PRECISION AS APPROPRIATE. C C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZINNR C C======================== S U B R O U T I N E S ======================== C C 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 = 8D0, TEN = 10D0 ) * C================= L O C A L D E C L A R A T I O N S ================= * INTEGER I * REAL ZZNRM2 C!!!! DOUBLE PRECISION ZZNRM2 * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA VALUES. C 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 ============================ C C THERE ARE NO FORMATS USED. C C================================ E N D ================================ * END * * SUBROUTINE BBLINS (ALPHA, F, DG, VALIDF, F0, DG0, AP, FP, DGP, - WIDTH, NOUPS, LSDONE, CT, NCALLS, QUADON, UPDATT ) * C================ A R G U M E N T D E C L A R A T I O N S ============ * LOGICAL NOUPS, LSDONE, QUADON, VALIDF * INTEGER CT, NCALLS, UPDATT * REAL F, DG, ALPHA, F0, DG0, DGP, FP, AP, WIDTH C!!!! DOUBLE PRECISION F, DG, ALPHA, F0, DG0, DGP, FP, AP, WIDTH * C============================= S T A T U S ============================= 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 REVISION STATUS: DATE AUTHOR VERSION C C JAN. 11, 1985 A. BUCKLEY 1.0 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 F 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 ======================= C C BBLINS ... THE NATURAL ENTRY POINT. C BBSLNS ... AN ENTRY TO INITIALIZE FIXED ARGUMENTS. C C======================== S U B R O U T I N E S ======================== C C BBCUBC FOR CUBIC INTERPOLATION. 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 = 8D0, TEN = 10D0 ) * 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 ) * * INTEGER SUMFRM, PRDFRM, MJDFRM PARAMETER ( SUMFRM = 1, PRDFRM = 2, MJDFRM = 3 ) * C================= L O C A L D E C L A R A T I O N S ================= * 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, FUB, DGUB, TP0, AT C!!!! DOUBLE PRECISION LB, FLB, DGLB, UB, FUB, DGUB, TP0, AT * REAL LEFT, RIGHT, SLICE, CURRMG C!!!! DOUBLE PRECISION LEFT, RIGHT, SLICE, CURRMG * C=============================== S A V E =============================== * SAVE M, QUADIN, TRU, CURRMG SAVE CG, USESHN, LMSTQN, FQUAD, TR4, TR5, TR6 SAVE ACC, LB, FLB, DGLB, LDATA, UB, FUB, DGUB, UDATA, GOODP * C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA VALUES. C 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, F, DG * FIRST = NCALLS .EQ. 1 * IF ( FIRST ) THEN * LB = ZERO FLB = F0 DGLB = DG0 * UB = ZERO * GOODP = .TRUE. CURRMG = INITMG * ENDIF * C TEST WHETHER THE STEPLENGTH CRITERIA HAVE BEEN MET. * TP0 = F0 + SMALL*ALPHA*DG0 TEST1 = F .LT. TP0 TEST2 = DG .GE. NERLY1*DG0 * IF (TR5) WRITE (TRU,*) ' [LINS] TP0->',TP0 * IF ( VALIDF ) THEN ACCEPT = TEST1 .AND. TEST2 ELSE ACCEPT = .FALSE. 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 = .TRUE. * ELSE IF ( CG .AND. UPDATT .EQ. SUMFRM ) THEN * QNSTEP = .NOT. NOUPS - .AND. ( QUADIN .GT. 0 ) - .AND. ( CT .LT. M+QUADIN ) * FORCEQ = .NOT. QNSTEP .AND. QUADIN .LE. 3 * ELSE IF ( CG .AND. UPDATT .EQ. PRDFRM ) THEN * FORCEQ = .FALSE. * 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 = .TRUE. FUB = F DGUB = DG ELSE LB = ALPHA LDATA = .TRUE. FLB = F DGLB = DG ENDIF ENDIF * ELSE * IF ( TR6 ) THEN WRITE(TRU,*) ' [LINS] NOT ACCEPTED; F ', TEST1, TEST2, UDATA WRITE(TRU,99998) ' [LINS] REQ''D REDUCTION, F0-F, SLOPE' - // ' LIMIT->', F0-TP0,F0-F,NERLY1*DG0 ENDIF * LSDONE = .FALSE. * IF ( .NOT. VALIDF ) THEN UB = ALPHA UDATA = .FALSE. ELSE IF ( F .GE. TP0 ) THEN UB = ALPHA FUB = F DGUB = DG UDATA = VALIDF ELSE LB = ALPHA FLB = F 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 = .FALSE. ELSE INTERP = .TRUE. IF ( AP .GT. UB .AND. LDATA ) THEN AP = LB FP = FLB DGP = DGLB ENDIF ENDIF * ELSE * INTERP = .FALSE. LEFT = ALPHA * (ONE+INITMG) RIGHT = EXTRAP * ALPHA * CALL BBCUBC (ALPHA,F,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, F, 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 = F DGP = DG * ALPHA = AT GOODP = VALIDF ELSE ALPHA = AT GOODP = .FALSE. 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 ================================ * END 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 D E C L A R A T I O N 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 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 REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 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 (T) 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 CURRENTLY UNUSED. 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 C FUNCNM, INNER EXTERNAL PROCEDURES PASSED AS ARGUMENTS. C C HERE, A NAME IN [..] IS AN ENTRY POINT IN THE GIVEN ROUTINE. C C BBDIAG [BBSDAG] 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 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 = 8D0, 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 ) * REAL NERLY1 C!!!! DOUBLE PRECISION NERLY1 PARAMETER ( NERLY1 = RPT9 ) * C================= L O C A L D E C L A R A T I O N S ================= * 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, NDLAST, RD C!!!! DOUBLE PRECISION DGP, DGAL, NRMD, NRMG, FLAST, EPS, NDLAST, RD REAL TP0, TP1, TP2, NRMX, ACOS, PI, RADS, WIDTH C!!!! DOUBLE PRECISION TP0, TP1, TP2, NRMX, ACOS, PI, RADS, WIDTH REAL STS, STY, YTY, YTHY C!!!! DOUBLE PRECISION STS, STY, YTY, YTHY * CHARACTER*5 TESTS * 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 ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== * 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 TESTS /' FTTF'/ * 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-----DEFINE THREE STATEMENT FUNCTIONS. * BAD() = CASE .EQ. ABORT .OR. CASE .EQ. LIMIT .OR. CASE .EQ. NOF - .OR. CASE .EQ. NOFG .OR. CASE .EQ. NOG * ANGLE(AP) = RADS*ACOS(AP) * RD(AP) = REAL (AP) C!!!! RD(AP) = DBLE (AP) 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 INITIALIZE STATUS, CNTRST, ETC. * CNTRST = 0 OTSTAT = OK 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 INCR = 2*N + 1 ENDIF * M = (HDIM - BASE) / INCR * IF ( METH .EQ. 0 ) THEN IF ( HDIM .GE. STORAG ) THEN CG = F 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 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 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 BBSDAG ( SCDIAG ) * 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 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) 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 BBDIAG ( N, X, G, H, D, NRMG, INNER, DG0, IDENTY, IW,RW,DW) NRMD = INNER ( N, D, D, DONORM, 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, RD(INNER (N,X,X,DONORM,IW,RW,DW)) ) C!!!! NRMX = MAX ( ONE, INNER (N,X,X,DONORM,IW,RW,DW) ) IF ( TR8 ) WRITE (TRU,*) ' [LNIR] NORM OF X->', NRMX IF ( TR8 ) WRITE (TRU,*) ' [LNIR] NORM OF D->', NRMD QUADON = F * IF ( TR9 ) WRITE(TRU,*) ' [LNIR] D->',D IF ( TR9 ) WRITE(TRU,*) ' [LNIR] X->',X * 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.<<<<<<<<<<<< * 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 NDLAST = NRMD FLAST = FMIN * C STORE THE CURRENT X AND G. * DO 1800 J=1,N XX(J) = X(J) GG(J) = G(J) 1800 CONTINUE * 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. * DO 2100 J=1,N X(J) = XX(J) + ALPHA*D(J) 2100 CONTINUE * 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. * DO 2700 J=1,N D(J) = ALPHA*D(J) 2700 CONTINUE * C CHECK IF A RESTART IS TO BE FORCED. * FORCER = CG .AND. UPDATT .EQ. SUMFRM - .AND. ( .NOT. LMSTQN ) - .AND. ( (CT .GE. LASTPT) .OR. (STEEPD .AND. FORCEF) ) * IF ( TR7 ) WRITE(TRU,*) ' [LNIR] FORCER->',FORCER * 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 * 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, 1, 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 BBUPDT (N, G, D, XX, GG, H, CT, CNTRST, LASTPT, IDENTY, NUPS, - STEEPD, RSTEP, QNPART, UPDATT, INNER, IW, RW, DW ) * C>>>>>>>>>> P H A S E XI: COMPUTE NEW DIRECTION.<<<<<<<<<<<<<<<<<<<<< * IF ( CG ) THEN * C CALCULATE THE DERIVATIVE DG0 ALONG THE NEW SEARCH VECTOR D. C THE NEW D IS AVAILABLE IN XX, AND IS TRANSFERRED TO D. * DO 7500 K=1,N D(K) = -XX(K) 7500 CONTINUE * 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 *PASSED TO* C FUNCTION EVALUATION ROUTINE. * ENTRY BBLFDF ( SDOF, SDOG, SDOFG, SNONE ) * DOF = SDOF DOG = SDOG DOFG = SDOFG NONE = SNONE * CALL ZZEFDF ( SDOF, SDOG, SDOFG, SNONE ) * 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 MUPS = M 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.' ) * 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 ================================ * END * SUBROUTINE BBMJDP ( DIAG, SHAT, W, Z, PHI, V, DELT, GAM, S, R, - U, HU, N, NUPS, I, M, IDENTY, INNER, IW, RW, DW, TR,TRU ) * C================ A R G U M E N T D E C L A R A T I O N S ============ * EXTERNAL INNER * INTEGER N, NUPS, I, M, TRU, IW(*) * LOGICAL IDENTY, TR * REAL U(N), HU(N), DIAG(*), SHAT(*), W(*), Z(*) C!!!! DOUBLE PRECISION U(N), HU(N), DIAG(*), SHAT(*), W(*), Z(*) * REAL PHI(0:*), V(N,0:*), DELT(N,0:*), GAM(N,0:*) C!!!! DOUBLE PRECISION PHI(0:*), V(N,0:*), DELT(N,0:*), GAM(N,0:*) * REAL S(N,0:*), R(0:*) C!!!! DOUBLE PRECISION S(N,0:*), R(0:*) * DOUBLE PRECISION DW(*), INNER REAL RW(*) * C============================= S T A T U S ============================= 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 REVISION STATUS: DATE AUTHOR VERSION C C JUNE 2, 1987 A. BUCKLEY 1.0 C C======================== D E S C R I P T I O N ======================== C C GIVEN THE QUASI NEWTON UPDATE MATRIX H (IN ZZ^T FORM) AND C GIVEN THE VECTOR V, THIS ROUTINE COMPUTES C C HV = H * V . C C IT ALSO RETURNS THE INTERMEDIATE VALUE SHAT = Z^T * V. C C-----NOTE THAT A NUMBER OF PARAMETERS WHICH WILL BE THE SAME C FOR EACH CALL TO BBMJDP DURING ANY PARTICULAR MINIMIZATION C PROBLEM ARE SET JUST ONCE THROUGH AN ENTRY POINT. C C------EACH UPDATE TERM OF H REQUIRES 3N+1 ENTRIES OF H. THE ORDER IS C C ETA(I), S(I), Y(I) AND SHAT(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 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 SEE BBMULT REGARDING THE USE OF INNER. 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------BETA IS THE PARAMETER DEFINING THE BROYDEN FAMILY C OF UPDATES. THE FORM USED IS C H! = H(DFP) + BETA * NU * W'W C SO THAT BETA = 1 GIVES THE BFGS UPDATE. C NOTE THAT H! DENOTES THE MATRIX OBTAINED BY C UPDATING H. BETA MUST BE 1 FOR PRODUCT UPDATES. C C------IF SCDIAG = .TRUE., H0 IS TAKEN TO BE A DIAGONAL MATRIX C WHICH IS AVAILABLE IN THE FIRST N C LOCATIONS OF THE ARRAY H. OTHERWISE, C H0 = I, AND IT IS OF COURSE NOT STORED. C C------IF SCGAMM = 2, THEN THE SO-CALLED GAMMA SCALING OF C OREN AND SPEDICATO, WHICH IS DESCRIBED C BY SHANNO, IS USED AT EACH UPDATE STEP. C THIS CAN IN FACT BE DONE ONLY IF THE C BFGS UPDATE IS BEING USED, I.E. IF C BETA = 1. NO EXTRA STORAGE IS NEEDED C TO IMPLEMENT THIS SCALING. IT IS NOT ALLOWED C WITH PRODUCT FORM UPDATES. C C------IF SCGAMM = 1, THEN SCALING IS DONE, AS JUST DESCRIBED C FOR SCGAMM=2, BUT IT ONLY APPLIES TO C THE FIRST UPDATE TERM. IT IS ALLOWED WITH C PRODUCT FORM UPDATES. C C-------IDENTY IS TRUE TO INDICATE THAT H0 = I; THIS MAY BE TRUE C EVEN IF SCDIAG IS TRUE. C C------INCR IS THE CONSTANT 2N+1, THE LENGTH OF EACH TERM. C BASE IS THE NO. OF LOCATIONS FOR THE DIAG. H0, EITHER 0 OR N. C COUNT NO OF TERMS DONE (INTERNAL COUNTER). C PTNU POINTER TO CURRENT RANK 2 TERM (INTERNAL POINTER). C C------TRACES: TURN ON TR TO SEE NU, ETA, GAMMA, HV AND S'V. C THESE 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 ======================= C C BBMJDP THE NATURAL ENTRY POINT. C C======================== S U B R O U T I N E S ======================== C C NO SUBROUTINES OR FUNCTIONS ARE CALLED C 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 = 8D0, TEN = 10D0 ) * C================= L O C A L D E C L A R A T I O N S ================= * INTEGER COUNT, K, IS, L, J, IY, IETA, LAST * REAL SV, GAMMA, BETAK, NU, ZETA, TMP C!!!! DOUBLE PRECISION SV, GAMMA, BETAK, NU, ZETA, TMP * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA VALUES. C C========================== E X E C U T I O N ========================== * IF ( TR ) WRITE (TRU,*) ' ***[MJDP ENTERED]***' * DO 4000 K = N,2,-(I-1) * DO 3000 J = MAX(0,-K+1), MIN(I,N-K-1) * ZETA = SQRT( PHI(J)/(PHI(J)+S(K+J-1,J)) ) * IF ( J .EQ. 0 ) THEN * DO 300 L = 1,N W(L) = - GAM(K-1,0) * DELT(L,0) 300 CONTINUE W(K-1) = W(K-1) + ONE * ELSE IF ( K-1+J .EQ. 1 ) THEN * TMP = INNER (N, GAM(1,J), DELT(1,J-1), NONORM,IW,RW,DW) DO 400 L = 1,N W(L) = (DELT(L,J-1) - TMP * DELT(L,J)) / R(J-1) 400 CONTINUE * ELSE TMP = INNER (N, GAM(1,J), Z, NONORM,IW,RW,DW) DO 500 L = 1,N W(L) = Z(L) - TMP * DELT(L,J) 500 CONTINUE ENDIF * DO 600 L = 1,N Z(L) = ZETA*(W(L) + S(K+J-1,J)*V(L,J))/PHI(J) V(L,J) = V(L,J) + S(K+J-1,J)*W(L) 600 CONTINUE * PHI(J) = PHI(J) + S(K+J-1,J)**2 * 3000 CONTINUE * IF ( K+I .GT. N ) THEN * IF ( K .EQ. N ) THEN DO 1100 L = 1,N V(L,0) = S(N,0)*GAM(N,0)* DELT(L,N-K) HU(L) = ZERO 1100 CONTINUE V(N,0) = V(N,0) + S(N,0) PHI(0) = S(N,0)**2 ELSE TMP = INNER(N, GAM(1,N-K), Z, NONORM,IW,RW,DW) DO 1200 L = 1,N V(L,J+1) = S(N,N-K)*(Z(L) - TMP * DELT(L,N-K)) 1200 CONTINUE PHI(J) = S(N,J)**2 ENDIF ELSE SHAT(K+J) = INNER (N, Z, U, NONORM, IW, RW, DW ) DO 2000 L = 1,N HU(L) = HU(L) + SHAT(K+J) + Z(L) 2000 CONTINUE ENDIF * 4000 CONTINUE * SHAT(1) = INNER( N, DELT(1,I), U, NONORM, IW, RW, DW )/R(I) * DO 5000 L = 1,N HU(L) = HU(L) + SHAT(1) * DELT(L,1)/R(1) 5000 CONTINUE * GOTO 90000 * C=============================== E X I T =============================== * 90000 IF ( TR ) WRITE (TRU,*) ' ===[LEAVING MJDP].' * RETURN * C============================ F O R M A T S ============================ C C THERE ARE NO FORMATS. C C================================ E N D ================================ * END SUBROUTINE BBMULT ( H, V, HV, N, NUPS, ICOMP, IDENTY, INNER, - IW, RW, DW ) * C================ A R G U M E N T D E C L A R A T I O N S ============ * EXTERNAL INNER * INTEGER N, NUPS, ICOMP, IW(*) * LOGICAL IDENTY * REAL H(*), V(N), HV(N) C!!!! DOUBLE PRECISION H(*), V(N), HV(N) * DOUBLE PRECISION DW(*), INNER REAL RW(*) * C============================= S T A T U S ============================= 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 REVISION STATUS: DATE AUTHOR VERSION C C APR. 2, 1987 A. BUCKLEY 1.1 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 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 ARE COMPUTED BY CALLING THE C 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. 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--BETA IS THE PARAMETER DEFINING THE BROYDEN FAMILY OF UPDATES. C THE FORM USED IS H! = H(DFP) + BETA * NU * W'W C SO THAT BETA = 1 GIVES THE BFGS UPDATE. NOTE THAT H! C DENOTES THE MATRIX OBTAINED BY UPDATING H. 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 IF = 2, 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 IF SCGAMM = 1, THEN SCALING IS DONE, AS JUST DESCRIBED C FOR SCGAMM=2, BUT IT ONLY APPLIES TO THE FIRST UPDATE TERM. C C--ICOMP IS A FLAG WHICH CONTROLS THE COMPUTATION TO BE DONE. C =1 COMPUTE H*V USING ALL THE TERMS WHICH DEFINE H. C =2 COMPUTE BY ADDING JUST ONE LAST TERM; I.E. WE COMPUTE C (H!)*V, ASSUMING THAT H*V WAS DONE EARLIER AND THAT C 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--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 COUNT NO OF TERMS DONE (INTERNAL COUNTER). C PTNU POINTER TO CURRENT RANK 2 TERM (INTERNAL POINTER). C C--TRACES TURN ON TR TO SEE NU, ETA, GAMMA, HV AND S'V. C THESE 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 ======================= C C BBMULT THE NATURAL ENTRY POINT. C BBSMLT AN ENTRY TO SET FIXED PARAMETERS. C C======================== S U B R O U T I N E S ======================== C C NO SUBROUTINES OR FUNCTIONS ARE CALLED 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 = 8D0, TEN = 10D0 ) * LOGICAL DONORM, NONORM PARAMETER ( DONORM = .TRUE., NONORM = .FALSE. ) * C================= L O C A L D E C L A R A T I O N S ================= * INTEGER COUNT, IU, K, PTNU, IS, I * 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, STR, TRV, STRV, SCDIAG, 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 ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA VALUES. C 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 (ICOMP .NE. 1) 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 DO 300 K = 1,N HV(K) = V(K) 300 CONTINUE ENDIF * PTNU = BASE + 1 COUNT = 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 = 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 * 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. 2 ) * - .OR. (SCGAMM .EQ. 1 .AND. I .EQ. 1)) ) THEN * GAMMA = ETA/NU IF ( TR ) WRITE (TRACUN, * ) ' [MULT] GAMMA->',GAMMA * DO 2000 K=1,N HV(K) = GAMMA*HV(K) 2000 CONTINUE * 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 * DO 3000 K=1,N C PRINT*,'K,IU,IS,H(IU+K),H(IS+K)',K,IU,IS,H(IU+K),H(IS+K) HV(K) = HV(K) + MU*H(IU+K) + SIGMA*H(IS+K) 3000 CONTINUE * 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 ============================ C C THERE ARE NO FORMATS. C C================================ E N D ================================ * END SUBROUTINE BBNOCE ( H, V, HV, N, NUPS, ITER, M, IDENTY, ARO, - INNER, IW, RW, DW ) * C================ A R G U M E N T D E C L A R A T I O N S ============ * EXTERNAL INNER * INTEGER N, NUPS, ITER, M, IW(*) * LOGICAL IDENTY * REAL H(*), V(N), HV(N), ARO(N) C!!!! DOUBLE PRECISION H(*), V(N), HV(N), ARO(N) * DOUBLE PRECISION DW(*), INNER REAL RW(*) * C============================= S T A T U S ============================= 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 REVISION STATUS: DATE AUTHOR VERSION C C APR. 1, 1987 A. BUCKLEY 1.0 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 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 SEE BBMULT REGARDING THE USE OF INNER. 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--BETA IS THE PARAMETER DEFINING THE BROYDEN FAMILY C OF UPDATES. THE FORM USED IS H! = H(DFP) + BETA * NU * W'W C SO THAT BETA = 1 GIVES THE BFGS UPDATE. NOTE THAT H! C DENOTES THE MATRIX OBTAINED BY UPDATING H.BETA MUST BE 1 C FOR PRODUCT UPDATES. 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 IF = 2, 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. IT IS NOT ALLOWED C WITH PRODUCT FORM UPDATES. C C IF SCGAMM = 1, THEN SCALING IS DONE, AS JUST DESCRIBED C FOR SCGAMM=2, BUT IT ONLY APPLIES TO THE FIRST UPDATE TERM. C IT IS ALLOWED WITH PRODUCT FORM UPDATES. C C--IDENTY IS TRUE TO INDICATE THAT H0 = I; THIS MAY BE TRUE C EVEN IF SCDIAG IS TRUE. C C------INCR IS THE CONSTANT 2N+1, THE LENGTH OF EACH TERM. C BASE IS THE NO. OF LOCATIONS FOR THE DIAG. H0, EITHER 0 OR N. C COUNT NO OF TERMS DONE (INTERNAL COUNTER). C PTNU POINTER TO CURRENT RANK 2 TERM (INTERNAL POINTER). 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 ======================= C C BBNOCE THE NATURAL ENTRY POINT. C BBSNOC AN ENTRY TO SET FIXED PARAMETERS. C C======================== S U B R O U T I N E S ======================== C C NO SUBROUTINES OR FUNCTIONS ARE CALLED C C========================= P A R A M E T E R S ========================= * * LOGICAL DONORM, NONORM PARAMETER ( DONORM = .TRUE., NONORM = .FALSE. ) * C================= L O C A L D E C L A R A T I O N S ================= * INTEGER COUNT, K, IS, I, IY, IETA, LAST * REAL SV, GAMMA, BETAK, NU C!!!! DOUBLE PRECISION SV, GAMMA, BETAK, NU * C-----VARIABLES FOR THE ENTRY POINT. * LOGICAL TR, STR, TRV, STRV, SCDIAG, 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 ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA VALUES. C C========================== E X E C U T I O N ========================== * IF ( TR ) WRITE (TRACUN,*) ' ***[NOCE ENTERED]***' * C INITIALIZE COUNTERS. * IF ( ITER .GT. M ) THEN COUNT = M ELSE COUNT = NUPS ENDIF * IF ( NUPS .GT. 0 ) THEN * C DO THE FIRST ITERATION OF THE FIRST HALF OF NOCEDAL'S RECURSION * IETA = (NUPS-1)*INCR +1 IS = IETA + 1 IY = IS + N - 1 * SV = INNER ( N, H(IS), V, NONORM, IW, RW, DW ) * ARO(NUPS) = SV / H(IETA) * DO 130 I = 1,N HV(I) = V(I) - ARO(NUPS)*H(IY+I) 130 CONTINUE * LAST = NUPS * DO 200 I = 1,COUNT-1 * IETA = IETA - INCR IF ( IETA .LE. 0 ) IETA = IETA + M*INCR IS = IETA + 1 IY = IS + N - 1 * LAST = LAST - 1 IF ( LAST .EQ. 0 ) LAST = M * C DO THE REMAINING ITERATIONS OF THE FIRST HALF. * SV = INNER ( N, H(IS), HV, NONORM, IW, RW, DW ) * ARO(LAST) = SV/H(IETA) * DO 180 K = 1,N HV(K) = HV(K) - ARO(LAST)*H(IY+K) 180 CONTINUE * 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 ( NUPS .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. 1 ) THEN NU = INNER ( N, H(IY+1), H(IY+1), NONORM, IW, RW, DW ) DO 225 K = 1,N HV(K) = HV(K)*H(IETA)/NU 225 CONTINUE ENDIF ELSE IF ( .NOT. IDENTY ) THEN DO 230 K=1,N HV(K) = H(K) * V(K) 230 CONTINUE ELSE DO 240 K = 1,N HV(K) = V(K) 240 CONTINUE 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 ) * DO 3000 K=1,N HV(K) = HV(K) + (ARO(LAST) - BETAK/H(IETA)) * H(IS+K) 3000 CONTINUE * LAST = MOD(LAST,M) + 1 IETA = IETA + INCR IF ( IETA .GT. M*INCR ) IETA = 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 ============================ C C THERE ARE NO FORMATS. C C================================ E N D ================================ * END REAL FUNCTION ZZNRM2 ( N, V ) C!!!! DOUBLE PRECISION FUNCTION ZZNRM2 ( N, V ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * INTEGER N * REAL V(N) C!!!! DOUBLE PRECISION V(N) * C============================= S T A T U S ============================= 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 REVISION STATUS: DATE AUTHOR VERSION C C JAN. 26, 1987 A. BUCKLEY 1.1 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZNRM2 C C======================== S U B R O U T I N E S ======================== 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 ========================= * 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 = 8D0, TEN = 10D0 ) * INTEGER XEPS, XSMALL, XBIG PARAMETER ( XEPS = 1, XSMALL = 2, XBIG = 3 ) * C================= L O C A L D E C L A R A T I O N S ================= * 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 =============================== * SAVE FIRST, MAX * C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== * DATA FIRST / .TRUE. / * 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 ============================ C C THERE ARE NO FORMATS USED. C C================================ E N D ================================ * END SUBROUTINE ZZPOWL ( H, U, HU, N, NUPS, I, M, IDENTY, - INNER, IW, RW, DW ) * C================ A R G U M E N T D E C L A R A T I O N S ============ * EXTERNAL INNER * INTEGER N, NUPS, I, M, IW(*) * LOGICAL IDENTY * REAL H(*), U(N), HU(N) C!!!! DOUBLE PRECISION H(*), U(N), HU(N) * DOUBLE PRECISION DW(*), INNER REAL RW(*) * C============================= S T A T U S ============================= 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 REVISION STATUS: DATE AUTHOR VERSION C C JUNE 2, 1987 A. BUCKLEY 1.0 C C======================== D E S C R I P T I O N ======================== C C GIVEN THE QUASI NEWTON UPDATE MATRIX H (IN ZZ^T FORM) AND C GIVEN THE VECTOR U, THIS ROUTINE COMPUTES C C HU = H * U . C C IT ALSO RETURNS THE INTERMEDIATE VALUE SHAT = Z^T * U. C C-----NOTE THAT A NUMBER OF PARAMETERS WHICH WILL BE THE SAME C FOR EACH CALL TO BBMJDP DURING ANY PARTICULAR MINIMIZATION C PROBLEM ARE SET JUST ONCE THROUGH AN ENTRY POINT. C C------EACH UPDATE TERM OF H REQUIRES 3N+1 ENTRIES OF H. THE ORDER IS C C ETA(I), S(I), Y(I) AND SHAT(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 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 SEE BBMULT REGARDING THE USE OF INNER. 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------BETA IS THE PARAMETER DEFINING THE BROYDEN FAMILY C OF UPDATES. THE FORM USED IS C H! = H(DFP) + BETA * NU * W'W C SO THAT BETA = 1 GIVES THE BFGS UPDATE. C NOTE THAT H! DENOTES THE MATRIX OBTAINED BY C UPDATING H. BETA MUST BE 1 FOR PRODUCT UPDATES. C C------IF SCDIAG = .TRUE., H0 IS TAKEN TO BE A DIAGONAL MATRIX C WHICH IS AVAILABLE IN THE FIRST N C LOCATIONS OF THE ARRAY H. OTHERWISE, C H0 = I, AND IT IS OF COURSE NOT STORED. C C------IF SCGAMM = 2, THEN THE SO-CALLED GAMMA SCALING OF C OREN AND SPEDICATO, WHICH IS DESCRIBED C BY SHANNO, IS USED AT EACH UPDATE STEP. C THIS CAN IN FACT BE DONE ONLY IF THE C BFGS UPDATE IS BEING USED, I.E. IF C BETA = 1. NO EXTRA STORAGE IS NEEDED C TO IMPLEMENT THIS SCALING. IT IS NOT ALLOWED C WITH PRODUCT FORM UPDATES. C C------IF SCGAMM = 1, THEN SCALING IS DONE, AS JUST DESCRIBED C FOR SCGAMM=2, BUT IT ONLY APPLIES TO C THE FIRST UPDATE TERM. IT IS ALLOWED WITH C PRODUCT FORM UPDATES. C C-------IDENTY IS TRUE TO INDICATE THAT H0 = I; THIS MAY BE TRUE C EVEN IF SCDIAG IS TRUE. C C------INCR IS THE CONSTANT 2N+1, THE LENGTH OF EACH TERM. C BASE IS THE NO. OF LOCATIONS FOR THE DIAG. H0, EITHER 0 OR N. C COUNT NO OF TERMS DONE (INTERNAL COUNTER). C PTNU POINTER TO CURRENT RANK 2 TERM (INTERNAL POINTER). C C------TRACES: TURN ON TR TO SEE NU, ETA, GAMMA, HV AND S'V. C THESE 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 ======================= C C BBPOWL THE NATURAL ENTRY POINT. C BBSMJD AN ENTRY TO SET FIXED POINTERS. C C======================== S U B R O U T I N E S ======================== C C ZZMJDP A ROUTINE WHICH ACTUALLY IMPLEMENTS THE UPDATES. C C========================= P A R A M E T E R S ========================= C C NONE. C C================= L O C A L D E C L A R A T I O N S ================= * INTEGER PTDIAG, PTSHAT, PTW, PTZ, PTPHI, PTV, PTDELT, PTGAM, PTS INTEGER DIAG, SHAT, W, Z, PHI, V, DELT, GAM, S INTEGER PTR, R * C-----VARIABLES FOR THE ENTRY POINT. * LOGICAL TR, STR, TRV, STRV, SCDIAG, SSCDAG * INTEGER SCGAMM, TRACUN INTEGER SSCGAM, STRACN * C=============================== S A V E =============================== * SAVE TR, TRV, SCDIAG, SCGAMM, TRACUN SAVE W, SHAT, DIAG, Z, PHI, V, DELT, GAM, S, R * C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C NO DATA VALUES. C C========================== E X E C U T I O N ========================== * * CALL BBMJDP ( H(DIAG), H(SHAT), H(W), H(Z), H(PHI), H(V), - H(DELT), H(GAM), H(S), H(R), - U, HU, N, NUPS, I, M, IDENTY, INNER, IW, RW, DW ) * GOTO 90000 * C>>>>>>>>>>>>>>>>>>>>>>>>>>> E N T R Y BBSMJD >>>>>>>>>>>>>>>>>>>>>>>> * ENTRY BBSMJD ( STR, STRV, SSCDAG, PTDIAG, PTSHAT, PTW, - PTZ, PTPHI, PTV, PTDELT, PTGAM, PTS, PTR, SSCGAM, STRACN) * TR = STR TRV = STRV SCDIAG = SSCDAG * DIAG = PTDIAG SHAT = PTSHAT W = PTW Z = PTZ PHI = PTPHI V = PTV DELT = PTDELT GAM = PTGAM S = PTS R = PTR * SCGAMM = SSCGAM TRACUN = STRACN * RETURN * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NO FORMATS. C C================================ E N D ================================ * END SUBROUTINE BBUPDT ( N, G, S, XX, GG, H,CT, CNTRST, LASTPT, - IDENTY, NUPS, STEEPD, RSTEP, QNPART, - UPDATT, INNER, IW, RW, DW ) * C================ A R G U M E N T D E C L A R A T I O N S ============ * EXTERNAL INNER * INTEGER N, CT, CNTRST, LASTPT, NUPS, UPDATT, IW(*) * REAL G(N), S(N), XX(N), GG(N), H(*) C!!!! DOUBLE PRECISION G(N), S(N), XX(N), GG(N), H(*) * LOGICAL STEEPD, RSTEP, QNPART, IDENTY * DOUBLE PRECISION DW(*), INNER REAL RW(*) * C============================= S T A T U S ============================= 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 REVISION STATUS: DATE AUTHOR VERSION C C APR. 1, 1987 A. BUCKLEY 1.1 C 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. IF CG IS TRUE, C THEN, IN ADDITION, THE NEGATIVE OF THE NEW SEARCH DIRECTION MUST C BE COMPUTED AND RETURNED IN XX. 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 GG THE GRADIENT AT THE PREVIOUS POINT. C S THE STEP TAKEN ON THE LAST ITERATION. C H THE CURRENT MATRIX H. 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 UPDATT TO INDICATE WHAT TYPE OF QN UPDATES ARE BEING STORED, C I.E. SUM FORM (BBLNIR) OR PRODUCT FORM (NOCEDAL). 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 CNTRST THE NUMBER OF RESTARTS FORCED BY THE TEST DESCRIBED C UNDER HTEST. C NUPS THE NUMBER OF SUM TERMS DEFINING THE CURRENT C UPDATE MATRIX. C QNPART A FLAG WHICH IS TRUE WHEN WE ARE IN THE QUASI-NEWTON C PART OF THE CODE. C C THE VECTOR GG WILL ALSO BE USED AS A SCRATCH VECTOR. 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, OR ELSE, IN THE C EVENT OF A RESTART, H WILL HAVE REDEFINED BY A SINGLE UPDATE TERM. C THUS, THE FOLLOWING VALUES MUST BE SET BEFORE RETURNING: C C XX THE NEGATIVE OF THE NEW SEARCH DIRECTION. 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 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 ======================= C C BBUPDT ... THE NATURAL ENTRY POINT. C BBSUPD ... AN ENTRY TO INITIALIZE FIXED ARGUMENTS. C C======================== S U B R O U T I N E S ======================== C C BBMULT TO MULTIPLY BY A SUM FORM H. C BBNOCE TO MULTIPLY BY A PRODUCT FORM H. C MOD ... AN INTRINSIC. C INNER AN EXTERNAL ARGUMENT. C 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 = 8D0, TEN = 10D0 ) * LOGICAL DONORM, NONORM PARAMETER ( DONORM = .TRUE., NONORM = .FALSE. ) * C================= L O C A L D E C L A R A T I O N S ================= * C-----CONTROL PARAMETERS FOR ENTRY BBSUPD. * INTEGER M, BASE, INCR, SCGAMM, TRU, SHAT INTEGER SM, SBASE, SINCR, SSGAMM, STRU, SSHAT * 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, ISHAT * REAL SIGMA, TP1, TP2, MU, GAMMA, NU, ETA C!!!! DOUBLE PRECISION SIGMA, TP1, TP2, MU, GAMMA, NU, ETA * C=============================== S A V E =============================== * SAVE M, BASE, INCR, INU, SCGAMM, TRU, - CG, SCDIAG, USESHN, FROMRS, TR7, TR10, TRV * C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA VALUES. C 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 ( 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 AT WHICH TO FORCE THE NEXT RESTART. * IF ( FROMRS .AND. .NOT. USESHN ) THEN LASTPT = 1 + N ELSE LASTPT = M + 1 + N ENDIF * C SINCE A RESTART IS INDICATED, SAVE THE CURRENT S C AND U = H*Y = I*Y = Y = G - GG (THE BEALE RESTART C VECTORS) AND SAVE NU = Y'*H*Y = Y'Y AND ETA = S'Y IN C H(INU) AND H(IETA). I.E. DEFINE H[1]. AFTER A RESTART THE C DIAGONAL SCALING MATRIX IS ALWAYS JUST I. IF M = 0 WE C CAN NOT SAVE UPDATES SO REVERT TO A STEEPEST DESCENT C RESTART. * IF ( M .EQ. 0 ) THEN * DO 2950 J = 1,N XX(J) = G(J) 2950 CONTINUE * CT = 0 NUPS = 0 * ELSE * CT = 1 NUPS = 1 * ENDIF * QNPART = .TRUE. * IF ( SCDIAG ) THEN IDENTY = .TRUE. ENDIF * IF ( M .NE. 0 ) THEN * INU = BASE + 1 IETA = INU + 1 IU = IETA IS = IU + N * DO 3200 J=1,N H(IU+J) = G(J) - GG(J) H(IS+J) = S(J) 3200 CONTINUE * H(INU) = INNER ( N, H(IU+1), H(IU+1), NONORM, IW, RW, DW ) H(IETA) = INNER ( N, H(IU+1), S , NONORM, IW, RW, DW ) * IF(TR7)WRITE(TRU,*) ' [UPDT] SAVED NU, ETA->',H(INU),H(IETA) * ENDIF * C NOW H! IS DEFINED, SO COMPUTE H!*G FOR THE NEXT C SEARCH DIRECTION AND SAVE IT IN XX. CAN'T PUT XX INTO THE C SEARCH DIRECTION JUST YET BECAUSE OF THE "IF SAVE" IN C PHASE X-B. * CALL BBMULT ( H, G, XX, N, NUPS, 1, IDENTY, INNER, IW, RW, DW ) * E L S E I F ( CG .AND. UPDATT .EQ. SUMFRM ) T H E N * C >>>>>>>>>> P H A S E X - B: CG, SUM FORM UPDATE. <<<<<<<<< * C FIRST COMPUTE Y; PUT TEMPORARILY INTO XX. THEN WE MUST C COMPUTE H*Y (INTO GG). NOTE THAT H*Y IS CALLED U. WE C ALSO COMPUTE S'G (IN TP1) AND U'G (IN TP2), 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. * DO 3300 J = 1,N XX(J) = G(J) - GG(J) 3300 CONTINUE * CALL BBMULT ( H, XX, GG, N, NUPS, 1, IDENTY, INNER, IW, RW, DW) * NU = INNER( N, XX, GG, NONORM, IW, RW, DW ) ETA = INNER( N, S, XX, NONORM, IW, RW, DW ) TP1 = INNER( N, G, S, NONORM, IW, RW, DW ) TP2 = INNER( N, G, GG, NONORM, IW, RW, DW ) * C COMPUTE H!*G BY PUTTING H*G INTO XX 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 = 2. * CALL BBMULT (H, G, XX, N, NUPS, 1, IDENTY, INNER, IW, RW, DW ) * IF ( SCGAMM .EQ. 2 ) THEN SIGMA = ( TWO*TP1/ETA) - (TP2/NU) MU = -TP1/NU GAMMA = ETA/NU ELSE SIGMA = ( (ONE + NU/ETA)*TP1 - TP2 ) / ETA MU = -TP1/ETA GAMMA = ONE ENDIF * C NOW COMPUTE H!*G INTO XX. * DO 3700 J = 1,N XX(J) = GAMMA*XX(J) + SIGMA*S(J) + MU*GG(J) 3700 CONTINUE * IF ( QNPART ) THEN * NUPS = NUPS + 1 * C SAVE UPDATE TERMS: PUT NU,ETA,U AND S IN THE ARRAY H. * INU = INU + INCR IETA = INU + 1 IU = IETA IS = IU + N * DO 3900 J = 1,N H(IU+J) = GG(J) H(IS+J) = S(J) 3900 CONTINUE * H(INU) = NU H(IETA) = ETA * IF ( TR7 .OR. TR10 ) WRITE(TRU,*) ' [UPDT] NO RESTART;' - //' NUPS->',NUPS * IF ( TR7 ) WRITE(TRU,*) ' [UPDT] SAVING 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...". * E L S E I F ( CG .AND. UPDATT .EQ. PRDFRM ) T H E N * C >>>>>>>>>> P H A S E X - C: CG, PRODUCT FORM UPDATE. <<<<<<<<< * NUPS = MOD(NUPS,M) IETA = BASE + NUPS*INCR + 1 NUPS = NUPS + 1 IS = IETA IY = IS + N * DO 4100 J = 1,N H(IS+J) = S(J) H(IY+J) = G(J) - GG(J) 4100 CONTINUE * H(IETA) = INNER ( N, S, H(IY+1), NONORM, IW, RW, DW ) * IF ( TR7 .OR. TR10 ) WRITE(TRU,*) ' [UPDT] SAVING NOCEDAL' - //' UPDATE TERM.' * CALL BBNOCE ( H, G, XX, N, NUPS, CT, M, IDENTY, GG, - INNER, IW, RW, DW) * E L S E * C >>>>>>>>>> P H A S E X - D: Q N C A S E.<<<<<<<<<<<<<<<<<< * C A VARIABLE METRIC ALGORITHM IS BEING USED. CALCULATE GRADIENT C DIFFERENCE Y AND ETA = S'Y. SAVE Y IN GG. C S IS THE STEP . * DO 5000 J=1,N GG(J) = G(J) - GG(J) 5000 CONTINUE * ETA = INNER ( N, S, GG, NONORM, IW, RW, DW ) * 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. Y IS IN GG * NU = INNER ( N, GG, GG, NONORM, IW, RW, DW ) * C STORE THE INITIAL HESSIAN, WHICH IS H = (S'Y/Y'Y)*I = C (ETA/NU)*I. SO WE NEED TO RECALCULATE THE INITIAL C NU = Y'*H*Y = (ETA/NU)*(NU ABOVE) = ETA, AND TO C FIND XX = H*Y. Y IS IN GG. * 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*GG(K) * 6000 CONTINUE * NU = ETA * ELSE * C CALCULATE XX[CT] = H*Y AND NU = Y'*H*Y. Y IS IN GG. C REMEMBER THAT ONLY THE SYMMETRIC UPPER HALF OF H IS STORED C (IN ROW ORDER). * NU = ZERO * DO 6500 K = 1,N * TP1 = ZERO KJ = K * DO 6200 J=1,K-1 TP1 = TP1 + H(KJ)*GG(J) KJ = KJ + (N-J) 6200 CONTINUE * DO 6400 J=K,N TP1 = TP1 + H(KJ)*GG(J) KJ = KJ+1 6400 CONTINUE * NU = NU + TP1*GG(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 * DO 7000 K=1,N GG(K) = TP1*S(K) - XX(K) 7000 CONTINUE * 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*GG(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 ============================ C C THERE ARE NO FORMATS USED. C C================================ E N D ================================ * END SUBROUTINE BBVALS ( INTS, LOGS, REALS ) * C================ A R G U M E N T D E C L A R A T I O N S ============ * INTEGER INTS(*) * LOGICAL LOGS(*) * REAL REALS(*) C!!!! DOUBLE PRECISION REALS(*) * C============================= S T A T U S ============================= 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 REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 1 CONTROL OF DERIVATIVE MODE; SEE SECTION 3.13 C XNORM 2 NORM 2 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 TRACUN 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 1 SEE BBLSET IN LISTING OF BBLNIR C XALPS1 10 ALPIS1 1 SEE BBLSET IN LISTING OF BBLNIR C XSCGMM 11 SCGAMM 1 SEE BBLSET IN LISTING OF BBLNIR C XHTEST 12 HTEST 1 SEE BBLSET IN LISTING OF BBLNIR C XUPDTT 13 UPDATT 1 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 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 XRO 33 FLETSC F 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 ======================= C C BBVALS THE NATURAL ENTRY POINT TO RETURN THE VALUES. C BBSVAL AN ENTRY TO RESET THE VALUES. C BBRVAL AN ENTRY TO RESET THE VALUES BY READING NEW DATA IN. C C======================== S U B R O U T I N E S ======================== C C THERE ARE NO SUBROUTINES CALLED. C C========================= P A R A M E T E R S ========================= * * CHARACTER*(*) BLANK, QUOTE, HASH PARAMETER ( BLANK = ' ', QUOTE = '"', HASH = '#' ) * CHARACTER*(*) PERIOD, DASH, EQUALS PARAMETER ( PERIOD = '.', DASH = '-', EQUALS = '=' ) * 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 ) * C-----FOR ZZEVAL. * LOGICAL TRF, TRG, TRTEST PARAMETER ( TRF = F, TRG = F, TRTEST = F ) * INTEGER ETRACU, SCALE, DERVMD PARAMETER ( ETRACU = 6, SCALE = 0, DERVMD = 1 ) * C-----FOR ZZPRNT. * LOGICAL GRAD, POINT PARAMETER ( GRAD = T, POINT = T ) * INTEGER PTRACU PARAMETER ( PTRACU = 6 ) * C-----FOR ZZTERM. * INTEGER NORM, TTRACU PARAMETER ( NORM = 2, 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-----FOR BBLNIR. * INTEGER METH, QUADIN, ALPIS1, STSTEP PARAMETER ( METH = 0, QUADIN = 1, ALPIS1 = 1, STSTEP = 2 ) * INTEGER SCGAMM, HTEST, UPDATT PARAMETER ( SCGAMM = 1, HTEST = 1, UPDATT = 1 ) * 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 PARAMETER ( LTRACU = ETRACU ) * LOGICAL TRACE, TRCCUB PARAMETER ( TRACE = F, TRCCUB = F ) * C================= L O C A L D E C L A R A T I O N S ================= * 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 =============================== * SAVE * C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== * 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----DEFINE A 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 * DO 300 I = 1,NREALS REALS(I) = KEEPR(I) 300 CONTINUE * GOTO 90000 * C>>>>>>>>>>>>>>>>>>>>>>>>>> E N T R Y BBRVAL <<<<<<<<<<<<<<<<<<<<<<<<<< * 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. * ENTRY BBRVAL (WUNIT, RUNIT) * 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 ZZLCUC (CHECK) * 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 * DO 600 I = 1,NREALS KEEPR(I) = SREALS(I) 600 CONTINUE * 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 ============================ C C THERE ARE NO FORMATS USED. C C================================ E N D ================================ * END SUBROUTINE BBVSCG( FUNCNM, N, X, F, G, ACCT, STATUS, ITERS, FNCCT, - WORK, LWORK ) * C================ A R G U M E N T D E C L A R A T I O N S ============ * EXTERNAL FUNCNM * INTEGER N, STATUS, ITERS, FNCCT, LWORK * REAL X(N), F, G(N), ACCT, WORK(LWORK+1) C!!!! DOUBLE PRECISION X(N), F, G(N), ACCT, WORK(LWORK+1), FUNCNM * C============================= S T A T U S ============================= 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 REVISION STATUS: DATE AUTHOR VERSION C C APR. 2, 1987 A. BUCKLEY 1.1 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 IMPROVE 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. 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 C======================= E N T R Y P O I N T S ======================= C C BBVSCG ... THE NATURAL ENTRY POINT. C BBVIDF ... AN ENTRY TO REDEFINE THE ENTRY STATUS CODES. C BBVSDF ... AN ENTRY TO 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 ZZINNR ...FOR COMPUTING EUCLIDEAN INNER PRODUCTS. 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 = 8D0, TEN = 10D0 ) * C================= L O C A L D E C L A R A T I O N S ================= * EXTERNAL ZZINNR * 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! REAL RW(1) C1!!! DOUBLE PRECISION DW(1) * 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 ============================= C C THERE ARE NO COMMON BLOCKS. C 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 ========================== * 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. PSBACK .AND. STATUS .NE. RCG ) THEN * CALL ZZEGET( FNCT, GRCT, TIME ) CALL ZZPGET( TIME, ITCT ) CALL ZZSECS( TIME ) ACCT = TIME - TT FNCCT = FNCT ITERS = ITCT ENDIF * GOTO 90000 * C>>>>>>>>>>>>>>>>>>>>>>>>>> E N T R Y BBVIDF <<<<<<<<<<<<<<<<<<<<<<<<<< * C 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 ============================ C C THERE ARE NO FORMATS USED. C C================================ E N D ================================ * END REAL FUNCTION ZZMPAR(I) C!!!! DOUBLE PRECISION FUNCTION ZZMPAR(I) * C============== A R G U M E N T D E C L A R A T I O N S ============== * INTEGER I * C============================= S T A T U S ============================= 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 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 REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZMPAR C C======================== S U B R O U T I N E S ======================== C C NO SUBROUTINES OR FUNCTIONS ARE CALLED C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * 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) * C=============================== S A V E =============================== * SAVE RMACH C!!!! SAVE DMACH * 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 ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C-----MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES (FTN 5). * * 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 ========================== * ZZMPAR = RMACH(I) C!!!! ZZMPAR = DMACH(I) * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZSECS(SECS) * C============== A R G U M E N T D E C L A R A T I O N S ============== * REAL SECS C!!!! DOUBLE PRECISION SECS * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR CPU USAGE. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR CYBER/FTN5 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 REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C 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 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 C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZSECS C C======================== S U B R O U T I N E S ======================== C C A SYSTEM CLOCK. C 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 A R A T I O N S ================= * 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 ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== * DATA FIRST/.TRUE./ * 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZDATE (CHDATE) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER *(*) CHDATE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM ROUTINE FOR DATE. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR VAX/BERK4.2(3) C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 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 C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZDATE C C======================== S U B R O U T I N E S ======================== C C SYSTEM DATE ROUTINE. C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * 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 ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C 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---- INITIALIZE CHDATE * CHDATE = '( + + )' * CALL FDATE(UNXDAT) * CHDATE(2:3) = UNXDAT(23:24) * CHDATE(8:9) = UNXDAT(9:10) * TEMP = UNXDAT(5:7) CALL ZZLCUC(TEMP) * 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZLCUC ( LINE ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER * (*) LINE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: THE ACTIONS DEPEND UPON THE UNDERLYING C CHARACTER SET. MOST VERSIONS ASSUME AN ASCII C OR EBCDIC CHARACTER SET WITH EACH CHARACTER C OCCUPYING ONE BYTE. THE CYBER VERSION ASSUMES 6- C 12 BIT CODES FOR UPPER/LOWER CASE. ALL THAT HAP- C PENS IS THAT THE ESCAPE CODES @ AND ^ ARE REMOVED. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR VAX/BERK4.2(3) C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C C LINE CONTAINS THE CHARACTERS TO BE CONVERTED TO UPPER CASE. C NOTE THAT ON SOME SYSTEMS (NOTABLY THE OLD ARCHITECTURE C CDC CYBERS), UPPER AND LOWER CASE CHARACTERS HAVE DIFFERENT C LENGTHS, SO THE LINE LENGTH MAY BE CHANGED BY THIS ROUTINE. C C THE ROUTINE ASSUMES THAT THE VALUE C C ICHAR ( UPPER-CASE OF LETTER ) - ICHAR ( LOWER-CASE LETTER ) C C IS FIXED, I.E. IT IS THE SAME FOR EACH LETTER =A,B,...,Z. C C THIS SHOULD BE TRUE ON MOST EBCDIC OR ASCII SYSTEMS. C C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZLCUC C C======================== S U B R O U T I N E S ======================== C C INDEX ...GENERIC C ZZLENG ...NON-BLANK LENGTH OF A LINE C C CHAR, ICHAR ...INTRINSIC C C========================= P A R A M E T E R S ========================= * CHARACTER * (*) LCALPH PARAMETER ( LCALPH = 'abcdefghijklmnopqrstuvwxyz' ) * C================= L O C A L D E C L A R A T I O N S ================= * LOGICAL FIRST * CHARACTER CH * INTEGER I, ZZLENG, WLEN, SHIFT * C=============================== S A V E =============================== SAVE FIRST, SHIFT * C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== DATA FIRST/.TRUE./ * C========================== E X E C U T I O N ========================== * WLEN = ZZLENG(LINE) * IF ( FIRST ) THEN SHIFT = ICHAR( 'A' ) - ICHAR( 'a' ) FIRST = .FALSE. ENDIF * DO 100 I = 1, WLEN * CH = LINE( I:I ) * IF ( INDEX( LCALPH, CH ) .NE. 0 ) THEN * LINE( I:I ) = CHAR( ICHAR( CH ) + SHIFT ) * ENDIF * 100 CONTINUE * GO TO 90000 * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END REAL FUNCTION ZZMPAR(I) C!!!! DOUBLE PRECISION FUNCTION ZZMPAR(I) * C============== A R G U M E N T D E C L A R A T I O N S ============== * INTEGER I * C============================= S T A T U S ============================= 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 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 REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZMPAR C C======================== S U B R O U T I N E S ======================== C C NO SUBROUTINES OR FUNCTIONS ARE CALLED C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * 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) * C=============================== S A V E =============================== * SAVE RMACH C!!!! SAVE DMACH * 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 ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C 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 ========================== * ZZMPAR = RMACH(I) C!!!! ZZMPAR = DMACH(I) * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZSECS(SECS) * C============== A R G U M E N T D E C L A R A T I O N S ============== * REAL SECS C!!!! DOUBLE PRECISION SECS * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR CPU USAGE. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR VAX/BERK4.2(3) 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 REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C 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 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 C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZSECS C C======================== S U B R O U T I N E S ======================== C C A SYSTEM CLOCK. C 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 A R A T I O N S ================= * 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 ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== * DATA FIRST/.TRUE./ * 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZTIME ( CHTIME ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER *(*) CHTIME * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR TIME OF DAY. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR VAX/BERK4.2(3) C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZTIME C C======================== S U B R O U T I N E S ======================== C C SYSTEM ROUTINE TO GET TIME OF DAY. C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * CHARACTER * 24 UNXTIM * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA STATEMENTS. C 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZDATE (CHDATE) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER *(*) CHDATE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM ROUTINE FOR DATE. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR CYBER/FTN5 C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 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 C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZDATE C C======================== S U B R O U T I N E S ======================== C C SYSTEM DATE ROUTINE. C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * CHARACTER * 10 DATE * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA VALUES. C 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZLCUC ( LINE ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER * (*) LINE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: THE ACTIONS DEPEND UPON THE UNDERLYING C CHARACTER SET. MOST VERSIONS ASSUME AN ASCII C OR EBCDIC CHARACTER SET WITH EACH CHARACTER C OCCUPYING ONE BYTE. THE CYBER VERSION ASSUMES 6- C 12 BIT CODES FOR UPPER/LOWER CASE. ALL THAT HAP- C PENS IS THAT THE ESCAPE CODES @ AND ^ ARE REMOVED. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR CYBER/FTN5 C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C C LINE CONTAINS THE CHARACTERS TO BE CONVERTED TO UPPER CASE. C NOTE THAT ON SOME SYSTEMS (NOTABLY THE OLD ARCHITECTURE C CDC CYBERS), UPPER AND LOWER CASE CHARACTERS HAVE DIFFERENT C LENGTHS, SO THE LINE LENGTH MAY BE CHANGED BY THIS ROUTINE. C C NOTE THAT IF IT HAPPENS THAT THE CONVERTED PART IS SHORTER AFTER C THE CONVERSION, THEN THE UNCONVERTED PART IS LEFT SHIFTED TO C FILL IN THE SPACE CREATED AS FOLLOWS (HERE WLEN IS THE C LENGTH OF THE WHOLE LINE. C C BEFORE CONVERSION C +----------------------------+-----------------------+ C ! CHARACTERS BEING CONVERTED ! SUBSEQUENT CHARACTERS ! C +----------------------------+-----------------------+ C 1 .. LENGTH LENGTH+1 .. WLEN C C AFTER CONVERSION C +----------------------+ +-----------------------+ C ! CONVERTED CHARACTERS ! <== ! SUBSEQUENT CHARACTERS ! C +----------------------+ +-----------------------+ C 1 .. J J+1 .. N C C WHERE J <= LENGTH AND ( WLEN - LENGTH ) = ( N - J ). C C THE RIGHT HAND SIDE IS BLANK FILLED IF THERE IS A SHIFT. C C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZLCUC C C======================== S U B R O U T I N E S ======================== C C INDEX ...GENERIC C ZZLENG ...NON-BLANK LENGTH OF A LINE C C MIN ...INTRINSIC C ZZSHFT ...TO SHIFT A STRING C C========================= P A R A M E T E R S ========================= * CHARACTER * (*) SPEC, BLANK PARAMETER ( SPEC = '^@', BLANK = ' ' ) * C================= L O C A L D E C L A R A T I O N S ================= * INTEGER I, J, L, ZZLENG, WLEN * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C C THERE ARE NO DATA VALUES. C * IF ( WLEN .NE. 0 ) THEN * I = 0 J = 0 * L = WLEN * 100 I = I + 1 J = J + 1 * IF ( I .LT. L .AND. INDEX( SPEC, LINE(I:I) ) .NE. 0 ) THEN * I = I + 1 * ENDIF * IF ( J .NE. I ) THEN LINE(J:J) = LINE(I:I) ENDIF * IF ( I .LT. L ) THEN GOTO 100 ENDIF C BLANK FILL. IF ( J .LT. L ) THEN LINE(J+1:L) = BLANK ENDIF * ENDIF * GO TO 90000 * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END REAL FUNCTION ZZMPAR(I) C!!!! DOUBLE PRECISION FUNCTION ZZMPAR(I) * C============== A R G U M E N T D E C L A R A T I O N S ============== * INTEGER I * C============================= S T A T U S ============================= 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 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 REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZMPAR C C======================== S U B R O U T I N E S ======================== C C NO SUBROUTINES OR FUNCTIONS ARE CALLED C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * 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) * C=============================== S A V E =============================== * SAVE RMACH C!!!! SAVE DMACH * 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 ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C-----MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES (FTN 5). * * 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 ========================== * ZZMPAR = RMACH(I) C!!!! ZZMPAR = DMACH(I) * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZSECS(SECS) * C============== A R G U M E N T D E C L A R A T I O N S ============== * REAL SECS C!!!! DOUBLE PRECISION SECS * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR CPU USAGE. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR CYBER/FTN5 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 REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C 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 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 C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZSECS C C======================== S U B R O U T I N E S ======================== C C A SYSTEM CLOCK. C 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 A R A T I O N S ================= * 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 ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== * DATA FIRST/.TRUE./ * 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZTIME ( CHTIME ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER *(*) CHTIME * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR TIME OF DAY. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR CYBER/FTN5 C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZTIME C C======================== S U B R O U T I N E S ======================== C C SYSTEM ROUTINE TO GET TIME OF DAY. C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * CHARACTER * 10 TIME * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA STATEMENTS. C 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZDATE (CHDATE) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER *(*) CHDATE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM ROUTINE FOR DATE. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR HW6 C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 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 C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZDATE C C======================== S U B R O U T I N E S ======================== C C SYSTEM DATE ROUTINE. C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * CHARACTER * 24 HWDATE INTEGER * 8 CLOCK_ * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA VALUES. C 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZLCUC ( LINE ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER * (*) LINE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: THE ACTIONS DEPEND UPON THE UNDERLYING C CHARACTER SET. MOST VERSIONS ASSUME AN ASCII C OR EBCDIC CHARACTER SET WITH EACH CHARACTER C OCCUPYING ONE BYTE. THE CYBER VERSION ASSUMES 6- C 12 BIT CODES FOR UPPER/LOWER CASE. ALL THAT HAP- C PENS IS THAT THE ESCAPE CODES @ AND ^ ARE REMOVED. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR HW6 C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C C LINE CONTAINS THE CHARACTERS TO BE CONVERTED TO UPPER CASE. C NOTE THAT ON SOME SYSTEMS (NOTABLY THE OLD ARCHITECTURE C CDC CYBERS), UPPER AND LOWER CASE CHARACTERS HAVE DIFFERENT C LENGTHS, SO THE LINE LENGTH MAY BE CHANGED BY THIS ROUTINE. C C THE ROUTINE ASSUMES THAT THE VALUE C C ICHAR ( UPPER-CASE OF LETTER ) - ICHAR ( LOWER-CASE LETTER ) C C IS FIXED, I.E. IT IS THE SAME FOR EACH LETTER =A,B,...,Z. C C THIS SHOULD BE TRUE ON MOST EBCDIC OR ASCII SYSTEMS. C C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZLCUC C C======================== S U B R O U T I N E S ======================== C C INDEX ...GENERIC C ZZLENG ...NON-BLANK LENGTH OF A LINE C C CHAR, ICHAR ...INTRINSIC C C========================= P A R A M E T E R S ========================= * CHARACTER * (*) LCALPH PARAMETER ( LCALPH = 'abcdefghijklmnopqrstuvwxyz' ) * C================= L O C A L D E C L A R A T I O N S ================= * LOGICAL FIRST * CHARACTER CH * INTEGER I, ZZLENG, WLEN, SHIFT * C=============================== S A V E =============================== SAVE FIRST, SHIFT * C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== DATA FIRST/.TRUE./ * C========================== E X E C U T I O N ========================== * WLEN = ZZLENG(LINE) * IF ( FIRST ) THEN SHIFT = ICHAR( 'A' ) - ICHAR( 'a' ) FIRST = .FALSE. ENDIF * DO 100 I = 1, WLEN * CH = LINE( I:I ) * IF ( INDEX( LCALPH, CH ) .NE. 0 ) THEN * LINE( I:I ) = CHAR( ICHAR( CH ) + SHIFT ) * ENDIF * 100 CONTINUE * GO TO 90000 * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END REAL FUNCTION ZZMPAR(I) C!!!! DOUBLE PRECISION FUNCTION ZZMPAR(I) * C============== A R G U M E N T D E C L A R A T I O N S ============== * INTEGER I * C============================= S T A T U S ============================= 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 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 REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZMPAR C C======================== S U B R O U T I N E S ======================== C C NO SUBROUTINES OR FUNCTIONS ARE CALLED C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * 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) * C=============================== S A V E =============================== * SAVE RMACH C!!!! SAVE DMACH * 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 ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C 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 ========================== * ZZMPAR = RMACH(I) C!!!! ZZMPAR = DMACH(I) * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZSECS(SECS) * C============== A R G U M E N T D E C L A R A T I O N S ============== * REAL SECS C!!!! DOUBLE PRECISION SECS * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR CPU USAGE. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR HW6 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 REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C 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 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 C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZSECS C C======================== S U B R O U T I N E S ======================== C C A SYSTEM CLOCK. C 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 A R A T I O N S ================= * 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 ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== * DATA FIRST/.TRUE./ * 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZTIME ( CHTIME ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER *(*) CHTIME * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR TIME OF DAY. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR HW6 C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZTIME C C======================== S U B R O U T I N E S ======================== C C SYSTEM ROUTINE TO GET TIME OF DAY. C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * CHARACTER * 24 HWTIME * INTEGER * 8 CLOCK_ INTEGER SECS * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA STATEMENTS. C 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZDATE (CHDATE) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER *(*) CHDATE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM ROUTINE FOR DATE. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR MAC/MS C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 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 C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZDATE C C======================== S U B R O U T I N E S ======================== C C SYSTEM DATE ROUTINE. C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * INTEGER MM, DD, YY * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA VALUES. C 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZLCUC ( LINE ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER * (*) LINE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: THE ACTIONS DEPEND UPON THE UNDERLYING C CHARACTER SET. MOST VERSIONS ASSUME AN ASCII C OR EBCDIC CHARACTER SET WITH EACH CHARACTER C OCCUPYING ONE BYTE. THE CYBER VERSION ASSUMES 6- C 12 BIT CODES FOR UPPER/LOWER CASE. ALL THAT HAP- C PENS IS THAT THE ESCAPE CODES @ AND ^ ARE REMOVED. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR MAC/MS C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C C LINE CONTAINS THE CHARACTERS TO BE CONVERTED TO UPPER CASE. C NOTE THAT ON SOME SYSTEMS (NOTABLY THE OLD ARCHITECTURE C CDC CYBERS), UPPER AND LOWER CASE CHARACTERS HAVE DIFFERENT C LENGTHS, SO THE LINE LENGTH MAY BE CHANGED BY THIS ROUTINE. C C THE ROUTINE ASSUMES THAT THE VALUE C C ICHAR ( UPPER-CASE OF LETTER ) - ICHAR ( LOWER-CASE LETTER ) C C IS FIXED, I.E. IT IS THE SAME FOR EACH LETTER =A,B,...,Z. C C THIS SHOULD BE TRUE ON MOST EBCDIC OR ASCII SYSTEMS. C C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZLCUC C C======================== S U B R O U T I N E S ======================== C C INDEX ...GENERIC C ZZLENG ...NON-BLANK LENGTH OF A LINE C C CHAR, ICHAR ...INTRINSIC C C========================= P A R A M E T E R S ========================= * CHARACTER * (*) LCALPH PARAMETER ( LCALPH = 'abcdefghijklmnopqrstuvwxyz' ) * C================= L O C A L D E C L A R A T I O N S ================= * LOGICAL FIRST * CHARACTER CH * INTEGER I, ZZLENG, WLEN, SHIFT * C=============================== S A V E =============================== SAVE FIRST, SHIFT * C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== DATA FIRST/.TRUE./ * C========================== E X E C U T I O N ========================== * WLEN = ZZLENG(LINE) * IF ( FIRST ) THEN SHIFT = ICHAR( 'A' ) - ICHAR( 'a' ) FIRST = .FALSE. ENDIF * DO 100 I = 1, WLEN * CH = LINE( I:I ) * IF ( INDEX( LCALPH, CH ) .NE. 0 ) THEN * LINE( I:I ) = CHAR( ICHAR( CH ) + SHIFT ) * ENDIF * 100 CONTINUE * GO TO 90000 * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END REAL FUNCTION ZZMPAR(I) C!!!! DOUBLE PRECISION FUNCTION ZZMPAR(I) * C============== A R G U M E N T D E C L A R A T I O N S ============== * INTEGER I * C============================= S T A T U S ============================= 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 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 REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZMPAR C C======================== S U B R O U T I N E S ======================== C C NO SUBROUTINES OR FUNCTIONS ARE CALLED C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * 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) * C=============================== S A V E =============================== * SAVE RMACH C!!!! SAVE DMACH * 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 ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C 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 ========================== * ZZMPAR = RMACH(I) C!!!! ZZMPAR = DMACH(I) * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZSECS(SECS) * C============== A R G U M E N T D E C L A R A T I O N S ============== * REAL SECS C!!!! DOUBLE PRECISION SECS * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR CPU USAGE. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR MAC/MS 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 REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C 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 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 C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZSECS C C======================== S U B R O U T I N E S ======================== C C A SYSTEM CLOCK. C 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 A R A T I O N S ================= * 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 ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== * DATA FIRST/.TRUE./ * 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZTIME ( CHTIME ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER *(*) CHTIME * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR TIME OF DAY. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR MAC/MS C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZTIME C C======================== S U B R O U T I N E S ======================== C C SYSTEM ROUTINE TO GET TIME OF DAY. C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * INTEGER SECNDS, MINUTS, HOURS * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA STATEMENTS. C 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZDATE (CHDATE) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER *(*) CHDATE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM ROUTINE FOR DATE. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR SUN3 C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 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 C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZDATE C C======================== S U B R O U T I N E S ======================== C C SYSTEM DATE ROUTINE. C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * 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 ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C 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---- INITIALIZE CHDATE * CHDATE = '( + + )' * CALL FDATE(UNXDAT) * CHDATE(2:3) = UNXDAT(23:24) * CHDATE(8:9) = UNXDAT(9:10) * TEMP = UNXDAT(5:7) CALL ZZLCUC(TEMP) * 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZLCUC ( LINE ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER * (*) LINE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: THE ACTIONS DEPEND UPON THE UNDERLYING C CHARACTER SET. MOST VERSIONS ASSUME AN ASCII C OR EBCDIC CHARACTER SET WITH EACH CHARACTER C OCCUPYING ONE BYTE. THE CYBER VERSION ASSUMES 6- C 12 BIT CODES FOR UPPER/LOWER CASE. ALL THAT HAP- C PENS IS THAT THE ESCAPE CODES @ AND ^ ARE REMOVED. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR SUN3 C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C C LINE CONTAINS THE CHARACTERS TO BE CONVERTED TO UPPER CASE. C NOTE THAT ON SOME SYSTEMS (NOTABLY THE OLD ARCHITECTURE C CDC CYBERS), UPPER AND LOWER CASE CHARACTERS HAVE DIFFERENT C LENGTHS, SO THE LINE LENGTH MAY BE CHANGED BY THIS ROUTINE. C C THE ROUTINE ASSUMES THAT THE VALUE C C ICHAR ( UPPER-CASE OF LETTER ) - ICHAR ( LOWER-CASE LETTER ) C C IS FIXED, I.E. IT IS THE SAME FOR EACH LETTER =A,B,...,Z. C C THIS SHOULD BE TRUE ON MOST EBCDIC OR ASCII SYSTEMS. C C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZLCUC C C======================== S U B R O U T I N E S ======================== C C INDEX ...GENERIC C ZZLENG ...NON-BLANK LENGTH OF A LINE C C CHAR, ICHAR ...INTRINSIC C C========================= P A R A M E T E R S ========================= * CHARACTER * (*) LCALPH PARAMETER ( LCALPH = 'abcdefghijklmnopqrstuvwxyz' ) * C================= L O C A L D E C L A R A T I O N S ================= * LOGICAL FIRST * CHARACTER CH * INTEGER I, ZZLENG, WLEN, SHIFT * C=============================== S A V E =============================== SAVE FIRST, SHIFT * C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== DATA FIRST/.TRUE./ * C========================== E X E C U T I O N ========================== * WLEN = ZZLENG(LINE) * IF ( FIRST ) THEN SHIFT = ICHAR( 'A' ) - ICHAR( 'a' ) FIRST = .FALSE. ENDIF * DO 100 I = 1, WLEN * CH = LINE( I:I ) * IF ( INDEX( LCALPH, CH ) .NE. 0 ) THEN * LINE( I:I ) = CHAR( ICHAR( CH ) + SHIFT ) * ENDIF * 100 CONTINUE * GO TO 90000 * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END REAL FUNCTION ZZMPAR(I) C!!!! DOUBLE PRECISION FUNCTION ZZMPAR(I) * C============== A R G U M E N T D E C L A R A T I O N S ============== * INTEGER I * C============================= S T A T U S ============================= 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 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 REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZMPAR C C======================== S U B R O U T I N E S ======================== C C NO SUBROUTINES OR FUNCTIONS ARE CALLED C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * 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) * C=============================== S A V E =============================== * SAVE RMACH C!!!! SAVE DMACH * 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 ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C 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 ========================== * ZZMPAR = RMACH(I) C!!!! ZZMPAR = DMACH(I) * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZSECS(SECS) * C============== A R G U M E N T D E C L A R A T I O N S ============== * REAL SECS C!!!! DOUBLE PRECISION SECS * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR CPU USAGE. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR SUN3 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 REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C 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 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 C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZSECS C C======================== S U B R O U T I N E S ======================== C C A SYSTEM CLOCK. C 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 A R A T I O N S ================= * 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 ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== * DATA FIRST/.TRUE./ * 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZTIME ( CHTIME ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER *(*) CHTIME * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR TIME OF DAY. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR SUN3 C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZTIME C C======================== S U B R O U T I N E S ======================== C C SYSTEM ROUTINE TO GET TIME OF DAY. C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * CHARACTER * 24 UNXTIM * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA STATEMENTS. C 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZDATE (CHDATE) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER *(*) CHDATE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM ROUTINE FOR DATE. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR SUN4 C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 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 C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZDATE C C======================== S U B R O U T I N E S ======================== C C SYSTEM DATE ROUTINE. C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * 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 ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C 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---- INITIALIZE CHDATE * CHDATE = '( + + )' * CALL FDATE(UNXDAT) * CHDATE(2:3) = UNXDAT(23:24) * CHDATE(8:9) = UNXDAT(9:10) * TEMP = UNXDAT(5:7) CALL ZZLCUC(TEMP) * 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZLCUC ( LINE ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER * (*) LINE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: THE ACTIONS DEPEND UPON THE UNDERLYING C CHARACTER SET. MOST VERSIONS ASSUME AN ASCII C OR EBCDIC CHARACTER SET WITH EACH CHARACTER C OCCUPYING ONE BYTE. THE CYBER VERSION ASSUMES 6- C 12 BIT CODES FOR UPPER/LOWER CASE. ALL THAT HAP- C PENS IS THAT THE ESCAPE CODES @ AND ^ ARE REMOVED. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR SUN4 C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C C LINE CONTAINS THE CHARACTERS TO BE CONVERTED TO UPPER CASE. C NOTE THAT ON SOME SYSTEMS (NOTABLY THE OLD ARCHITECTURE C CDC CYBERS), UPPER AND LOWER CASE CHARACTERS HAVE DIFFERENT C LENGTHS, SO THE LINE LENGTH MAY BE CHANGED BY THIS ROUTINE. C C THE ROUTINE ASSUMES THAT THE VALUE C C ICHAR ( UPPER-CASE OF LETTER ) - ICHAR ( LOWER-CASE LETTER ) C C IS FIXED, I.E. IT IS THE SAME FOR EACH LETTER =A,B,...,Z. C C THIS SHOULD BE TRUE ON MOST EBCDIC OR ASCII SYSTEMS. C C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZLCUC C C======================== S U B R O U T I N E S ======================== C C INDEX ...GENERIC C ZZLENG ...NON-BLANK LENGTH OF A LINE C C CHAR, ICHAR ...INTRINSIC C C========================= P A R A M E T E R S ========================= * CHARACTER * (*) LCALPH PARAMETER ( LCALPH = 'abcdefghijklmnopqrstuvwxyz' ) * C================= L O C A L D E C L A R A T I O N S ================= * LOGICAL FIRST * CHARACTER CH * INTEGER I, ZZLENG, WLEN, SHIFT * C=============================== S A V E =============================== SAVE FIRST, SHIFT * C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== DATA FIRST/.TRUE./ * C========================== E X E C U T I O N ========================== * WLEN = ZZLENG(LINE) * IF ( FIRST ) THEN SHIFT = ICHAR( 'A' ) - ICHAR( 'a' ) FIRST = .FALSE. ENDIF * DO 100 I = 1, WLEN * CH = LINE( I:I ) * IF ( INDEX( LCALPH, CH ) .NE. 0 ) THEN * LINE( I:I ) = CHAR( ICHAR( CH ) + SHIFT ) * ENDIF * 100 CONTINUE * GO TO 90000 * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END REAL FUNCTION ZZMPAR(I) C!!!! DOUBLE PRECISION FUNCTION ZZMPAR(I) * C============== A R G U M E N T D E C L A R A T I O N S ============== * INTEGER I * C============================= S T A T U S ============================= 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 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 REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZMPAR C C======================== S U B R O U T I N E S ======================== C C NO SUBROUTINES OR FUNCTIONS ARE CALLED C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * 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) * C=============================== S A V E =============================== * SAVE RMACH C!!!! SAVE DMACH * 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 ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C-----MACHINE CONSTANTS FOR THE SUN-4. * DATA MCHEPS(1),MCHEPS(2) / 9472, 0 / C!!!! DATA DMACH(1) /1.11022302D-16 / C!!!! DATA MCHEPS(1) / 13568 / * DATA MINMAG(1),MINMAG(2) / 128, 0 / C!!!! DATA DMACH(2) /4.94065646D-324 / C!!!! DATA MINMAG(1) / 128 / * DATA MAXMAG(1),MAXMAG(2) / -32769, -1 / C!!!! DATA DMACH(3) /1.79769313D+308 / C!!!! DATA MAXMAG(1) / -32769 / * 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZSECS(SECS) * C============== A R G U M E N T D E C L A R A T I O N S ============== * REAL SECS C!!!! DOUBLE PRECISION SECS * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR CPU USAGE. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR SUN4 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 REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C 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 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 C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZSECS C C======================== S U B R O U T I N E S ======================== C C A SYSTEM CLOCK. C 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 A R A T I O N S ================= * 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 ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== * DATA FIRST/.TRUE./ * 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZTIME ( CHTIME ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER *(*) CHTIME * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR TIME OF DAY. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR SUN4 C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZTIME C C======================== S U B R O U T I N E S ======================== C C SYSTEM ROUTINE TO GET TIME OF DAY. C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * CHARACTER * 24 UNXTIM * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA STATEMENTS. C 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZDATE (CHDATE) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER *(*) CHDATE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM ROUTINE FOR DATE. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR VAX/VMS C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 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 C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZDATE C C======================== S U B R O U T I N E S ======================== C C SYSTEM DATE ROUTINE. C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * 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 ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C 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---- 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZLCUC ( LINE ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER * (*) LINE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: THE ACTIONS DEPEND UPON THE UNDERLYING C CHARACTER SET. MOST VERSIONS ASSUME AN ASCII C OR EBCDIC CHARACTER SET WITH EACH CHARACTER C OCCUPYING ONE BYTE. THE CYBER VERSION ASSUMES 6- C 12 BIT CODES FOR UPPER/LOWER CASE. ALL THAT HAP- C PENS IS THAT THE ESCAPE CODES @ AND ^ ARE REMOVED. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR VAX/VMS C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C C LINE CONTAINS THE CHARACTERS TO BE CONVERTED TO UPPER CASE. C NOTE THAT ON SOME SYSTEMS (NOTABLY THE OLD ARCHITECTURE C CDC CYBERS), UPPER AND LOWER CASE CHARACTERS HAVE DIFFERENT C LENGTHS, SO THE LINE LENGTH MAY BE CHANGED BY THIS ROUTINE. C C THE ROUTINE ASSUMES THAT THE VALUE C C ICHAR ( UPPER-CASE OF LETTER ) - ICHAR ( LOWER-CASE LETTER ) C C IS FIXED, I.E. IT IS THE SAME FOR EACH LETTER =A,B,...,Z. C C THIS SHOULD BE TRUE ON MOST EBCDIC OR ASCII SYSTEMS. C C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZLCUC C C======================== S U B R O U T I N E S ======================== C C INDEX ...GENERIC C ZZLENG ...NON-BLANK LENGTH OF A LINE C C CHAR, ICHAR ...INTRINSIC C C========================= P A R A M E T E R S ========================= * CHARACTER * (*) LCALPH PARAMETER ( LCALPH = 'abcdefghijklmnopqrstuvwxyz' ) * C================= L O C A L D E C L A R A T I O N S ================= * LOGICAL FIRST * CHARACTER CH * INTEGER I, ZZLENG, WLEN, SHIFT * C=============================== S A V E =============================== SAVE FIRST, SHIFT * C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== DATA FIRST/.TRUE./ * C========================== E X E C U T I O N ========================== * WLEN = ZZLENG(LINE) * IF ( FIRST ) THEN SHIFT = ICHAR( 'A' ) - ICHAR( 'a' ) FIRST = .FALSE. ENDIF * DO 100 I = 1, WLEN * CH = LINE( I:I ) * IF ( INDEX( LCALPH, CH ) .NE. 0 ) THEN * LINE( I:I ) = CHAR( ICHAR( CH ) + SHIFT ) * ENDIF * 100 CONTINUE * GO TO 90000 * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END REAL FUNCTION ZZMPAR(I) C!!!! DOUBLE PRECISION FUNCTION ZZMPAR(I) * C============== A R G U M E N T D E C L A R A T I O N S ============== * INTEGER I * C============================= S T A T U S ============================= 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 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 REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZMPAR C C======================== S U B R O U T I N E S ======================== C C NO SUBROUTINES OR FUNCTIONS ARE CALLED C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * 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) * C=============================== S A V E =============================== * SAVE RMACH C!!!! SAVE DMACH * 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 ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C 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 ========================== * ZZMPAR = RMACH(I) C!!!! ZZMPAR = DMACH(I) * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZSECS(SECS) * C============== A R G U M E N T D E C L A R A T I O N S ============== * REAL SECS C!!!! DOUBLE PRECISION SECS * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR CPU USAGE. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR VAX/VMS 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 REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C 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 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 C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZSECS C C======================== S U B R O U T I N E S ======================== C C A SYSTEM CLOCK. C 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 A R A T I O N S ================= * 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 ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== * DATA FIRST/.TRUE./ * 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZTIME ( CHTIME ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER *(*) CHTIME * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR TIME OF DAY. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR VAX/VMS C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZTIME C C======================== S U B R O U T I N E S ======================== C C SYSTEM ROUTINE TO GET TIME OF DAY. C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * CHARACTER * 8 VAXTIM * * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA STATEMENTS. C 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZDATE (CHDATE) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER *(*) CHDATE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM ROUTINE FOR DATE. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR VAX/BERK4.2(3) C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 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 C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZDATE C C======================== S U B R O U T I N E S ======================== C C SYSTEM DATE ROUTINE. C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * 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 ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C 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---- INITIALIZE CHDATE * CHDATE = '( + + )' * CALL FDATE(UNXDAT) * CHDATE(2:3) = UNXDAT(23:24) * CHDATE(8:9) = UNXDAT(9:10) * TEMP = UNXDAT(5:7) CALL ZZLCUC(TEMP) * 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZLCUC ( LINE ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER * (*) LINE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: THE ACTIONS DEPEND UPON THE UNDERLYING C CHARACTER SET. MOST VERSIONS ASSUME AN ASCII C OR EBCDIC CHARACTER SET WITH EACH CHARACTER C OCCUPYING ONE BYTE. THE CYBER VERSION ASSUMES 6- C 12 BIT CODES FOR UPPER/LOWER CASE. ALL THAT HAP- C PENS IS THAT THE ESCAPE CODES @ AND ^ ARE REMOVED. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR VAX/BERK4.2(3) C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C C LINE CONTAINS THE CHARACTERS TO BE CONVERTED TO UPPER CASE. C NOTE THAT ON SOME SYSTEMS (NOTABLY THE OLD ARCHITECTURE C CDC CYBERS), UPPER AND LOWER CASE CHARACTERS HAVE DIFFERENT C LENGTHS, SO THE LINE LENGTH MAY BE CHANGED BY THIS ROUTINE. C C THE ROUTINE ASSUMES THAT THE VALUE C C ICHAR ( UPPER-CASE OF LETTER ) - ICHAR ( LOWER-CASE LETTER ) C C IS FIXED, I.E. IT IS THE SAME FOR EACH LETTER =A,B,...,Z. C C THIS SHOULD BE TRUE ON MOST EBCDIC OR ASCII SYSTEMS. C C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZLCUC C C======================== S U B R O U T I N E S ======================== C C INDEX ...GENERIC C ZZLENG ...NON-BLANK LENGTH OF A LINE C C CHAR, ICHAR ...INTRINSIC C C========================= P A R A M E T E R S ========================= * CHARACTER * (*) LCALPH PARAMETER ( LCALPH = 'abcdefghijklmnopqrstuvwxyz' ) * C================= L O C A L D E C L A R A T I O N S ================= * LOGICAL FIRST * CHARACTER CH * INTEGER I, ZZLENG, WLEN, SHIFT * C=============================== S A V E =============================== SAVE FIRST, SHIFT * C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== DATA FIRST/.TRUE./ * C========================== E X E C U T I O N ========================== * WLEN = ZZLENG(LINE) * IF ( FIRST ) THEN SHIFT = ICHAR( 'A' ) - ICHAR( 'a' ) FIRST = .FALSE. ENDIF * DO 100 I = 1, WLEN * CH = LINE( I:I ) * IF ( INDEX( LCALPH, CH ) .NE. 0 ) THEN * LINE( I:I ) = CHAR( ICHAR( CH ) + SHIFT ) * ENDIF * 100 CONTINUE * GO TO 90000 * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END DOUBLE PRECISION FUNCTION ZZMPAR(I) C!!!! REAL FUNCTION ZZMPAR(I) * C============== A R G U M E N T D E C L A R A T I O N S ============== * INTEGER I * C============================= S T A T U S ============================= 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 CONVERSION FOR SINGLE OR DOUBLE PRECISION: REQUIRED (SEE CONVRT) C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZMPAR C C======================== S U B R O U T I N E S ======================== C C NO SUBROUTINES OR FUNCTIONS ARE CALLED C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * 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(4) C!!!! INTEGER MCHEPS(2) * INTEGER MINMAG(4) C!!!! INTEGER MINMAG(2) * INTEGER MAXMAG(4) C!!!! INTEGER MAXMAG(2) * DOUBLE PRECISION DMACH(3) C!!!! REAL RMACH(3) * C=============================== S A V E =============================== * SAVE DMACH C!!!! SAVE RMACH * C======================= E Q U I V A L E N C E S ======================= * EQUIVALENCE (DMACH(1),MCHEPS(1)) C!!!! EQUIVALENCE (RMACH(1),MCHEPS(1)) * EQUIVALENCE (DMACH(2),MINMAG(1)) C!!!! EQUIVALENCE (RMACH(2),MINMAG(1)) * EQUIVALENCE (DMACH(3),MAXMAG(1)) C!!!! EQUIVALENCE (RMACH(3),MAXMAG(1)) * C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C-----MACHINE CONSTANTS FOR THE VAX-11. * DATA MCHEPS(1),MCHEPS(2) / 9472, 0 / C!!!! DATA MCHEPS(1) / 13568 / * DATA MINMAG(1),MINMAG(2) / 128, 0 / C!!!! DATA MINMAG(1) / 128 / * DATA MAXMAG(1),MAXMAG(2) / -32769, -1 / C!!!! DATA MAXMAG(1) / -32769 / * C========================== E X E C U T I O N ========================== * ZZMPAR = DMACH(I) C!!!! ZZMPAR = RMACH(I) * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZSECS(SECS) * C============== A R G U M E N T D E C L A R A T I O N S ============== * DOUBLE PRECISION SECS C!!!! REAL SECS * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR CPU USAGE. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR VAX/BERK4.2(3) C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: REQUIRED (SEE CONVRT) C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C 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 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 C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZSECS C C======================== S U B R O U T I N E S ======================== C C A SYSTEM CLOCK. C 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 A R A T I O N S ================= * 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 ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== * DATA FIRST/.TRUE./ * 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 = DBLE(SEC) C!!!! SECS = SEC * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZTIME ( CHTIME ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER *(*) CHTIME * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR TIME OF DAY. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR VAX/BERK4.2(3) C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZTIME C C======================== S U B R O U T I N E S ======================== C C SYSTEM ROUTINE TO GET TIME OF DAY. C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * CHARACTER * 24 UNXTIM * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA STATEMENTS. C 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZDATE (CHDATE) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER *(*) CHDATE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM ROUTINE FOR DATE. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR CYBER/FTN5 C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 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 C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZDATE C C======================== S U B R O U T I N E S ======================== C C SYSTEM DATE ROUTINE. C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * CHARACTER * 10 DATE * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA VALUES. C 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZLCUC ( LINE ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER * (*) LINE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: THE ACTIONS DEPEND UPON THE UNDERLYING C CHARACTER SET. MOST VERSIONS ASSUME AN ASCII C OR EBCDIC CHARACTER SET WITH EACH CHARACTER C OCCUPYING ONE BYTE. THE CYBER VERSION ASSUMES 6- C 12 BIT CODES FOR UPPER/LOWER CASE. ALL THAT HAP- C PENS IS THAT THE ESCAPE CODES @ AND ^ ARE REMOVED. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR CYBER/FTN5 C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C C LINE CONTAINS THE CHARACTERS TO BE CONVERTED TO UPPER CASE. C NOTE THAT ON SOME SYSTEMS (NOTABLY THE OLD ARCHITECTURE C CDC CYBERS), UPPER AND LOWER CASE CHARACTERS HAVE DIFFERENT C LENGTHS, SO THE LINE LENGTH MAY BE CHANGED BY THIS ROUTINE. C C NOTE THAT IF IT HAPPENS THAT THE CONVERTED PART IS SHORTER AFTER C THE CONVERSION, THEN THE UNCONVERTED PART IS LEFT SHIFTED TO C FILL IN THE SPACE CREATED AS FOLLOWS (HERE WLEN IS THE C LENGTH OF THE WHOLE LINE. C C BEFORE CONVERSION C +----------------------------+-----------------------+ C ! CHARACTERS BEING CONVERTED ! SUBSEQUENT CHARACTERS ! C +----------------------------+-----------------------+ C 1 .. LENGTH LENGTH+1 .. WLEN C C AFTER CONVERSION C +----------------------+ +-----------------------+ C ! CONVERTED CHARACTERS ! <== ! SUBSEQUENT CHARACTERS ! C +----------------------+ +-----------------------+ C 1 .. J J+1 .. N C C WHERE J <= LENGTH AND ( WLEN - LENGTH ) = ( N - J ). C C THE RIGHT HAND SIDE IS BLANK FILLED IF THERE IS A SHIFT. C C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZLCUC C C======================== S U B R O U T I N E S ======================== C C INDEX ...GENERIC C ZZLENG ...NON-BLANK LENGTH OF A LINE C C MIN ...INTRINSIC C ZZSHFT ...TO SHIFT A STRING C C========================= P A R A M E T E R S ========================= * CHARACTER * (*) SPEC, BLANK PARAMETER ( SPEC = '^@', BLANK = ' ' ) * C================= L O C A L D E C L A R A T I O N S ================= * INTEGER I, J, L, ZZLENG, WLEN * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C C THERE ARE NO DATA VALUES. C * IF ( WLEN .NE. 0 ) THEN * I = 0 J = 0 * L = WLEN * 100 I = I + 1 J = J + 1 * IF ( I .LT. L .AND. INDEX( SPEC, LINE(I:I) ) .NE. 0 ) THEN * I = I + 1 * ENDIF * IF ( J .NE. I ) THEN LINE(J:J) = LINE(I:I) ENDIF * IF ( I .LT. L ) THEN GOTO 100 ENDIF C BLANK FILL. IF ( J .LT. L ) THEN LINE(J+1:L) = BLANK ENDIF * ENDIF * GO TO 90000 * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END DOUBLE PRECISION FUNCTION ZZMPAR(I) C!!!! REAL FUNCTION ZZMPAR(I) * C============== A R G U M E N T D E C L A R A T I O N S ============== * INTEGER I * C============================= S T A T U S ============================= 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 CONVERSION FOR SINGLE OR DOUBLE PRECISION: REQUIRED (SEE CONVRT) C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZMPAR C C======================== S U B R O U T I N E S ======================== C C NO SUBROUTINES OR FUNCTIONS ARE CALLED C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * 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(4) C!!!! INTEGER MCHEPS(2) * INTEGER MINMAG(4) C!!!! INTEGER MINMAG(2) * INTEGER MAXMAG(4) C!!!! INTEGER MAXMAG(2) * DOUBLE PRECISION DMACH(3) C!!!! REAL RMACH(3) * C=============================== S A V E =============================== * SAVE DMACH C!!!! SAVE RMACH * C======================= E Q U I V A L E N C E S ======================= * EQUIVALENCE (DMACH(1),MCHEPS(1)) C!!!! EQUIVALENCE (RMACH(1),MCHEPS(1)) * EQUIVALENCE (DMACH(2),MINMAG(1)) C!!!! EQUIVALENCE (RMACH(2),MINMAG(1)) * EQUIVALENCE (DMACH(3),MAXMAG(1)) C!!!! EQUIVALENCE (RMACH(3),MAXMAG(1)) * C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C-----MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES (FTN 5). * DATA MCHEPS(1) / O"15614000000000000000" / C!!!! DATA MCHEPS(2) / O"15010000000000000000" / C!!!! DATA RMACH(1) / O"16414000000000000000" / * DATA MINMAG(1) / O"00604000000000000000" / C!!!! DATA MINMAG(2) / O"00000000000000000000" / C!!!! DATA RMACH(2) / O"00014000000000000000" / * DATA MAXMAG(1) / O"37767777777777777777" / C!!!! DATA MAXMAG(2) / O"37167777777777777777" / C!!!! DATA RMACH(3) / O"37767777777777777777" / * C========================== E X E C U T I O N ========================== * ZZMPAR = DMACH(I) C!!!! ZZMPAR = RMACH(I) * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZSECS(SECS) * C============== A R G U M E N T D E C L A R A T I O N S ============== * DOUBLE PRECISION SECS C!!!! REAL SECS * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR CPU USAGE. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR CYBER/FTN5 C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: REQUIRED (SEE CONVRT) C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C 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 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 C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZSECS C C======================== S U B R O U T I N E S ======================== C C A SYSTEM CLOCK. C 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 A R A T I O N S ================= * 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 ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== * DATA FIRST/.TRUE./ * 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 = DBLE(SEC) C!!!! SECS = SEC * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZTIME ( CHTIME ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER *(*) CHTIME * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR TIME OF DAY. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR CYBER/FTN5 C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZTIME C C======================== S U B R O U T I N E S ======================== C C SYSTEM ROUTINE TO GET TIME OF DAY. C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * CHARACTER * 10 TIME * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA STATEMENTS. C 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZDATE (CHDATE) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER *(*) CHDATE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM ROUTINE FOR DATE. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR HW6 C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 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 C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZDATE C C======================== S U B R O U T I N E S ======================== C C SYSTEM DATE ROUTINE. C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * CHARACTER * 24 HWDATE INTEGER * 8 CLOCK_ * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA VALUES. C 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZLCUC ( LINE ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER * (*) LINE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: THE ACTIONS DEPEND UPON THE UNDERLYING C CHARACTER SET. MOST VERSIONS ASSUME AN ASCII C OR EBCDIC CHARACTER SET WITH EACH CHARACTER C OCCUPYING ONE BYTE. THE CYBER VERSION ASSUMES 6- C 12 BIT CODES FOR UPPER/LOWER CASE. ALL THAT HAP- C PENS IS THAT THE ESCAPE CODES @ AND ^ ARE REMOVED. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR HW6 C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C C LINE CONTAINS THE CHARACTERS TO BE CONVERTED TO UPPER CASE. C NOTE THAT ON SOME SYSTEMS (NOTABLY THE OLD ARCHITECTURE C CDC CYBERS), UPPER AND LOWER CASE CHARACTERS HAVE DIFFERENT C LENGTHS, SO THE LINE LENGTH MAY BE CHANGED BY THIS ROUTINE. C C THE ROUTINE ASSUMES THAT THE VALUE C C ICHAR ( UPPER-CASE OF LETTER ) - ICHAR ( LOWER-CASE LETTER ) C C IS FIXED, I.E. IT IS THE SAME FOR EACH LETTER =A,B,...,Z. C C THIS SHOULD BE TRUE ON MOST EBCDIC OR ASCII SYSTEMS. C C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZLCUC C C======================== S U B R O U T I N E S ======================== C C INDEX ...GENERIC C ZZLENG ...NON-BLANK LENGTH OF A LINE C C CHAR, ICHAR ...INTRINSIC C C========================= P A R A M E T E R S ========================= * CHARACTER * (*) LCALPH PARAMETER ( LCALPH = 'abcdefghijklmnopqrstuvwxyz' ) * C================= L O C A L D E C L A R A T I O N S ================= * LOGICAL FIRST * CHARACTER CH * INTEGER I, ZZLENG, WLEN, SHIFT * C=============================== S A V E =============================== SAVE FIRST, SHIFT * C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== DATA FIRST/.TRUE./ * C========================== E X E C U T I O N ========================== * WLEN = ZZLENG(LINE) * IF ( FIRST ) THEN SHIFT = ICHAR( 'A' ) - ICHAR( 'a' ) FIRST = .FALSE. ENDIF * DO 100 I = 1, WLEN * CH = LINE( I:I ) * IF ( INDEX( LCALPH, CH ) .NE. 0 ) THEN * LINE( I:I ) = CHAR( ICHAR( CH ) + SHIFT ) * ENDIF * 100 CONTINUE * GO TO 90000 * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END DOUBLE PRECISION FUNCTION ZZMPAR(I) C!!!! REAL FUNCTION ZZMPAR(I) * C============== A R G U M E N T D E C L A R A T I O N S ============== * INTEGER I * C============================= S T A T U S ============================= 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 CONVERSION FOR SINGLE OR DOUBLE PRECISION: REQUIRED (SEE CONVRT) C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZMPAR C C======================== S U B R O U T I N E S ======================== C C NO SUBROUTINES OR FUNCTIONS ARE CALLED C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * 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(4) C!!!! INTEGER MCHEPS(2) * INTEGER MINMAG(4) C!!!! INTEGER MINMAG(2) * INTEGER MAXMAG(4) C!!!! INTEGER MAXMAG(2) * DOUBLE PRECISION DMACH(3) C!!!! REAL RMACH(3) * C=============================== S A V E =============================== * SAVE DMACH C!!!! SAVE RMACH * C======================= E Q U I V A L E N C E S ======================= * EQUIVALENCE (DMACH(1),MCHEPS(1)) C!!!! EQUIVALENCE (RMACH(1),MCHEPS(1)) * EQUIVALENCE (DMACH(2),MINMAG(1)) C!!!! EQUIVALENCE (RMACH(2),MINMAG(1)) * EQUIVALENCE (DMACH(3),MAXMAG(1)) C!!!! EQUIVALENCE (RMACH(3),MAXMAG(1)) * C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C-----MACHINE CONSTANTS FOR THE HONEYWELL 60/600/6000 SERIES. * DATA MCHEPS(1),MCHEPS(2) / O606400000000, O000000000000 / C!!!! DATA RMACH(1) / O716400000000 / * DATA MINMAG(1),MINMAG(2) / O402400000000, O000000000000 / C!!!! DATA RMACH(2) / O402400000000 / * DATA MAXMAG(1),MAXMAG(2) / O376777777777, O777777777777 / C!!!! DATA RMACH(3) / O376777777777 / * C========================== E X E C U T I O N ========================== * ZZMPAR = DMACH(I) C!!!! ZZMPAR = RMACH(I) * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZSECS(SECS) * C============== A R G U M E N T D E C L A R A T I O N S ============== * DOUBLE PRECISION SECS C!!!! REAL SECS * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR CPU USAGE. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR HW6 C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: REQUIRED (SEE CONVRT) C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C 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 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 C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZSECS C C======================== S U B R O U T I N E S ======================== C C A SYSTEM CLOCK. C 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 A R A T I O N S ================= * 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 ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== * DATA FIRST/.TRUE./ * 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 = DBLE(SEC) C!!!! SECS = SEC * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZTIME ( CHTIME ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER *(*) CHTIME * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR TIME OF DAY. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR HW6 C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZTIME C C======================== S U B R O U T I N E S ======================== C C SYSTEM ROUTINE TO GET TIME OF DAY. C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * CHARACTER * 24 HWTIME * INTEGER * 8 CLOCK_ INTEGER SECS * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA STATEMENTS. C 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZDATE (CHDATE) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER *(*) CHDATE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM ROUTINE FOR DATE. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR MAC/MS C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 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 C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZDATE C C======================== S U B R O U T I N E S ======================== C C SYSTEM DATE ROUTINE. C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * INTEGER MM, DD, YY * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA VALUES. C 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZLCUC ( LINE ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER * (*) LINE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: THE ACTIONS DEPEND UPON THE UNDERLYING C CHARACTER SET. MOST VERSIONS ASSUME AN ASCII C OR EBCDIC CHARACTER SET WITH EACH CHARACTER C OCCUPYING ONE BYTE. THE CYBER VERSION ASSUMES 6- C 12 BIT CODES FOR UPPER/LOWER CASE. ALL THAT HAP- C PENS IS THAT THE ESCAPE CODES @ AND ^ ARE REMOVED. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR MAC/MS C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C C LINE CONTAINS THE CHARACTERS TO BE CONVERTED TO UPPER CASE. C NOTE THAT ON SOME SYSTEMS (NOTABLY THE OLD ARCHITECTURE C CDC CYBERS), UPPER AND LOWER CASE CHARACTERS HAVE DIFFERENT C LENGTHS, SO THE LINE LENGTH MAY BE CHANGED BY THIS ROUTINE. C C THE ROUTINE ASSUMES THAT THE VALUE C C ICHAR ( UPPER-CASE OF LETTER ) - ICHAR ( LOWER-CASE LETTER ) C C IS FIXED, I.E. IT IS THE SAME FOR EACH LETTER =A,B,...,Z. C C THIS SHOULD BE TRUE ON MOST EBCDIC OR ASCII SYSTEMS. C C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZLCUC C C======================== S U B R O U T I N E S ======================== C C INDEX ...GENERIC C ZZLENG ...NON-BLANK LENGTH OF A LINE C C CHAR, ICHAR ...INTRINSIC C C========================= P A R A M E T E R S ========================= * CHARACTER * (*) LCALPH PARAMETER ( LCALPH = 'abcdefghijklmnopqrstuvwxyz' ) * C================= L O C A L D E C L A R A T I O N S ================= * LOGICAL FIRST * CHARACTER CH * INTEGER I, ZZLENG, WLEN, SHIFT * C=============================== S A V E =============================== SAVE FIRST, SHIFT * C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== DATA FIRST/.TRUE./ * C========================== E X E C U T I O N ========================== * WLEN = ZZLENG(LINE) * IF ( FIRST ) THEN SHIFT = ICHAR( 'A' ) - ICHAR( 'a' ) FIRST = .FALSE. ENDIF * DO 100 I = 1, WLEN * CH = LINE( I:I ) * IF ( INDEX( LCALPH, CH ) .NE. 0 ) THEN * LINE( I:I ) = CHAR( ICHAR( CH ) + SHIFT ) * ENDIF * 100 CONTINUE * GO TO 90000 * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END DOUBLE PRECISION FUNCTION ZZMPAR(I) C!!!! REAL FUNCTION ZZMPAR(I) * C============== A R G U M E N T D E C L A R A T I O N S ============== * INTEGER I * C============================= S T A T U S ============================= 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 CONVERSION FOR SINGLE OR DOUBLE PRECISION: REQUIRED (SEE CONVRT) C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZMPAR C C======================== S U B R O U T I N E S ======================== C C NO SUBROUTINES OR FUNCTIONS ARE CALLED C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * 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(4) C!!!! INTEGER MCHEPS(2) * INTEGER MINMAG(4) C!!!! INTEGER MINMAG(2) * INTEGER MAXMAG(4) C!!!! INTEGER MAXMAG(2) * DOUBLE PRECISION DMACH(3) C!!!! REAL RMACH(3) * C=============================== S A V E =============================== * SAVE DMACH C!!!! SAVE RMACH * C======================= E Q U I V A L E N C E S ======================= * EQUIVALENCE (DMACH(1),MCHEPS(1)) C!!!! EQUIVALENCE (RMACH(1),MCHEPS(1)) * EQUIVALENCE (DMACH(2),MINMAG(1)) C!!!! EQUIVALENCE (RMACH(2),MINMAG(1)) * EQUIVALENCE (DMACH(3),MAXMAG(1)) C!!!! EQUIVALENCE (RMACH(3),MAXMAG(1)) * C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C 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),MCHEPS(2) / O'07454000000', O'00000000000' / C!!!! DATA MCHEPS(1) / O'06400000000' / * DATA MINMAG(1),MINMAG(2) / O'00004000000', O'00000000000' / C!!!! DATA MINMAG(1) / O'00040000000' / * DATA MAXMAG(1),MAXMAG(2) / O'17773777777', O'37777777777' / C!!!! DATA MAXMAG(1) / O'17737777777' / * C========================== E X E C U T I O N ========================== * ZZMPAR = DMACH(I) C!!!! ZZMPAR = RMACH(I) * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZSECS(SECS) * C============== A R G U M E N T D E C L A R A T I O N S ============== * DOUBLE PRECISION SECS C!!!! REAL SECS * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR CPU USAGE. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR MAC/MS C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: REQUIRED (SEE CONVRT) C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C 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 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 C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZSECS C C======================== S U B R O U T I N E S ======================== C C A SYSTEM CLOCK. C 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 A R A T I O N S ================= * 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 ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== * DATA FIRST/.TRUE./ * 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 = DBLE(SEC) C!!!! SECS = SEC * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZTIME ( CHTIME ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER *(*) CHTIME * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR TIME OF DAY. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR MAC/MS C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZTIME C C======================== S U B R O U T I N E S ======================== C C SYSTEM ROUTINE TO GET TIME OF DAY. C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * INTEGER SECNDS, MINUTS, HOURS * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA STATEMENTS. C 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZDATE (CHDATE) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER *(*) CHDATE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM ROUTINE FOR DATE. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR SUN3 C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 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 C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZDATE C C======================== S U B R O U T I N E S ======================== C C SYSTEM DATE ROUTINE. C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * 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 ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C 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---- INITIALIZE CHDATE * CHDATE = '( + + )' * CALL FDATE(UNXDAT) * CHDATE(2:3) = UNXDAT(23:24) * CHDATE(8:9) = UNXDAT(9:10) * TEMP = UNXDAT(5:7) CALL ZZLCUC(TEMP) * 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZLCUC ( LINE ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER * (*) LINE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: THE ACTIONS DEPEND UPON THE UNDERLYING C CHARACTER SET. MOST VERSIONS ASSUME AN ASCII C OR EBCDIC CHARACTER SET WITH EACH CHARACTER C OCCUPYING ONE BYTE. THE CYBER VERSION ASSUMES 6- C 12 BIT CODES FOR UPPER/LOWER CASE. ALL THAT HAP- C PENS IS THAT THE ESCAPE CODES @ AND ^ ARE REMOVED. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR SUN3 C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C C LINE CONTAINS THE CHARACTERS TO BE CONVERTED TO UPPER CASE. C NOTE THAT ON SOME SYSTEMS (NOTABLY THE OLD ARCHITECTURE C CDC CYBERS), UPPER AND LOWER CASE CHARACTERS HAVE DIFFERENT C LENGTHS, SO THE LINE LENGTH MAY BE CHANGED BY THIS ROUTINE. C C THE ROUTINE ASSUMES THAT THE VALUE C C ICHAR ( UPPER-CASE OF LETTER ) - ICHAR ( LOWER-CASE LETTER ) C C IS FIXED, I.E. IT IS THE SAME FOR EACH LETTER =A,B,...,Z. C C THIS SHOULD BE TRUE ON MOST EBCDIC OR ASCII SYSTEMS. C C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZLCUC C C======================== S U B R O U T I N E S ======================== C C INDEX ...GENERIC C ZZLENG ...NON-BLANK LENGTH OF A LINE C C CHAR, ICHAR ...INTRINSIC C C========================= P A R A M E T E R S ========================= * CHARACTER * (*) LCALPH PARAMETER ( LCALPH = 'abcdefghijklmnopqrstuvwxyz' ) * C================= L O C A L D E C L A R A T I O N S ================= * LOGICAL FIRST * CHARACTER CH * INTEGER I, ZZLENG, WLEN, SHIFT * C=============================== S A V E =============================== SAVE FIRST, SHIFT * C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== DATA FIRST/.TRUE./ * C========================== E X E C U T I O N ========================== * WLEN = ZZLENG(LINE) * IF ( FIRST ) THEN SHIFT = ICHAR( 'A' ) - ICHAR( 'a' ) FIRST = .FALSE. ENDIF * DO 100 I = 1, WLEN * CH = LINE( I:I ) * IF ( INDEX( LCALPH, CH ) .NE. 0 ) THEN * LINE( I:I ) = CHAR( ICHAR( CH ) + SHIFT ) * ENDIF * 100 CONTINUE * GO TO 90000 * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END DOUBLE PRECISION FUNCTION ZZMPAR(I) C!!!! REAL FUNCTION ZZMPAR(I) * C============== A R G U M E N T D E C L A R A T I O N S ============== * INTEGER I * C============================= S T A T U S ============================= 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 CONVERSION FOR SINGLE OR DOUBLE PRECISION: REQUIRED (SEE CONVRT) C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZMPAR C C======================== S U B R O U T I N E S ======================== C C NO SUBROUTINES OR FUNCTIONS ARE CALLED C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * 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(4) C!!!! INTEGER MCHEPS(2) * INTEGER MINMAG(4) C!!!! INTEGER MINMAG(2) * INTEGER MAXMAG(4) C!!!! INTEGER MAXMAG(2) * DOUBLE PRECISION DMACH(3) C!!!! REAL RMACH(3) * C=============================== S A V E =============================== * SAVE DMACH C!!!! SAVE RMACH * C======================= E Q U I V A L E N C E S ======================= * EQUIVALENCE (DMACH(1),MCHEPS(1)) C!!!! EQUIVALENCE (RMACH(1),MCHEPS(1)) * EQUIVALENCE (DMACH(2),MINMAG(1)) C!!!! EQUIVALENCE (RMACH(2),MINMAG(1)) * EQUIVALENCE (DMACH(3),MAXMAG(1)) C!!!! EQUIVALENCE (RMACH(3),MAXMAG(1)) * C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C 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),MCHEPS(2) / O'07454000000', O'00000000000' / C!!!! DATA MCHEPS(1) / O'06400000000' / * DATA MINMAG(1),MINMAG(2) / O'00004000000', O'00000000000' / C!!!! DATA MINMAG(1) / O'00040000000' / * DATA MAXMAG(1),MAXMAG(2) / O'17773777777', O'37777777777' / C!!!! DATA MAXMAG(1) / O'17737777777' / * C========================== E X E C U T I O N ========================== * ZZMPAR = DMACH(I) C!!!! ZZMPAR = RMACH(I) * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZSECS(SECS) * C============== A R G U M E N T D E C L A R A T I O N S ============== * DOUBLE PRECISION SECS C!!!! REAL SECS * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR CPU USAGE. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR SUN3 C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: REQUIRED (SEE CONVRT) C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C 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 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 C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZSECS C C======================== S U B R O U T I N E S ======================== C C A SYSTEM CLOCK. C 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 A R A T I O N S ================= * 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 ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== * DATA FIRST/.TRUE./ * 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 = DBLE(SEC) C!!!! SECS = SEC * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZTIME ( CHTIME ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER *(*) CHTIME * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR TIME OF DAY. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR SUN3 C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZTIME C C======================== S U B R O U T I N E S ======================== C C SYSTEM ROUTINE TO GET TIME OF DAY. C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * CHARACTER * 24 UNXTIM * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA STATEMENTS. C 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZDATE (CHDATE) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER *(*) CHDATE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM ROUTINE FOR DATE. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR SUN4 C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 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 C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZDATE C C======================== S U B R O U T I N E S ======================== C C SYSTEM DATE ROUTINE. C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * 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 ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C 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---- INITIALIZE CHDATE * CHDATE = '( + + )' * CALL FDATE(UNXDAT) * CHDATE(2:3) = UNXDAT(23:24) * CHDATE(8:9) = UNXDAT(9:10) * TEMP = UNXDAT(5:7) CALL ZZLCUC(TEMP) * 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZLCUC ( LINE ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER * (*) LINE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: THE ACTIONS DEPEND UPON THE UNDERLYING C CHARACTER SET. MOST VERSIONS ASSUME AN ASCII C OR EBCDIC CHARACTER SET WITH EACH CHARACTER C OCCUPYING ONE BYTE. THE CYBER VERSION ASSUMES 6- C 12 BIT CODES FOR UPPER/LOWER CASE. ALL THAT HAP- C PENS IS THAT THE ESCAPE CODES @ AND ^ ARE REMOVED. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR SUN4 C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C C LINE CONTAINS THE CHARACTERS TO BE CONVERTED TO UPPER CASE. C NOTE THAT ON SOME SYSTEMS (NOTABLY THE OLD ARCHITECTURE C CDC CYBERS), UPPER AND LOWER CASE CHARACTERS HAVE DIFFERENT C LENGTHS, SO THE LINE LENGTH MAY BE CHANGED BY THIS ROUTINE. C C THE ROUTINE ASSUMES THAT THE VALUE C C ICHAR ( UPPER-CASE OF LETTER ) - ICHAR ( LOWER-CASE LETTER ) C C IS FIXED, I.E. IT IS THE SAME FOR EACH LETTER =A,B,...,Z. C C THIS SHOULD BE TRUE ON MOST EBCDIC OR ASCII SYSTEMS. C C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZLCUC C C======================== S U B R O U T I N E S ======================== C C INDEX ...GENERIC C ZZLENG ...NON-BLANK LENGTH OF A LINE C C CHAR, ICHAR ...INTRINSIC C C========================= P A R A M E T E R S ========================= * CHARACTER * (*) LCALPH PARAMETER ( LCALPH = 'abcdefghijklmnopqrstuvwxyz' ) * C================= L O C A L D E C L A R A T I O N S ================= * LOGICAL FIRST * CHARACTER CH * INTEGER I, ZZLENG, WLEN, SHIFT * C=============================== S A V E =============================== SAVE FIRST, SHIFT * C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== DATA FIRST/.TRUE./ * C========================== E X E C U T I O N ========================== * WLEN = ZZLENG(LINE) * IF ( FIRST ) THEN SHIFT = ICHAR( 'A' ) - ICHAR( 'a' ) FIRST = .FALSE. ENDIF * DO 100 I = 1, WLEN * CH = LINE( I:I ) * IF ( INDEX( LCALPH, CH ) .NE. 0 ) THEN * LINE( I:I ) = CHAR( ICHAR( CH ) + SHIFT ) * ENDIF * 100 CONTINUE * GO TO 90000 * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END DOUBLE PRECISION FUNCTION ZZMPAR(I) C!!!! REAL FUNCTION ZZMPAR(I) * C============== A R G U M E N T D E C L A R A T I O N S ============== * INTEGER I * C============================= S T A T U S ============================= 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 CONVERSION FOR SINGLE OR DOUBLE PRECISION: REQUIRED (SEE CONVRT) C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZMPAR C C======================== S U B R O U T I N E S ======================== C C NO SUBROUTINES OR FUNCTIONS ARE CALLED C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * 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(4) C!!!! INTEGER MCHEPS(2) * INTEGER MINMAG(4) C!!!! INTEGER MINMAG(2) * INTEGER MAXMAG(4) C!!!! INTEGER MAXMAG(2) * DOUBLE PRECISION DMACH(3) C!!!! REAL RMACH(3) * C=============================== S A V E =============================== * SAVE DMACH C!!!! SAVE RMACH * C======================= E Q U I V A L E N C E S ======================= * EQUIVALENCE (DMACH(1),MCHEPS(1)) C!!!! EQUIVALENCE (RMACH(1),MCHEPS(1)) * EQUIVALENCE (DMACH(2),MINMAG(1)) C!!!! EQUIVALENCE (RMACH(2),MINMAG(1)) * EQUIVALENCE (DMACH(3),MAXMAG(1)) C!!!! EQUIVALENCE (RMACH(3),MAXMAG(1)) * C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C-----MACHINE CONSTANTS FOR THE SUN-4. * DATA DMACH(1) /1.11022302D-16 / C!!!! DATA MCHEPS(1),MCHEPS(2) / 9472, 0 / C!!!! DATA MCHEPS(1) / 13568 / * DATA DMACH(2) /4.94065646D-324 / C!!!! DATA MINMAG(1),MINMAG(2) / 128, 0 / C!!!! DATA MINMAG(1) / 128 / * DATA DMACH(3) /1.79769313D+308 / C!!!! DATA MAXMAG(1),MAXMAG(2) / -32769, -1 / C!!!! DATA MAXMAG(1) / -32769 / * C========================== E X E C U T I O N ========================== * ZZMPAR = DMACH(I) C!!!! ZZMPAR = RMACH(I) * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZSECS(SECS) * C============== A R G U M E N T D E C L A R A T I O N S ============== * DOUBLE PRECISION SECS C!!!! REAL SECS * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR CPU USAGE. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR SUN4 C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: REQUIRED (SEE CONVRT) C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C 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 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 C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZSECS C C======================== S U B R O U T I N E S ======================== C C A SYSTEM CLOCK. C 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 A R A T I O N S ================= * 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 ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== * DATA FIRST/.TRUE./ * 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 = DBLE(SEC) C!!!! SECS = SEC * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZTIME ( CHTIME ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER *(*) CHTIME * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR TIME OF DAY. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR SUN4 C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZTIME C C======================== S U B R O U T I N E S ======================== C C SYSTEM ROUTINE TO GET TIME OF DAY. C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * CHARACTER * 24 UNXTIM * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA STATEMENTS. C 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZDATE (CHDATE) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER *(*) CHDATE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM ROUTINE FOR DATE. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR VAX/VMS C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 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 C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZDATE C C======================== S U B R O U T I N E S ======================== C C SYSTEM DATE ROUTINE. C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * 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 ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C 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---- 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZLCUC ( LINE ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER * (*) LINE * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: THE ACTIONS DEPEND UPON THE UNDERLYING C CHARACTER SET. MOST VERSIONS ASSUME AN ASCII C OR EBCDIC CHARACTER SET WITH EACH CHARACTER C OCCUPYING ONE BYTE. THE CYBER VERSION ASSUMES 6- C 12 BIT CODES FOR UPPER/LOWER CASE. ALL THAT HAP- C PENS IS THAT THE ESCAPE CODES @ AND ^ ARE REMOVED. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR VAX/VMS C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C C LINE CONTAINS THE CHARACTERS TO BE CONVERTED TO UPPER CASE. C NOTE THAT ON SOME SYSTEMS (NOTABLY THE OLD ARCHITECTURE C CDC CYBERS), UPPER AND LOWER CASE CHARACTERS HAVE DIFFERENT C LENGTHS, SO THE LINE LENGTH MAY BE CHANGED BY THIS ROUTINE. C C THE ROUTINE ASSUMES THAT THE VALUE C C ICHAR ( UPPER-CASE OF LETTER ) - ICHAR ( LOWER-CASE LETTER ) C C IS FIXED, I.E. IT IS THE SAME FOR EACH LETTER =A,B,...,Z. C C THIS SHOULD BE TRUE ON MOST EBCDIC OR ASCII SYSTEMS. C C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZLCUC C C======================== S U B R O U T I N E S ======================== C C INDEX ...GENERIC C ZZLENG ...NON-BLANK LENGTH OF A LINE C C CHAR, ICHAR ...INTRINSIC C C========================= P A R A M E T E R S ========================= * CHARACTER * (*) LCALPH PARAMETER ( LCALPH = 'abcdefghijklmnopqrstuvwxyz' ) * C================= L O C A L D E C L A R A T I O N S ================= * LOGICAL FIRST * CHARACTER CH * INTEGER I, ZZLENG, WLEN, SHIFT * C=============================== S A V E =============================== SAVE FIRST, SHIFT * C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== DATA FIRST/.TRUE./ * C========================== E X E C U T I O N ========================== * WLEN = ZZLENG(LINE) * IF ( FIRST ) THEN SHIFT = ICHAR( 'A' ) - ICHAR( 'a' ) FIRST = .FALSE. ENDIF * DO 100 I = 1, WLEN * CH = LINE( I:I ) * IF ( INDEX( LCALPH, CH ) .NE. 0 ) THEN * LINE( I:I ) = CHAR( ICHAR( CH ) + SHIFT ) * ENDIF * 100 CONTINUE * GO TO 90000 * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END DOUBLE PRECISION FUNCTION ZZMPAR(I) C!!!! REAL FUNCTION ZZMPAR(I) * C============== A R G U M E N T D E C L A R A T I O N S ============== * INTEGER I * C============================= S T A T U S ============================= 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 CONVERSION FOR SINGLE OR DOUBLE PRECISION: REQUIRED (SEE CONVRT) C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZMPAR C C======================== S U B R O U T I N E S ======================== C C NO SUBROUTINES OR FUNCTIONS ARE CALLED C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * 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(4) C!!!! INTEGER MCHEPS(2) * INTEGER MINMAG(4) C!!!! INTEGER MINMAG(2) * INTEGER MAXMAG(4) C!!!! INTEGER MAXMAG(2) * DOUBLE PRECISION DMACH(3) C!!!! REAL RMACH(3) * C=============================== S A V E =============================== * SAVE DMACH C!!!! SAVE RMACH * C======================= E Q U I V A L E N C E S ======================= * EQUIVALENCE (DMACH(1),MCHEPS(1)) C!!!! EQUIVALENCE (RMACH(1),MCHEPS(1)) * EQUIVALENCE (DMACH(2),MINMAG(1)) C!!!! EQUIVALENCE (RMACH(2),MINMAG(1)) * EQUIVALENCE (DMACH(3),MAXMAG(1)) C!!!! EQUIVALENCE (RMACH(3),MAXMAG(1)) * C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C-----MACHINE CONSTANTS FOR THE VAX-11. * DATA MCHEPS(1),MCHEPS(2) / 9472, 0 / C!!!! DATA MCHEPS(1) / 13568 / * DATA MINMAG(1),MINMAG(2) / 128, 0 / C!!!! DATA MINMAG(1) / 128 / * DATA MAXMAG(1),MAXMAG(2) / -32769, -1 / C!!!! DATA MAXMAG(1) / -32769 / * C========================== E X E C U T I O N ========================== * ZZMPAR = DMACH(I) C!!!! ZZMPAR = RMACH(I) * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZSECS(SECS) * C============== A R G U M E N T D E C L A R A T I O N S ============== * DOUBLE PRECISION SECS C!!!! REAL SECS * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR CPU USAGE. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR VAX/VMS C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: REQUIRED (SEE CONVRT) C C IGNORE LINES BEGINNING WITH "C!!!!" . C C THIS VERSION IS IN D O U B L E PRECISION. C!!!! THIS VERSION IS IN S I N G L E PRECISION. C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 C C======================== D E S C R I P T I O N ======================== C 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 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 C======================= E N T R Y P O I N T S ======================= C C ONLY THE NATURAL ENTRY POINT ZZSECS C C======================== S U B R O U T I N E S ======================== C C A SYSTEM CLOCK. C 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 A R A T I O N S ================= * 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 ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== * DATA FIRST/.TRUE./ * 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 = DBLE(SEC) C!!!! SECS = SEC * C=============================== E X I T =============================== * 90000 RETURN * C============================ F O R M A T S ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END SUBROUTINE ZZTIME ( CHTIME ) * C============== A R G U M E N T D E C L A R A T I O N S ============== * CHARACTER *(*) CHTIME * C============================= S T A T U S ============================= C C SYSTEM DEPENDENCE: SYSTEM DEPENDENT ROUTINE FOR TIME OF DAY. C C THE CURRENT VERSION MAY BE PROCESSED TO PRODUCE C CODE FOR ONE OF THE FOLLOWING: C C THIS VERSION IS FOR VAX/VMS C C CONVERSION FOR SINGLE OR DOUBLE PRECISION: NOT REQUIRED C C REVISION STATUS: DATE AUTHOR VERSION C C JUN. 16, 1988 A. BUCKLEY 1.2 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 ======================= C C ONLY THE NATURAL ENTRY POINT ZZTIME C C======================== S U B R O U T I N E S ======================== C C SYSTEM ROUTINE TO GET TIME OF DAY. C C========================= P A R A M E T E R S ========================= C C THERE ARE NO PARAMETERS DEFINED. C C================= L O C A L D E C L A R A T I O N S ================= * CHARACTER * 8 VAXTIM * * C=============================== S A V E =============================== C C THERE ARE NO SAVE VARIABLES. C C======================= E Q U I V A L E N C E S ======================= C C THERE ARE NO EQUIVALENCES. C C============================= C O M M O N ============================= C C THERE ARE NO COMMON BLOCKS. C C=============================== D A T A =============================== C C THERE ARE NO DATA STATEMENTS. C 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 ============================ C C THERE ARE NONE. C C================================ E N D ================================ * END STARTING TEST AT 3:27 P.M. ON WEDNESDAY, NOVEMBER 30, 1988 1 BEGINNING RUN #1: CALL BBVSCG, ANALYTIC MODE, FORWARD CALLS. FUNCTION # 1 ...PT 0; F= 41.68169586167801 (# 1) !!G!!=.85E+02(# 1); ...PT 9; F= 0.9979563513253990E-02(# 10) !!G!!=.46E-02(# 10); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 2 ...PT 0; F= 0.7790700756559702 (# 1) !!G!!=.26E+01(# 1); ...PT 43; F= 0.5655650634086431E-02(# 46) !!G!!=.10E-03(# 46); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 3 ...PT 0; F= 1031.153810609398 (# 1) !!G!!=.15E+03(# 1); ...PT 18; F= 0.1155940389680373E-03(# 23) !!G!!=.46E-03(# 23); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 4 ...PT 0; F= 2.266182511289055 (# 1) !!G!!=.12E+02(# 1); ...PT 37; F= 0.2598111368328460E-06(# 39) !!G!!=.66E-04(# 39); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 5 ...PT 0; F= 629.0000000000000 (# 1) !!G!!=.46E+03(# 1); ...PT 26; F= 0.1268884276519305E-11(# 30) !!G!!=.10E-03(# 30); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 6 ...PT 0; F= 148032.5653500000 (# 1) !!G!!=.30E+05(# 1); ...PT 19; F= 0.7446886540286594E-04(# 20) !!G!!=.29E-04(# 20); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 7 ...PT 0; F= 162.6526819887061 (# 1) !!G!!=.50E+03(# 1); ...PT 18; F= 0.1947559660561768E-03(# 24) !!G!!=.13E-04(# 24); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 8 ...PT 0; F= 2150.000000000000 (# 1) !!G!!=.15E+04(# 1); ...PT 35; F= 0.1830050294747058E-05(# 36) !!G!!=.79E-03(# 36); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 9 ...PT 0; F= 24.20000000000000 (# 1) !!G!!=.23E+03(# 1); ...PT 35; F= 0.3316606905652118E-10(# 43) !!G!!=.26E-03(# 43); ************* RUN COMPLETE, STATUS = 0. FUNCTION #10 ...PT 0; F= -2.860065561048750 (# 1) !!G!!=.84E+00(# 1); ...PT 13; F= -2.999999999962678 (# 17) !!G!!=.35E-04(# 17); ************* RUN COMPLETE, STATUS = 0. 1 BEGINNING RUN #2: CALL BBVSCG, ANALYTIC MODE, REVERSE CALLS. FUNCTION # 1 ...PT 0; F= 41.68169586167801 (# 0) !!G!!=.85E+02(# 0); ...PT 9; F= 0.9979563513253990E-02(# 9) !!G!!=.46E-02(# 9); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 2 ...PT 0; F= 0.7790700756559702 (# 0) !!G!!=.26E+01(# 0); ...PT 43; F= 0.5655650634086431E-02(# 45) !!G!!=.10E-03(# 45); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 3 ...PT 0; F= 1031.153810609398 (# 0) !!G!!=.15E+03(# 0); ...PT 18; F= 0.1155940389680373E-03(# 22) !!G!!=.46E-03(# 22); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 4 ...PT 0; F= 2.266182511289055 (# 0) !!G!!=.12E+02(# 0); ...PT 37; F= 0.2598111368328460E-06(# 38) !!G!!=.66E-04(# 38); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 5 ...PT 0; F= 629.0000000000000 (# 0) !!G!!=.46E+03(# 0); ...PT 26; F= 0.1268884276519305E-11(# 29) !!G!!=.10E-03(# 29); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 6 ...PT 0; F= 148032.5653500000 (# 0) !!G!!=.30E+05(# 0); ...PT 19; F= 0.7446886540286594E-04(# 19) !!G!!=.29E-04(# 19); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 7 ...PT 0; F= 162.6526819887061 (# 0) !!G!!=.50E+03(# 0); ...PT 18; F= 0.1947559660561768E-03(# 23) !!G!!=.13E-04(# 23); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 8 ...PT 0; F= 2150.000000000000 (# 0) !!G!!=.15E+04(# 0); ...PT 35; F= 0.1830050294747058E-05(# 35) !!G!!=.79E-03(# 35); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 9 ...PT 0; F= 24.20000000000000 (# 0) !!G!!=.23E+03(# 0); ...PT 35; F= 0.3316606905652118E-10(# 42) !!G!!=.26E-03(# 42); ************* RUN COMPLETE, STATUS = 0. FUNCTION #10 ...PT 0; F= -2.860065561048750 (# 0) !!G!!=.84E+00(# 0); ...PT 13; F= -2.999999999962678 (# 16) !!G!!=.35E-04(# 16); ************* RUN COMPLETE, STATUS = 0. 1 BEGINNING RUN #3: CALL BBVSCG, DIFFERENCING, FORWARD CALLS. FUNCTION # 1 ...PT 0; F= 41.68169586167801 (# 1) !!G!!=.85E+02(# 1); ...PT 9; F= 0.9979563489328016E-02(# 10) !!G!!=.46E-02(# 10); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 2 ...PT 0; F= 0.7790700756559702 (# 1) !!G!!=.26E+01(# 1); ...PT 43; F= 0.5655650637472540E-02(# 46) !!G!!=.10E-03(# 46); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 3 ...PT 0; F= 1031.153810609398 (# 1) !!G!!=.15E+03(# 1); ...PT 18; F= 0.1155940426600787E-03(# 23) !!G!!=.46E-03(# 23); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 4 ...PT 0; F= 2.266182511289055 (# 1) !!G!!=.12E+02(# 1); ...PT 37; F= 0.2597992704394289E-06(# 39) !!G!!=.66E-04(# 39); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 5 ...PT 0; F= 629.0000000000000 (# 1) !!G!!=.46E+03(# 1); ...PT 26; F= 0.3567925193333121E-10(# 30) !!G!!=.10E-03(# 30); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 6 ...PT 0; F= 148032.5653500000 (# 1) !!G!!=.30E+05(# 1); ...PT 19; F= 0.7446884805919609E-04(# 20) !!G!!=.29E-04(# 20); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 7 ...PT 0; F= 162.6526819887061 (# 1) !!G!!=.50E+03(# 1); ...PT 18; F= 0.1947559660646354E-03(# 24) !!G!!=.13E-04(# 24); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 8 ...PT 0; F= 2150.000000000000 (# 1) !!G!!=.15E+04(# 1); ...PT 35; F= 0.1824286534970351E-05(# 36) !!G!!=.79E-03(# 36); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 9 ...PT 0; F= 24.20000000000000 (# 1) !!G!!=.23E+03(# 1); ...PT 35; F= 0.3955018949608103E-10(# 43) !!G!!=.24E-03(# 43); ************* RUN COMPLETE, STATUS = 0. FUNCTION #10 ...PT 0; F= -2.860065561048750 (# 1) !!G!!=.84E+00(# 1); ...PT 13; F= -2.999999999963172 (# 17) !!G!!=.35E-04(# 17); ************* RUN COMPLETE, STATUS = 0. 1 BEGINNING RUN #4: CALL BBVSCG, TESTING MODE, FORWARD CALLS. FUNCTION # 1 ...PT 0; F= 41.68169586167801 (# 1) !!G!!=.85E+02(# 1); ...PT 9; F= 0.9979563513253990E-02(# 10) !!G!!=.46E-02(# 10); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 2 ...PT 0; F= 0.7790700756559702 (# 1) !!G!!=.26E+01(# 1); ...PT 43; F= 0.5655650634086431E-02(# 46) !!G!!=.10E-03(# 46); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 3 ...PT 0; F= 1031.153810609398 (# 1) !!G!!=.15E+03(# 1); ...PT 18; F= 0.1155940389680373E-03(# 23) !!G!!=.46E-03(# 23); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 4 ...PT 0; F= 2.266182511289055 (# 1) !!G!!=.12E+02(# 1); ...PT 37; F= 0.2598111368328460E-06(# 39) !!G!!=.66E-04(# 39); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 5 ...PT 0; F= 629.0000000000000 (# 1) !!G!!=.46E+03(# 1); ...PT 26; F= 0.1268884276519305E-11(# 30) !!G!!=.10E-03(# 30); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 6 ...PT 0; F= 148032.5653500000 (# 1) !!G!!=.30E+05(# 1); ...PT 19; F= 0.7446886540286594E-04(# 20) !!G!!=.29E-04(# 20); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 7 ...PT 0; F= 162.6526819887061 (# 1) !!G!!=.50E+03(# 1); ...PT 18; F= 0.1947559660561768E-03(# 24) !!G!!=.13E-04(# 24); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 8 ...PT 0; F= 2150.000000000000 (# 1) !!G!!=.15E+04(# 1); ...PT 35; F= 0.1830050294747058E-05(# 36) !!G!!=.79E-03(# 36); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 9 ...PT 0; F= 24.20000000000000 (# 1) !!G!!=.23E+03(# 1); ...PT 35; F= 0.3316606905652118E-10(# 43) !!G!!=.26E-03(# 43); ************* RUN COMPLETE, STATUS = 0. FUNCTION #10 ...PT 0; F= -2.860065561048750 (# 1) !!G!!=.84E+00(# 1); ...PT 13; F= -2.999999999962678 (# 17) !!G!!=.35E-04(# 17); ************* RUN COMPLETE, STATUS = 0. TESTING MODE DERIVATIVE ESTIMATION ERRORS MAX ERROR COMPONENT ITERATE AV. DECIMALS 0.56E-07 1 1 8.23 0.88E-07 2 3 7.98 0.36E-03 2 3 7.65 -0.31E-06 1 2 8.10 0.29E-05 2 24 7.97 0.39E-05 1 2 7.84 0.50E-05 3 23 8.14 0.30E-03 3 2 8.56 0.76E-07 1 2 8.21 0.25E-06 2 2 8.13 1 BEGINNING RUN #5: CALL BBLNIR, ANALYTIC MODE, FORWARD CALLS; METH= 2. FUNCTION # 1 ...PT 0; F= 41.68169586167801 (# 1) !!G!!=.85E+02(# 1); ...PT 13; F= 0.8214877443206120E-02(# 26) !!G!!=.14E-04(# 26); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 2 ...PT 0; F= 0.7790700756559702 (# 1) !!G!!=.26E+01(# 1); ...PT 42; F= 0.5884325825983519E-02(# 80) !!G!!=.14E-02(# 80); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 3 ...PT 0; F= 1031.153810609398 (# 1) !!G!!=.15E+03(# 1); ...PT 14; F= 0.1101807392786634E-03(# 28) !!G!!=.57E-03(# 28); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 4 ...PT 0; F= 2.266182511289055 (# 1) !!G!!=.12E+02(# 1); ...PT 35; F= 0.7136510327781077E-08(# 70) !!G!!=.93E-05(# 70); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 5 ...PT 0; F= 629.0000000000000 (# 1) !!G!!=.46E+03(# 1); ...PT 28; F= 0.1824950364272499E-04(# 59) !!G!!=.17E-01(# 59); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 6 ...PT 0; F= 148032.5653500000 (# 1) !!G!!=.30E+05(# 1); ...PT 8; F= 0.7446455879590995E-04(# 26) !!G!!=.43E-04(# 26); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 7 ...PT 0; F= 162.6526819887061 (# 1) !!G!!=.50E+03(# 1); ...PT 14; F= 0.1947570867047990E-03(# 26) !!G!!=.17E-03(# 26); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 8 ...PT 0; F= 2150.000000000000 (# 1) !!G!!=.15E+04(# 1); ...PT 30; F= 0.1968145211620533E-07(# 58) !!G!!=.94E-04(# 58); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 9 ...PT 0; F= 24.20000000000000 (# 1) !!G!!=.23E+03(# 1); ...PT 27; F= 0.8996421083512084E-08(# 56) !!G!!=.15E-02(# 56); ************* RUN COMPLETE, STATUS = 0. FUNCTION #10 ...PT 0; F= -2.860065561048750 (# 1) !!G!!=.84E+00(# 1); ...PT 9; F= -2.999999999997687 (# 30) !!G!!=.26E-05(# 30); ************* RUN COMPLETE, STATUS = 0. 1 BEGINNING RUN #6: CALL BBLNIR, ANALYTIC MODE, REVERSE CALLS; METH=-2. FUNCTION # 1 ...PT 0; F= 41.68169586167801 (# 1) !!G!!=.85E+02(# 1); ...PT 9; F= 0.9979563513253990E-02(# 10) !!G!!=.46E-02(# 10); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 2 ...PT 0; F= 0.7790700756559702 (# 1) !!G!!=.26E+01(# 1); ...PT 43; F= 0.5655650634086431E-02(# 46) !!G!!=.10E-03(# 46); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 3 ...PT 0; F= 1031.153810609398 (# 1) !!G!!=.15E+03(# 1); ...PT 18; F= 0.1155940389680373E-03(# 23) !!G!!=.46E-03(# 23); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 4 ...PT 0; F= 2.266182511289055 (# 1) !!G!!=.12E+02(# 1); ...PT 37; F= 0.2598111368328460E-06(# 39) !!G!!=.66E-04(# 39); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 5 ...PT 0; F= 629.0000000000000 (# 1) !!G!!=.46E+03(# 1); ...PT 26; F= 0.1268884276519305E-11(# 30) !!G!!=.10E-03(# 30); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 6 ...PT 0; F= 148032.5653500000 (# 1) !!G!!=.30E+05(# 1); ...PT 19; F= 0.7446886540286594E-04(# 20) !!G!!=.29E-04(# 20); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 7 ...PT 0; F= 162.6526819887061 (# 1) !!G!!=.50E+03(# 1); ...PT 18; F= 0.1947559660561768E-03(# 24) !!G!!=.13E-04(# 24); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 8 ...PT 0; F= 2150.000000000000 (# 1) !!G!!=.15E+04(# 1); ...PT 35; F= 0.1830050294747058E-05(# 36) !!G!!=.79E-03(# 36); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 9 ...PT 0; F= 24.20000000000000 (# 1) !!G!!=.23E+03(# 1); ...PT 35; F= 0.3316606905652118E-10(# 43) !!G!!=.26E-03(# 43); ************* RUN COMPLETE, STATUS = 0. FUNCTION #10 ...PT 0; F= -2.860065561048750 (# 1) !!G!!=.84E+00(# 1); ...PT 13; F= -2.999999999962678 (# 17) !!G!!=.35E-04(# 17); ************* RUN COMPLETE, STATUS = 0. 1 BEGINNING RUN #7: CALL BBVSCG, ANALYTIC MODE, NOCEDAL UPDATES. FUNCTION # 1 ...PT 0; F= 41.68169586167801 (# 1) !!G!!=.85E+02(# 1); ...PT 6; F= 0.9977356051037970E-02(# 12) !!G!!=.81E-02(# 12); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 2 ...PT 0; F= 0.7790700756559702 (# 1) !!G!!=.26E+01(# 1); ...PT 42; F= 0.1643609313874590E-01(# 56) !!G!!=.70E-02(# 56); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 3 ...PT 0; F= 1031.153810609398 (# 1) !!G!!=.15E+03(# 1); ...PT 18; F= 0.1037248381501738E-03(# 30) !!G!!=.40E-02(# 30); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 4 ...PT 0; F= 2.266182511289055 (# 1) !!G!!=.12E+02(# 1); ...PT 29; F= 0.5630380788549153E-06(# 45) !!G!!=.91E-04(# 45); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 5 ...PT 0; F= 629.0000000000000 (# 1) !!G!!=.46E+03(# 1); ...PT 46; F= 0.4700351240815482E-04(# 73) !!G!!=.39E-01(# 73); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 6 ...PT 0; F= 148032.5653500000 (# 1) !!G!!=.30E+05(# 1); ...PT 13; F= 0.7359540179902220E-04(# 34) !!G!!=.85E-03(# 34); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 7 ...PT 0; F= 162.6526819887061 (# 1) !!G!!=.50E+03(# 1); ...PT 15; F= 0.1948723108643921E-03(# 25) !!G!!=.44E-03(# 25); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 8 ...PT 0; F= 2150.000000000000 (# 1) !!G!!=.15E+04(# 1); ...PT 34; F= 0.3421333936729964E-06(# 48) !!G!!=.13E-02(# 48); ************* RUN COMPLETE, STATUS = 0. FUNCTION # 9 ...PT 0; F= 24.20000000000000 (# 1) !!G!!=.23E+03(# 1); ...PT 32; F= 0.1317659873264308E-07(# 47) !!G!!=.37E-02(# 47); ************* RUN COMPLETE, STATUS = 0. FUNCTION #10 ...PT 0; F= -2.860065561048750 (# 1) !!G!!=.84E+00(# 1); ...PT 11; F= -2.999999999959682 (# 20) !!G!!=.33E-04(# 20); ************* RUN COMPLETE, STATUS = 0. RN ITS FUNCT. VALUE FNS | RN ITS FUNCT. VALUE FNS | RN ITS FUNCT. VALUE FNS ------------------------|-------------------------|------------------------ 1 9 0.997956E-02 10 | 2 43 0.565565E-02 46 | 3 18 0.115594E-03 23 4 37 0.259811E-06 39 | 5 26 0.126888E-11 30 | 6 19 0.744689E-04 20 7 18 0.194756E-03 24 | 8 35 0.183005E-05 36 | 9 35 0.331661E-10 43 10 13 -.300000E+01 17 | 11 9 0.997956E-02 9 | 12 43 0.565565E-02 45 13 18 0.115594E-03 22 | 14 37 0.259811E-06 38 | 15 26 0.126888E-11 29 16 19 0.744689E-04 19 | 17 18 0.194756E-03 23 | 18 35 0.183005E-05 35 19 35 0.331661E-10 42 | 20 13 -.300000E+01 16 | 21 9 0.997956E-02 10 22 43 0.565565E-02 46 | 23 18 0.115594E-03 23 | 24 37 0.259799E-06 39 25 26 0.356793E-10 30 | 26 19 0.744688E-04 20 | 27 18 0.194756E-03 24 28 35 0.182429E-05 36 | 29 35 0.395502E-10 43 | 30 13 -.300000E+01 17 31 9 0.997956E-02 10 | 32 43 0.565565E-02 46 | 33 18 0.115594E-03 23 34 37 0.259811E-06 39 | 35 26 0.126888E-11 30 | 36 19 0.744689E-04 20 37 18 0.194756E-03 24 | 38 35 0.183005E-05 36 | 39 35 0.331661E-10 43 40 13 -.300000E+01 17 | 41 13 0.821488E-02 26 | 42 42 0.588433E-02 80 43 14 0.110181E-03 28 | 44 35 0.713651E-08 70 | 45 28 0.182495E-04 59 46 8 0.744646E-04 26 | 47 14 0.194757E-03 26 | 48 30 0.196815E-07 58 49 27 0.899642E-08 56 | 50 9 -.300000E+01 30 | 51 9 0.997956E-02 10 52 43 0.565565E-02 46 | 53 18 0.115594E-03 23 | 54 37 0.259811E-06 39 55 26 0.126888E-11 30 | 56 19 0.744689E-04 20 | 57 18 0.194756E-03 24 58 35 0.183005E-05 36 | 59 35 0.331661E-10 43 | 60 13 -.300000E+01 17 61 6 0.997736E-02 12 | 62 42 0.164361E-01 56 | 63 18 0.103725E-03 30 64 29 0.563038E-06 45 | 65 46 0.470035E-04 73 | 66 13 0.735954E-04 34 67 15 0.194872E-03 25 | 68 34 0.342133E-06 48 | 69 32 0.131766E-07 47 70 11 -.300000E+01 20 | TIME USED WAS 15.100 SECONDS WITHOUT PROMPTS; 15.130 TOTAL. *****TEST FINISHED**** PROBLEMS DONE 70; NUMBER OF ERRORS IS 0. TOTAL FUNCTION CALLS = 2279 TOTAL ITERATIONS = 1731 * * TEST ENDED AT 3:27 P.M. ON WEDNESDAY, NOVEMBER 30, 1988 * *