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<F0-ABIT, SLOPE TEST,'
     -                         //' UDATA-> ', 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<F0-ABIT, SLOPE TEST,'
     -                         //' UDATA-> ', 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
*
*
