OpenLibm/slatec/dpopt.f

*DECK DPOPT
      SUBROUTINE DPOPT (PRGOPT, MRELAS, NVARS, INFO, CSC, IBASIS, ROPT,
     +   INTOPT, LOPT)
C***BEGIN PROLOGUE  DPOPT
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DSPLP
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (SPOPT-S, DPOPT-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO
C     DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES.
C
C     USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/.
C     /REAL (12 BLANKS)/DOUBLE PRECISION/,/R1MACH/D1MACH/,/E0/D0/
C
C     REVISED 821122-1045
C     REVISED YYMMDD-HHMM
C
C     THIS SUBROUTINE PROCESSES THE OPTION VECTOR, PRGOPT(*),
C     AND VALIDATES ANY MODIFIED DATA.
C
C***SEE ALSO  DSPLP
C***ROUTINES CALLED  D1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   811215  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890605  Removed unreferenced labels.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900328  Added TYPE section.  (WRB)
C   900510  Fixed an error message.  (RWC)
C***END PROLOGUE  DPOPT
      DOUBLE PRECISION ABIG,ASMALL,COSTSC,CSC(*),EPS,ONE,PRGOPT(*),
     * ROPT(07),TOLLS,TUNE,ZERO,D1MACH,TOLABS
      INTEGER IBASIS(*),INTOPT(08)
      LOGICAL CONTIN,USRBAS,SIZEUP,SAVEDT,COLSCP,CSTSCP,MINPRB,
     * STPEDG,LOPT(8)
C
C***FIRST EXECUTABLE STATEMENT  DPOPT
      IOPT=1
      ZERO=0.D0
      ONE=1.D0
      GO TO 30001
20002 CONTINUE
      GO TO 30002
C
20003 LOPT(1)=CONTIN
      LOPT(2)=USRBAS
      LOPT(3)=SIZEUP
      LOPT(4)=SAVEDT
      LOPT(5)=COLSCP
      LOPT(6)=CSTSCP
      LOPT(7)=MINPRB
      LOPT(8)=STPEDG
C
      INTOPT(1)=IDG
      INTOPT(2)=IPAGEF
      INTOPT(3)=ISAVE
      INTOPT(4)=MXITLP
      INTOPT(5)=KPRINT
      INTOPT(6)=ITBRC
      INTOPT(7)=NPP
      INTOPT(8)=LPRG
C
      ROPT(1)=EPS
      ROPT(2)=ASMALL
      ROPT(3)=ABIG
      ROPT(4)=COSTSC
      ROPT(5)=TOLLS
      ROPT(6)=TUNE
      ROPT(7)=TOLABS
      RETURN
C
C
C     PROCEDURE (INITIALIZE PARAMETERS AND PROCESS USER OPTIONS)
30001 CONTIN = .FALSE.
      USRBAS = .FALSE.
      SIZEUP = .FALSE.
      SAVEDT = .FALSE.
      COLSCP = .FALSE.
      CSTSCP = .FALSE.
      MINPRB = .TRUE.
      STPEDG = .TRUE.
C
C     GET THE MACHINE REL. FLOATING POINT ACCURACY VALUE FROM THE
C     LIBRARY SUBPROGRAM, D1MACH( ).
      EPS=D1MACH(4)
      TOLLS=D1MACH(4)
      TUNE=ONE
      TOLABS=ZERO
C
C     DEFINE NOMINAL FILE NUMBERS FOR MATRIX PAGES AND DATA SAVING.
      IPAGEF=1
      ISAVE=2
      ITBRC=10
      MXITLP=3*(NVARS+MRELAS)
      KPRINT=0
      IDG=-4
      NPP=NVARS
      LPRG=0
C
      LAST = 1
      IADBIG=10000
      ICTMAX=1000
      ICTOPT= 0
20004 NEXT=PRGOPT(LAST)
      IF (.NOT.(NEXT.LE.0 .OR. NEXT.GT.IADBIG)) GO TO 20006
C
C     THE CHECKS FOR SMALL OR LARGE VALUES OF NEXT ARE TO PREVENT
C     WORKING WITH UNDEFINED DATA.
      NERR=14
      CALL XERMSG ('SLATEC', 'DPOPT',
     +   'IN DSPLP, THE USER OPTION ARRAY HAS UNDEFINED DATA.', NERR,
     +   IOPT)
      INFO=-NERR
      RETURN
20006 IF (.NOT.(NEXT.EQ.1)) GO TO 10001
      GO TO 20005
10001 IF (.NOT.(ICTOPT.GT.ICTMAX)) GO TO 10002
      NERR=15
      CALL XERMSG ('SLATEC', 'DPOPT',
     +   'IN DSPLP, OPTION ARRAY PROCESSING IS CYCLING.', NERR, IOPT)
      INFO=-NERR
      RETURN
10002 CONTINUE
      KEY = PRGOPT(LAST+1)
C
C     IF KEY = 50, THIS IS TO BE A MAXIMIZATION PROBLEM
C     INSTEAD OF A MINIMIZATION PROBLEM.
      IF (.NOT.(KEY.EQ.50)) GO TO 20010
      MINPRB = PRGOPT(LAST+2).EQ.ZERO
      LDS=3
      GO TO 20009
20010 CONTINUE
C
C     IF KEY = 51, THE LEVEL OF OUTPUT IS BEING MODIFIED.
C     KPRINT = 0, NO OUTPUT
C            = 1, SUMMARY OUTPUT
C            = 2, LOTS OF OUTPUT
C            = 3, EVEN MORE OUTPUT
      IF (.NOT.(KEY.EQ.51)) GO TO 20013
      KPRINT=PRGOPT(LAST+2)
      LDS=3
      GO TO 20009
20013 CONTINUE
C
C     IF KEY = 52, REDEFINE THE FORMAT AND PRECISION USED
C     IN THE OUTPUT.
      IF (.NOT.(KEY.EQ.52)) GO TO 20016
      IF (PRGOPT(LAST+2).NE.ZERO) IDG=PRGOPT(LAST+3)
      LDS=4
      GO TO 20009
20016 CONTINUE
C
C     IF KEY = 53, THE ALLOTTED SPACE FOR THE SPARSE MATRIX
C     STORAGE AND/OR SPARSE EQUATION SOLVING HAS BEEN CHANGED.
C    (PROCESSED IN DSPLP(). THIS IS TO COMPUTE THE LENGTH OF PRGOPT(*).)
      IF (.NOT.(KEY.EQ.53)) GO TO 20019
      LDS=5
      GO TO 20009
20019 CONTINUE
C
C     IF KEY = 54, REDEFINE THE FILE NUMBER WHERE THE PAGES
C     FOR THE SPARSE MATRIX ARE STORED.
      IF (.NOT.(KEY.EQ.54)) GO TO 20022
      IF(PRGOPT(LAST+2).NE.ZERO) IPAGEF = PRGOPT(LAST+3)
      LDS=4
      GO TO 20009
20022 CONTINUE
C
C     IF KEY = 55,  A CONTINUATION FOR A PROBLEM MAY BE REQUESTED.
      IF (.NOT.(KEY .EQ. 55)) GO TO 20025
      CONTIN = PRGOPT(LAST+2).NE.ZERO
      LDS=3
      GO TO 20009
20025 CONTINUE
C
C     IF KEY = 56, REDEFINE THE FILE NUMBER WHERE THE SAVED DATA
C     WILL BE STORED.
      IF (.NOT.(KEY.EQ.56)) GO TO 20028
      IF(PRGOPT(LAST+2).NE.ZERO) ISAVE = PRGOPT(LAST+3)
      LDS=4
      GO TO 20009
20028 CONTINUE
C
C     IF KEY = 57, SAVE DATA (ON EXTERNAL FILE)  AT MXITLP ITERATIONS OR
C     THE OPTIMUM, WHICHEVER COMES FIRST.
      IF (.NOT.(KEY.EQ.57)) GO TO 20031
      SAVEDT=PRGOPT(LAST+2).NE.ZERO
      LDS=3
      GO TO 20009
20031 CONTINUE
C
C     IF KEY = 58,  SEE IF PROBLEM IS TO RUN ONLY A GIVEN
C     NUMBER OF ITERATIONS.
      IF (.NOT.(KEY.EQ.58)) GO TO 20034
      IF (PRGOPT(LAST+2).NE.ZERO) MXITLP = PRGOPT(LAST+3)
      LDS=4
      GO TO 20009
20034 CONTINUE
C
C     IF KEY = 59,  SEE IF USER PROVIDES THE BASIS INDICES.
      IF (.NOT.(KEY .EQ. 59)) GO TO 20037
      USRBAS = PRGOPT(LAST+2) .NE. ZERO
      IF (.NOT.(USRBAS)) GO TO 20040
      I=1
      N20043=MRELAS
      GO TO 20044
20043 I=I+1
20044 IF ((N20043-I).LT.0) GO TO 20045
      IBASIS(I) = PRGOPT(LAST+2+I)
      GO TO 20043
20045 CONTINUE
20040 CONTINUE
      LDS=MRELAS+3
      GO TO 20009
20037 CONTINUE
C
C     IF KEY = 60,  SEE IF USER HAS PROVIDED SCALING OF COLUMNS.
      IF (.NOT.(KEY .EQ. 60)) GO TO 20047
      COLSCP = PRGOPT(LAST+2).NE.ZERO
      IF (.NOT.(COLSCP)) GO TO 20050
      J=1
      N20053=NVARS
      GO TO 20054
20053 J=J+1
20054 IF ((N20053-J).LT.0) GO TO 20055
      CSC(J)=ABS(PRGOPT(LAST+2+J))
      GO TO 20053
20055 CONTINUE
20050 CONTINUE
      LDS=NVARS+3
      GO TO 20009
20047 CONTINUE
C
C     IF KEY = 61,  SEE IF USER HAS PROVIDED SCALING OF COSTS.
      IF (.NOT.(KEY .EQ. 61)) GO TO 20057
      CSTSCP = PRGOPT(LAST+2).NE.ZERO
      IF (CSTSCP) COSTSC = PRGOPT(LAST+3)
      LDS=4
      GO TO 20009
20057 CONTINUE
C
C     IF KEY = 62,  SEE IF SIZE PARAMETERS ARE PROVIDED WITH THE DATA.
C     THESE WILL BE CHECKED AGAINST THE MATRIX ELEMENT SIZES LATER.
      IF (.NOT.(KEY .EQ. 62)) GO TO 20060
      SIZEUP = PRGOPT(LAST+2).NE.ZERO
      IF (.NOT.(SIZEUP)) GO TO 20063
      ASMALL = PRGOPT(LAST+3)
      ABIG = PRGOPT(LAST+4)
20063 CONTINUE
      LDS=5
      GO TO 20009
20060 CONTINUE
C
C     IF KEY = 63, SEE IF TOLERANCE FOR LINEAR SYSTEM RESIDUAL ERROR IS
C     PROVIDED.
      IF (.NOT.(KEY .EQ. 63)) GO TO 20066
      IF (PRGOPT(LAST+2).NE.ZERO) TOLLS = MAX(EPS,PRGOPT(LAST+3))
      LDS=4
      GO TO 20009
20066 CONTINUE
C
C     IF KEY = 64,  SEE IF MINIMUM REDUCED COST OR STEEPEST EDGE
C     DESCENT IS TO BE USED FOR SELECTING VARIABLES TO ENTER BASIS.
      IF (.NOT.(KEY.EQ.64)) GO TO 20069
      STPEDG = PRGOPT(LAST+2).EQ.ZERO
      LDS=3
      GO TO 20009
20069 CONTINUE
C
C     IF KEY = 65, SET THE NUMBER OF ITERATIONS BETWEEN RECALCULATING
C     THE ERROR IN THE PRIMAL SOLUTION.
      IF (.NOT.(KEY.EQ.65)) GO TO 20072
      IF (PRGOPT(LAST+2).NE.ZERO) ITBRC=MAX(ONE,PRGOPT(LAST+3))
      LDS=4
      GO TO 20009
20072 CONTINUE
C
C     IF KEY = 66, SET THE NUMBER OF NEGATIVE REDUCED COSTS TO BE FOUND
C     IN THE PARTIAL PRICING STRATEGY.
      IF (.NOT.(KEY.EQ.66)) GO TO 20075
      IF (.NOT.(PRGOPT(LAST+2).NE.ZERO)) GO TO 20078
      NPP=MAX(PRGOPT(LAST+3),ONE)
      NPP=MIN(NPP,NVARS)
20078 CONTINUE
      LDS=4
      GO TO 20009
20075 CONTINUE
C     IF KEY = 67, CHANGE THE TUNING PARAMETER TO APPLY TO THE ERROR
C     ESTIMATES FOR THE PRIMAL AND DUAL SYSTEMS.
      IF (.NOT.(KEY.EQ.67)) GO TO 20081
      IF (.NOT.(PRGOPT(LAST+2).NE.ZERO)) GO TO 20084
      TUNE=ABS(PRGOPT(LAST+3))
20084 CONTINUE
      LDS=4
      GO TO 20009
20081 CONTINUE
      IF (.NOT.(KEY.EQ.68)) GO TO 20087
      LDS=6
      GO TO 20009
20087 CONTINUE
C
C     RESET THE ABSOLUTE TOLERANCE TO BE USED ON THE FEASIBILITY
C     DECISION PROVIDED THE RELATIVE ERROR TEST FAILED.
      IF (.NOT.(KEY.EQ.69)) GO TO 20090
      IF(PRGOPT(LAST+2).NE.ZERO)TOLABS=PRGOPT(LAST+3)
      LDS=4
      GO TO 20009
20090 CONTINUE
      CONTINUE
C
20009 ICTOPT = ICTOPT+1
      LAST = NEXT
      LPRG=LPRG+LDS
      GO TO 20004
20005 CONTINUE
      GO TO 20002
C
C     PROCEDURE (VALIDATE OPTIONALLY MODIFIED DATA)
C
C     IF USER HAS DEFINED THE BASIS, CHECK FOR VALIDITY OF INDICES.
30002 IF (.NOT.(USRBAS)) GO TO 20093
      I=1
      N20096=MRELAS
      GO TO 20097
20096 I=I+1
20097 IF ((N20096-I).LT.0) GO TO 20098
      ITEST=IBASIS(I)
      IF (.NOT.(ITEST.LE.0 .OR.ITEST.GT.(NVARS+MRELAS))) GO TO 20100
      NERR=16
      CALL XERMSG ('SLATEC', 'DPOPT',
     +   'IN DSPLP, AN INDEX OF USER-SUPPLIED BASIS IS OUT OF RANGE.',
     +   NERR, IOPT)
      INFO=-NERR
      RETURN
20100 CONTINUE
      GO TO 20096
20098 CONTINUE
20093 CONTINUE
C
C     IF USER HAS PROVIDED SIZE PARAMETERS, MAKE SURE THEY ARE ORDERED
C     AND POSITIVE.
      IF (.NOT.(SIZEUP)) GO TO 20103
      IF (.NOT.(ASMALL.LE.ZERO .OR. ABIG.LT.ASMALL)) GO TO 20106
      NERR=17
      CALL XERMSG ('SLATEC', 'DPOPT',
     +   'IN DSPLP, SIZE PARAMETERS FOR MATRIX MUST BE SMALLEST AND ' //
     +   'LARGEST MAGNITUDES OF NONZERO ENTRIES.', NERR, IOPT)
      INFO=-NERR
      RETURN
20106 CONTINUE
20103 CONTINUE
C
C     THE NUMBER OF ITERATIONS OF REV. SIMPLEX STEPS MUST BE POSITIVE.
      IF (.NOT.(MXITLP.LE.0)) GO TO 20109
      NERR=18
      CALL XERMSG ('SLATEC', 'DPOPT',
     +   'IN DSPLP, THE NUMBER OF REVISED SIMPLEX STEPS BETWEEN ' //
     +   'CHECK-POINTS MUST BE POSITIVE.', NERR, IOPT)
      INFO=-NERR
      RETURN
20109 CONTINUE
C
C     CHECK THAT SAVE AND PAGE FILE NUMBERS ARE DEFINED AND NOT EQUAL.
      IF (.NOT.(ISAVE.LE.0.OR.IPAGEF.LE.0.OR.(ISAVE.EQ.IPAGEF))) GO TO 2
     *0112
      NERR=19
      CALL XERMSG ('SLATEC', 'DPOPT',
     +   'IN DSPLP, FILE NUMBERS FOR SAVED DATA AND MATRIX PAGES ' //
     +   'MUST BE POSITIVE AND NOT EQUAL.', NERR, IOPT)
      INFO=-NERR
      RETURN
20112 CONTINUE
      CONTINUE
      GO TO 20003
      END