relibc_openlibm/slatec/dplpmn.f

*DECK DPLPMN
      SUBROUTINE DPLPMN (DUSRMT, MRELAS, NVARS, COSTS, PRGOPT, DATTRV,
     +   BL, BU, IND, INFO, PRIMAL, DUALS, AMAT, CSC, COLNRM, ERD, ERP,
     +   BASMAT, WR, RZ, RG, RPRIM, RHS, WW, LMX, LBM, IBASIS, IBB,
     +   IMAT, IBRC, IPR, IWR)
C***BEGIN PROLOGUE  DPLPMN
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DSPLP
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (SPLPMN-S, DPLPMN-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     MARVEL OPTION(S).. OUTPUT=YES/NO TO ELIMINATE PRINTED OUTPUT.
C     THIS DOES NOT APPLY TO THE CALLS TO THE ERROR PROCESSOR.
C
C     MAIN SUBROUTINE FOR DSPLP PACKAGE.
C
C***SEE ALSO  DSPLP
C***ROUTINES CALLED  DASUM, DCOPY, DDOT, DPINCW, DPINIT, DPINTM, DPLPCE,
C                    DPLPDM, DPLPFE, DPLPFL, DPLPMU, DPLPUP, DPNNZR,
C                    DPOPT, DPRWPG, DVOUT, IVOUT, LA05BD, SCLOSM, XERMSG
C***COMMON BLOCKS    LA05DD
C***REVISION HISTORY  (YYMMDD)
C   811215  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890605  Removed unreferenced labels.  (WRB)
C   891009  Removed unreferenced variable.  (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  Convert XERRWV calls to XERMSG calls.  (RWC)
C***END PROLOGUE  DPLPMN
      DOUBLE PRECISION ABIG,AIJ,AMAT(*),ANORM,ASMALL,BASMAT(*),
     * BL(*),BU(*),COLNRM(*),COSTS(*),COSTSC,CSC(*),DATTRV(*),
     * DIRNRM,DUALS(*),DULNRM,EPS,TUNE,ERD(*),ERDNRM,ERP(*),FACTOR,GG,
     * ONE,PRGOPT(*),PRIMAL(*),RESNRM,RG(*),RHS(*),RHSNRM,ROPT(07),
     * RPRIM(*),RPRNRM,RZ(*),RZJ,SCALR,SCOSTS,SIZE,SMALL,THETA,
     * TOLLS,UPBND,UU,WR(*),WW(*),XLAMDA,XVAL,ZERO,RDUM(01),TOLABS
      DOUBLE PRECISION DDOT,DASUM
C
      INTEGER IBASIS(*),IBB(*),IBRC(LBM,2),IMAT(*),IND(*),
     * IPR(*),IWR(*),INTOPT(08),IDUM(01)
C
C     ARRAY LOCAL VARIABLES
C     NAME(LENGTH)          DESCRIPTION
C
C     COSTS(NVARS)          COST COEFFICIENTS
C     PRGOPT( )             OPTION VECTOR
C     DATTRV( )             DATA TRANSFER VECTOR
C     PRIMAL(NVARS+MRELAS)  AS OUTPUT IT IS PRIMAL SOLUTION OF LP.
C                           INTERNALLY, THE FIRST NVARS POSITIONS HOLD
C                           THE COLUMN CHECK SUMS.  THE NEXT MRELAS
C                           POSITIONS HOLD THE CLASSIFICATION FOR THE
C                           BASIC VARIABLES  -1 VIOLATES LOWER
C                           BOUND, 0 FEASIBLE, +1 VIOLATES UPPER BOUND
C     DUALS(MRELAS+NVARS)   DUAL SOLUTION. INTERNALLY HOLDS R.H. SIDE
C                           AS FIRST MRELAS ENTRIES.
C     AMAT(LMX)             SPARSE FORM OF DATA MATRIX
C     IMAT(LMX)             SPARSE FORM OF DATA MATRIX
C     BL(NVARS+MRELAS)      LOWER BOUNDS FOR VARIABLES
C     BU(NVARS+MRELAS)      UPPER BOUNDS FOR VARIABLES
C     IND(NVARS+MRELAS)     INDICATOR FOR VARIABLES
C     CSC(NVARS)            COLUMN SCALING
C     IBASIS(NVARS+MRELAS)  COLS. 1-MRELAS ARE BASIC, REST ARE NON-BASIC
C     IBB(NVARS+MRELAS)     INDICATOR FOR NON-BASIC VARS., POLARITY OF
C                           VARS., AND POTENTIALLY INFINITE VARS.
C                           IF IBB(J).LT.0, VARIABLE J IS BASIC
C                           IF IBB(J).GT.0, VARIABLE J IS NON-BASIC
C                           IF IBB(J).EQ.0, VARIABLE J HAS TO BE IGNORED
C                           BECAUSE IT WOULD CAUSE UNBOUNDED SOLN.
C                           WHEN MOD(IBB(J),2).EQ.0, VARIABLE IS AT ITS
C                           UPPER BOUND, OTHERWISE IT IS AT ITS LOWER
C                           BOUND
C     COLNRM(NVARS)         NORM OF COLUMNS
C     ERD(MRELAS)           ERRORS IN DUAL VARIABLES
C     ERP(MRELAS)           ERRORS IN PRIMAL VARIABLES
C     BASMAT(LBM)           BASIS MATRIX FOR HARWELL SPARSE CODE
C     IBRC(LBM,2)           ROW AND COLUMN POINTERS FOR BASMAT(*)
C     IPR(2*MRELAS)         WORK ARRAY FOR HARWELL SPARSE CODE
C     IWR(8*MRELAS)         WORK ARRAY FOR HARWELL SPARSE CODE
C     WR(MRELAS)            WORK ARRAY FOR HARWELL SPARSE CODE
C     RZ(NVARS+MRELAS)      REDUCED COSTS
C     RPRIM(MRELAS)         INTERNAL PRIMAL SOLUTION
C     RG(NVARS+MRELAS)      COLUMN WEIGHTS
C     WW(MRELAS)            WORK ARRAY
C     RHS(MRELAS)           HOLDS TRANSLATED RIGHT HAND SIDE
C
C     SCALAR LOCAL VARIABLES
C     NAME       TYPE         DESCRIPTION
C
C     LMX        INTEGER      LENGTH OF AMAT(*)
C     LPG        INTEGER      LENGTH OF PAGE FOR AMAT(*)
C     EPS        DOUBLE       MACHINE PRECISION
C     TUNE       DOUBLE       PARAMETER TO SCALE ERROR ESTIMATES
C     TOLLS      DOUBLE       RELATIVE TOLERANCE FOR SMALL RESIDUALS
C     TOLABS     DOUBLE       ABSOLUTE TOLERANCE FOR SMALL RESIDUALS.
C                             USED IF RELATIVE ERROR TEST FAILS.
C                             IN CONSTRAINT EQUATIONS
C     FACTOR     DOUBLE      .01--DETERMINES IF BASIS IS SINGULAR
C                             OR COMPONENT IS FEASIBLE.  MAY NEED TO
C                             BE INCREASED TO 1.D0 ON SHORT WORD
C                             LENGTH MACHINES.
C     ASMALL     DOUBLE       LOWER BOUND FOR NON-ZERO MAGN. IN AMAT(*)
C     ABIG       DOUBLE       UPPER BOUND FOR NON-ZERO MAGN. IN AMAT(*)
C     MXITLP     INTEGER      MAXIMUM NUMBER OF ITERATIONS FOR LP
C     ITLP       INTEGER      ITERATION COUNTER FOR TOTAL LP ITERS
C     COSTSC     DOUBLE       COSTS(*) SCALING
C     SCOSTS     DOUBLE       TEMP LOC. FOR COSTSC.
C     XLAMDA     DOUBLE       WEIGHT PARAMETER FOR PEN. METHOD.
C     ANORM      DOUBLE       NORM OF DATA MATRIX AMAT(*)
C     RPRNRM     DOUBLE       NORM OF THE SOLUTION
C     DULNRM     DOUBLE       NORM OF THE DUALS
C     ERDNRM     DOUBLE       NORM OF ERROR IN DUAL VARIABLES
C     DIRNRM     DOUBLE       NORM OF THE DIRECTION VECTOR
C     RHSNRM     DOUBLE       NORM OF TRANSLATED RIGHT HAND SIDE VECTOR
C     RESNRM     DOUBLE       NORM OF RESIDUAL VECTOR FOR CHECKING
C                             FEASIBILITY
C     NZBM       INTEGER      NUMBER OF NON-ZEROS IN BASMAT(*)
C     LBM        INTEGER      LENGTH OF BASMAT(*)
C     SMALL      DOUBLE       EPS*ANORM  USED IN HARWELL SPARSE CODE
C     LP         INTEGER      USED IN HARWELL LA05*() PACK AS OUTPUT
C                             FILE NUMBER. SET=I1MACH(4) NOW.
C     UU         DOUBLE       0.1--USED IN HARWELL SPARSE CODE
C                             FOR RELATIVE PIVOTING TOLERANCE.
C     GG         DOUBLE       OUTPUT INFO FLAG IN HARWELL SPARSE CODE
C     IPLACE     INTEGER      INTEGER USED BY SPARSE MATRIX CODES
C     IENTER     INTEGER      NEXT COLUMN TO ENTER BASIS
C     NREDC      INTEGER      NO. OF FULL REDECOMPOSITIONS
C     KPRINT     INTEGER      LEVEL OF OUTPUT, =0-3
C     IDG        INTEGER      FORMAT AND PRECISION OF OUTPUT
C     ITBRC      INTEGER      NO. OF ITERS. BETWEEN RECALCULATING
C                             THE ERROR IN THE PRIMAL SOLUTION.
C     NPP        INTEGER      NO. OF NEGATIVE REDUCED COSTS REQUIRED
C                             IN PARTIAL PRICING
C     JSTRT      INTEGER      STARTING PLACE FOR PARTIAL PRICING.
C
      LOGICAL COLSCP,SAVEDT,CONTIN,CSTSCP,UNBND,
     *        FEAS,FINITE,FOUND,MINPRB,REDBAS,
     *        SINGLR,SIZEUP,STPEDG,TRANS,USRBAS,ZEROLV,LOPT(08)
      CHARACTER*8 XERN1, XERN2
      EQUIVALENCE (CONTIN,LOPT(1)),(USRBAS,LOPT(2)),
     *  (SIZEUP,LOPT(3)),(SAVEDT,LOPT(4)),(COLSCP,LOPT(5)),
     *  (CSTSCP,LOPT(6)),(MINPRB,LOPT(7)),(STPEDG,LOPT(8)),
     *  (IDG,INTOPT(1)),(IPAGEF,INTOPT(2)),(ISAVE,INTOPT(3)),
     *  (MXITLP,INTOPT(4)),(KPRINT,INTOPT(5)),(ITBRC,INTOPT(6)),
     *  (NPP,INTOPT(7)),(LPRG,INTOPT(8)),(EPS,ROPT(1)),(ASMALL,ROPT(2)),
     *  (ABIG,ROPT(3)),(COSTSC,ROPT(4)),(TOLLS,ROPT(5)),(TUNE,ROPT(6)),
     *   (TOLABS,ROPT(7))
C
C     COMMON BLOCK USED BY LA05 () PACKAGE..
      COMMON /LA05DD/ SMALL,LP,LENL,LENU,NCP,LROW,LCOL
      EXTERNAL DUSRMT
C
C     SET LP=0 SO NO ERROR MESSAGES WILL PRINT WITHIN LA05 () PACKAGE.
C***FIRST EXECUTABLE STATEMENT  DPLPMN
      LP=0
C
C     THE VALUES ZERO AND ONE.
      ZERO=0.D0
      ONE=1.D0
      FACTOR=0.01D0
      LPG=LMX-(NVARS+4)
      IOPT=1
      INFO=0
      UNBND=.FALSE.
      JSTRT=1
C
C     PROCESS USER OPTIONS IN PRGOPT(*).
C     CHECK THAT ANY USER-GIVEN CHANGES ARE WELL-DEFINED.
      CALL DPOPT(PRGOPT,MRELAS,NVARS,INFO,CSC,IBASIS,ROPT,INTOPT,LOPT)
      IF (.NOT.(INFO.LT.0)) GO TO 20002
      GO TO 30001
20002 IF (.NOT.(CONTIN)) GO TO 20003
      GO TO 30002
20006 GO TO 20004
C
C     INITIALIZE SPARSE DATA MATRIX, AMAT(*) AND IMAT(*).
20003 CALL DPINTM(MRELAS,NVARS,AMAT,IMAT,LMX,IPAGEF)
C
C     UPDATE MATRIX DATA AND CHECK BOUNDS FOR CONSISTENCY.
20004 CALL DPLPUP(DUSRMT,MRELAS,NVARS,PRGOPT,DATTRV,
     *     BL,BU,IND,INFO,AMAT,IMAT,SIZEUP,ASMALL,ABIG)
      IF (.NOT.(INFO.LT.0)) GO TO 20007
      GO TO 30001
C
C++  CODE FOR OUTPUT=YES IS ACTIVE
20007 IF (.NOT.(KPRINT.GE.1)) GO TO 20008
      GO TO 30003
20011 CONTINUE
C++  CODE FOR OUTPUT=NO IS INACTIVE
C++  END
C
C     INITIALIZATION. SCALE DATA, NORMALIZE BOUNDS, FORM COLUMN
C     CHECK SUMS, AND FORM INITIAL BASIS MATRIX.
20008 CALL DPINIT(MRELAS,NVARS,COSTS,BL,BU,IND,PRIMAL,INFO,
     * AMAT,CSC,COSTSC,COLNRM,XLAMDA,ANORM,RHS,RHSNRM,
     * IBASIS,IBB,IMAT,LOPT)
      IF (.NOT.(INFO.LT.0)) GO TO 20012
      GO TO 30001
C
20012 NREDC=0
      ASSIGN 20013 TO NPR004
      GO TO 30004
20013 IF (.NOT.(SINGLR)) GO TO 20014
      NERR=23
      CALL XERMSG ('SLATEC', 'DPLPMN',
     +   'IN DSPLP,  A SINGULAR INITIAL BASIS WAS ENCOUNTERED.', NERR,
     +   IOPT)
      INFO=-NERR
      GO TO 30001
20014 ASSIGN 20018 TO NPR005
      GO TO 30005
20018 ASSIGN 20019 TO NPR006
      GO TO 30006
20019 ASSIGN 20020 TO NPR007
      GO TO 30007
20020 IF (.NOT.(USRBAS)) GO TO 20021
      ASSIGN 20024 TO NPR008
      GO TO 30008
20024 IF (.NOT.(.NOT.FEAS)) GO TO 20025
      NERR=24
      CALL XERMSG ('SLATEC', 'DPLPMN',
     +   'IN DSPLP, AN INFEASIBLE INITIAL BASIS WAS ENCOUNTERED.',
     +   NERR, IOPT)
      INFO=-NERR
      GO TO 30001
20025 CONTINUE
20021 ITLP=0
C
C     LAMDA HAS BEEN SET TO A CONSTANT, PERFORM PENALTY METHOD.
      ASSIGN 20029 TO NPR009
      GO TO 30009
20029 ASSIGN 20030 TO NPR010
      GO TO 30010
20030 ASSIGN 20031 TO NPR006
      GO TO 30006
20031 ASSIGN 20032 TO NPR008
      GO TO 30008
20032 IF (.NOT.(.NOT.FEAS)) GO TO 20033
C
C     SET LAMDA TO INFINITY BY SETTING COSTSC TO ZERO (SAVE THE VALUE OF
C     COSTSC) AND PERFORM STANDARD PHASE-1.
      IF(KPRINT.GE.2)CALL IVOUT(0,IDUM,'('' ENTER STANDARD PHASE-1'')',
     *IDG)
      SCOSTS=COSTSC
      COSTSC=ZERO
      ASSIGN 20036 TO NPR007
      GO TO 30007
20036 ASSIGN 20037 TO NPR009
      GO TO 30009
20037 ASSIGN 20038 TO NPR010
      GO TO 30010
20038 ASSIGN 20039 TO NPR006
      GO TO 30006
20039 ASSIGN 20040 TO NPR008
      GO TO 30008
20040 IF (.NOT.(FEAS)) GO TO 20041
C
C     SET LAMDA TO ZERO, COSTSC=SCOSTS, PERFORM STANDARD PHASE-2.
      IF(KPRINT.GT.1)CALL IVOUT(0,IDUM,'('' ENTER STANDARD PHASE-2'')',
     *IDG)
      XLAMDA=ZERO
      COSTSC=SCOSTS
      ASSIGN 20044 TO NPR009
      GO TO 30009
20044 CONTINUE
20041 GO TO 20034
C     CHECK IF ANY BASIC VARIABLES ARE STILL CLASSIFIED AS
C     INFEASIBLE.  IF ANY ARE, THEN THIS MAY NOT YET BE AN
C     OPTIMAL POINT.  THEREFORE SET LAMDA TO ZERO AND TRY
C     TO PERFORM MORE SIMPLEX STEPS.
20033 I=1
      N20046=MRELAS
      GO TO 20047
20046 I=I+1
20047 IF ((N20046-I).LT.0) GO TO 20048
      IF (PRIMAL(I+NVARS).NE.ZERO) GO TO 20045
      GO TO 20046
20048 GO TO 20035
20045 XLAMDA=ZERO
      ASSIGN 20050 TO NPR009
      GO TO 30009
20050 CONTINUE
20034 CONTINUE
C
20035 ASSIGN 20051 TO NPR011
      GO TO 30011
20051 IF (.NOT.(FEAS.AND.(.NOT.UNBND))) GO TO 20052
      INFO=1
      GO TO 20053
20052 IF (.NOT.((.NOT.FEAS).AND.(.NOT.UNBND))) GO TO 10001
      NERR=1
      CALL XERMSG ('SLATEC', 'DPLPMN',
     +   'IN DSPLP, THE PROBLEM APPEARS TO BE INFEASIBLE', NERR, IOPT)
      INFO=-NERR
      GO TO 20053
10001 IF (.NOT.(FEAS .AND. UNBND)) GO TO 10002
      NERR=2
      CALL XERMSG ('SLATEC', 'DPLPMN',
     +   'IN DSPLP, THE PROBLEM APPEARS TO HAVE NO FINITE SOLUTION.',
     +   NERR, IOPT)
      INFO=-NERR
      GO TO 20053
10002 IF (.NOT.((.NOT.FEAS).AND.UNBND)) GO TO 10003
      NERR=3
      CALL XERMSG ('SLATEC', 'DPLPMN',
     +   'IN DSPLP, THE PROBLEM APPEARS TO BE INFEASIBLE AND TO ' //
     +   'HAVE NO FINITE SOLN.', NERR, IOPT)
      INFO=-NERR
10003 CONTINUE
20053 CONTINUE
C
      IF (.NOT.(INFO.EQ.(-1) .OR. INFO.EQ.(-3))) GO TO 20055
      SIZE=DASUM(NVARS,PRIMAL,1)*ANORM
      SIZE=SIZE/DASUM(NVARS,CSC,1)
      SIZE=SIZE+DASUM(MRELAS,PRIMAL(NVARS+1),1)
      I=1
      N20058=NVARS+MRELAS
      GO TO 20059
20058 I=I+1
20059 IF ((N20058-I).LT.0) GO TO 20060
      NX0066=IND(I)
      IF (NX0066.LT.1.OR.NX0066.GT.4) GO TO 20066
      GO TO (20062,20063,20064,20065), NX0066
20062 IF (.NOT.(SIZE+ABS(PRIMAL(I)-BL(I))*FACTOR.EQ.SIZE)) GO TO 20068
      GO TO 20058
20068 IF (.NOT.(PRIMAL(I).GT.BL(I))) GO TO 10004
      GO TO 20058
10004 IND(I)=-4
      GO TO 20067
20063 IF (.NOT.(SIZE+ABS(PRIMAL(I)-BU(I))*FACTOR.EQ.SIZE)) GO TO 20071
      GO TO 20058
20071 IF (.NOT.(PRIMAL(I).LT.BU(I))) GO TO 10005
      GO TO 20058
10005 IND(I)=-4
      GO TO 20067
20064 IF (.NOT.(SIZE+ABS(PRIMAL(I)-BL(I))*FACTOR.EQ.SIZE)) GO TO 20074
      GO TO 20058
20074 IF (.NOT.(PRIMAL(I).LT.BL(I))) GO TO 10006
      IND(I)=-4
      GO TO 20075
10006 IF (.NOT.(SIZE+ABS(PRIMAL(I)-BU(I))*FACTOR.EQ.SIZE)) GO TO 10007
      GO TO 20058
10007 IF (.NOT.(PRIMAL(I).GT.BU(I))) GO TO 10008
      IND(I)=-4
      GO TO 20075
10008 GO TO 20058
20075 GO TO 20067
20065 GO TO 20058
20066 CONTINUE
20067 GO TO 20058
20060 CONTINUE
20055 CONTINUE
C
      IF (.NOT.(INFO.EQ.(-2) .OR. INFO.EQ.(-3))) GO TO 20077
      J=1
      N20080=NVARS
      GO TO 20081
20080 J=J+1
20081 IF ((N20080-J).LT.0) GO TO 20082
      IF (.NOT.(IBB(J).EQ.0)) GO TO 20084
      NX0091=IND(J)
      IF (NX0091.LT.1.OR.NX0091.GT.4) GO TO 20091
      GO TO (20087,20088,20089,20090), NX0091
20087 BU(J)=BL(J)
      IND(J)=-3
      GO TO 20092
20088 BL(J)=BU(J)
      IND(J)=-3
      GO TO 20092
20089 GO TO 20080
20090 BL(J)=ZERO
      BU(J)=ZERO
      IND(J)=-3
20091 CONTINUE
20092 CONTINUE
20084 GO TO 20080
20082 CONTINUE
20077 CONTINUE
C++  CODE FOR OUTPUT=YES IS ACTIVE
      IF (.NOT.(KPRINT.GE.1)) GO TO 20093
      ASSIGN 20096 TO NPR012
      GO TO 30012
20096 CONTINUE
20093 CONTINUE
C++  CODE FOR OUTPUT=NO IS INACTIVE
C++  END
      GO TO 30001
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (COMPUTE RIGHT HAND SIDE)
30010 RHS(1)=ZERO
      CALL DCOPY(MRELAS,RHS,0,RHS,1)
      J=1
      N20098=NVARS+MRELAS
      GO TO 20099
20098 J=J+1
20099 IF ((N20098-J).LT.0) GO TO 20100
      NX0106=IND(J)
      IF (NX0106.LT.1.OR.NX0106.GT.4) GO TO 20106
      GO TO (20102,20103,20104,20105), NX0106
20102 SCALR=-BL(J)
      GO TO 20107
20103 SCALR=-BU(J)
      GO TO 20107
20104 SCALR=-BL(J)
      GO TO 20107
20105 SCALR=ZERO
20106 CONTINUE
20107 IF (.NOT.(SCALR.NE.ZERO)) GO TO 20108
      IF (.NOT.(J.LE.NVARS)) GO TO 20111
      I=0
20114 CALL DPNNZR(I,AIJ,IPLACE,AMAT,IMAT,J)
      IF (.NOT.(I.LE.0)) GO TO 20116
      GO TO 20115
20116 RHS(I)=RHS(I)+AIJ*SCALR
      GO TO 20114
20115 GO TO 20112
20111 RHS(J-NVARS)=RHS(J-NVARS)-SCALR
20112 CONTINUE
20108 GO TO 20098
20100 J=1
      N20119=NVARS+MRELAS
      GO TO 20120
20119 J=J+1
20120 IF ((N20119-J).LT.0) GO TO 20121
      SCALR=ZERO
      IF(IND(J).EQ.3.AND.MOD(IBB(J),2).EQ.0) SCALR=BU(J)-BL(J)
      IF (.NOT.(SCALR.NE.ZERO)) GO TO 20123
      IF (.NOT.(J.LE.NVARS)) GO TO 20126
      I=0
20129 CALL DPNNZR(I,AIJ,IPLACE,AMAT,IMAT,J)
      IF (.NOT.(I.LE.0)) GO TO 20131
      GO TO 20130
20131 RHS(I)=RHS(I)-AIJ*SCALR
      GO TO 20129
20130 GO TO 20127
20126 RHS(J-NVARS)=RHS(J-NVARS)+SCALR
20127 CONTINUE
20123 GO TO 20119
20121 CONTINUE
      GO TO NPR010, (20030,20038)
C     PROCEDURE (PERFORM SIMPLEX STEPS)
30009 ASSIGN 20134 TO NPR013
      GO TO 30013
20134 ASSIGN 20135 TO NPR014
      GO TO 30014
20135 IF (.NOT.(KPRINT.GT.2)) GO TO 20136
      CALL DVOUT(MRELAS,DUALS,'('' BASIC (INTERNAL) DUAL SOLN.'')',IDG)
      CALL DVOUT(NVARS+MRELAS,RZ,'('' REDUCED COSTS'')',IDG)
20136 CONTINUE
20139 ASSIGN 20141 TO NPR015
      GO TO 30015
20141 IF (.NOT.(.NOT. FOUND)) GO TO 20142
      GO TO 30016
20145 CONTINUE
20142 IF (.NOT.(FOUND)) GO TO 20146
      IF (KPRINT.GE.3) CALL DVOUT(MRELAS,WW,'('' SEARCH DIRECTION'')',
     *IDG)
      GO TO 30017
20149 IF (.NOT.(FINITE)) GO TO 20150
      GO TO 30018
20153 ASSIGN 20154 TO NPR005
      GO TO 30005
20154 GO TO 20151
20150 UNBND=.TRUE.
      IBB(IBASIS(IENTER))=0
20151 GO TO 20147
20146 GO TO 20140
20147 ITLP=ITLP+1
      GO TO 30019
20155 GO TO 20139
20140 CONTINUE
      GO TO NPR009, (20029,20037,20044,20050)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (RETRIEVE SAVED DATA FROM FILE ISAVE)
30002 LPR=NVARS+4
      REWIND ISAVE
      READ(ISAVE) (AMAT(I),I=1,LPR),(IMAT(I),I=1,LPR)
      KEY=2
      IPAGE=1
      GO TO 20157
20156 IF (NP.LT.0) GO TO 20158
20157 LPR1=LPR+1
      READ(ISAVE) (AMAT(I),I=LPR1,LMX),(IMAT(I),I=LPR1,LMX)
      CALL DPRWPG(KEY,IPAGE,LPG,AMAT,IMAT)
      NP=IMAT(LMX-1)
      IPAGE=IPAGE+1
      GO TO 20156
20158 NPARM=NVARS+MRELAS
      READ(ISAVE) (IBASIS(I),I=1,NPARM)
      REWIND ISAVE
      GO TO 20006
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (SAVE DATA ON FILE ISAVE)
C
C     SOME PAGES MAY NOT BE WRITTEN YET.
30020 IF (.NOT.(AMAT(LMX).EQ.ONE)) GO TO 20159
      AMAT(LMX)=ZERO
      KEY=2
      IPAGE=ABS(IMAT(LMX-1))
      CALL DPRWPG(KEY,IPAGE,LPG,AMAT,IMAT)
C
C     FORCE PAGE FILE TO BE OPENED ON RESTARTS.
20159 KEY=AMAT(4)
      AMAT(4)=ZERO
      LPR=NVARS+4
      WRITE(ISAVE) (AMAT(I),I=1,LPR),(IMAT(I),I=1,LPR)
      AMAT(4)=KEY
      IPAGE=1
      KEY=1
      GO TO 20163
20162 IF (NP.LT.0) GO TO 20164
20163 CALL DPRWPG(KEY,IPAGE,LPG,AMAT,IMAT)
      LPR1=LPR+1
      WRITE(ISAVE) (AMAT(I),I=LPR1,LMX),(IMAT(I),I=LPR1,LMX)
      NP=IMAT(LMX-1)
      IPAGE=IPAGE+1
      GO TO 20162
20164 NPARM=NVARS+MRELAS
      WRITE(ISAVE) (IBASIS(I),I=1,NPARM)
      ENDFILE ISAVE
C
C     CLOSE FILE, IPAGEF, WHERE PAGES ARE STORED. THIS IS NEEDED SO THAT
C     THE PAGES MAY BE RESTORED AT A CONTINUATION OF DSPLP().
      GO TO 20317
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (DECOMPOSE BASIS MATRIX)
C++  CODE FOR OUTPUT=YES IS ACTIVE
30004 IF (.NOT.(KPRINT.GE.2)) GO TO 20165
      CALL IVOUT(MRELAS,IBASIS,
     *'('' SUBSCRIPTS OF BASIC VARIABLES DURING REDECOMPOSITION'')',
     *IDG)
C++  CODE FOR OUTPUT=NO IS INACTIVE
C++  END
C
C     SET RELATIVE PIVOTING FACTOR FOR USE IN LA05 () PACKAGE.
20165 UU=0.1
      CALL DPLPDM(
     *MRELAS,NVARS,LMX,LBM,NREDC,INFO,IOPT,
     *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB,
     *ANORM,EPS,UU,GG,
     *AMAT,BASMAT,CSC,WR,
     *SINGLR,REDBAS)
      IF (.NOT.(INFO.LT.0)) GO TO 20168
      GO TO 30001
20168 CONTINUE
      GO TO NPR004, (20013,20204,20242)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (CLASSIFY VARIABLES)
C
C     DEFINE THE CLASSIFICATION OF THE BASIC VARIABLES
C     -1 VIOLATES LOWER BOUND, 0 FEASIBLE, +1 VIOLATES UPPER BOUND.
C     (THIS INFO IS STORED IN PRIMAL(NVARS+1)-PRIMAL(NVARS+MRELAS))
C     TRANSLATE VARIABLE TO ITS UPPER BOUND, IF .GT. UPPER BOUND
30007 PRIMAL(NVARS+1)=ZERO
      CALL DCOPY(MRELAS,PRIMAL(NVARS+1),0,PRIMAL(NVARS+1),1)
      I=1
      N20172=MRELAS
      GO TO 20173
20172 I=I+1
20173 IF ((N20172-I).LT.0) GO TO 20174
      J=IBASIS(I)
      IF (.NOT.(IND(J).NE.4)) GO TO 20176
      IF (.NOT.(RPRIM(I).LT.ZERO)) GO TO 20179
      PRIMAL(I+NVARS)=-ONE
      GO TO 20180
20179 IF (.NOT.(IND(J).EQ.3)) GO TO 10009
      UPBND=BU(J)-BL(J)
      IF (J.LE.NVARS) UPBND=UPBND/CSC(J)
      IF (.NOT.(RPRIM(I).GT.UPBND)) GO TO 20182
      RPRIM(I)=RPRIM(I)-UPBND
      IF (.NOT.(J.LE.NVARS)) GO TO 20185
      K=0
20188 CALL DPNNZR(K,AIJ,IPLACE,AMAT,IMAT,J)
      IF (.NOT.(K.LE.0)) GO TO 20190
      GO TO 20189
20190 RHS(K)=RHS(K)-UPBND*AIJ*CSC(J)
      GO TO 20188
20189 GO TO 20186
20185 RHS(J-NVARS)=RHS(J-NVARS)+UPBND
20186 PRIMAL(I+NVARS)=ONE
20182 CONTINUE
      CONTINUE
10009 CONTINUE
20180 CONTINUE
20176 GO TO 20172
20174 CONTINUE
      GO TO NPR007, (20020,20036)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (COMPUTE ERROR IN DUAL AND PRIMAL SYSTEMS)
30005 NTRIES=1
      GO TO 20195
20194 NTRIES=NTRIES+1
20195 IF ((2-NTRIES).LT.0) GO TO 20196
      CALL DPLPCE(
     *MRELAS,NVARS,LMX,LBM,ITLP,ITBRC,
     *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB,
     *ERDNRM,EPS,TUNE,GG,
     *AMAT,BASMAT,CSC,WR,WW,PRIMAL,ERD,ERP,
     *SINGLR,REDBAS)
      IF (.NOT.(.NOT. SINGLR)) GO TO 20198
C++  CODE FOR OUTPUT=YES IS ACTIVE
      IF (.NOT.(KPRINT.GE.3)) GO TO 20201
      CALL DVOUT(MRELAS,ERP,'('' EST. ERROR IN PRIMAL COMPS.'')',IDG)
      CALL DVOUT(MRELAS,ERD,'('' EST. ERROR IN DUAL COMPS.'')',IDG)
20201 CONTINUE
C++  CODE FOR OUTPUT=NO IS INACTIVE
C++  END
      GO TO 20193
20198 IF (NTRIES.EQ.2) GO TO 20197
      ASSIGN 20204 TO NPR004
      GO TO 30004
20204 CONTINUE
      GO TO 20194
20196 CONTINUE
20197 NERR=26
      CALL XERMSG ('SLATEC', 'DPLPMN',
     +   'IN DSPLP, MOVED TO A SINGULAR POINT. THIS SHOULD NOT HAPPEN.',
     +   NERR, IOPT)
      INFO=-NERR
      GO TO 30001
20193 CONTINUE
      GO TO NPR005, (20018,20154,20243)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (CHECK FEASIBILITY)
C
C     SEE IF NEARBY FEASIBLE POINT SATISFIES THE CONSTRAINT
C     EQUATIONS.
C
C     COPY RHS INTO WW(*), THEN UPDATE WW(*).
30008 CALL DCOPY(MRELAS,RHS,1,WW,1)
      J=1
      N20206=MRELAS
      GO TO 20207
20206 J=J+1
20207 IF ((N20206-J).LT.0) GO TO 20208
      IBAS=IBASIS(J)
      XVAL=RPRIM(J)
C
C     ALL VARIABLES BOUNDED BELOW HAVE ZERO AS THAT BOUND.
      IF (IND(IBAS).LE.3) XVAL=MAX(ZERO,XVAL)
C
C     IF THE VARIABLE HAS AN UPPER BOUND, COMPUTE THAT BOUND.
      IF (.NOT.(IND(IBAS).EQ.3)) GO TO 20210
      UPBND=BU(IBAS)-BL(IBAS)
      IF (IBAS.LE.NVARS) UPBND=UPBND/CSC(IBAS)
      XVAL=MIN(UPBND,XVAL)
20210 CONTINUE
C
C     SUBTRACT XVAL TIMES COLUMN VECTOR FROM RIGHT-HAND SIDE IN WW(*)
      IF (.NOT.(XVAL.NE.ZERO)) GO TO 20213
      IF (.NOT.(IBAS.LE.NVARS)) GO TO 20216
      I=0
20219 CALL DPNNZR(I,AIJ,IPLACE,AMAT,IMAT,IBAS)
      IF (.NOT.(I.LE.0)) GO TO 20221
      GO TO 20220
20221 WW(I)=WW(I)-XVAL*AIJ*CSC(IBAS)
      GO TO 20219
20220 GO TO 20217
20216 IF (.NOT.(IND(IBAS).EQ.2)) GO TO 20224
      WW(IBAS-NVARS)=WW(IBAS-NVARS)-XVAL
      GO TO 20225
20224 WW(IBAS-NVARS)=WW(IBAS-NVARS)+XVAL
20225 CONTINUE
      CONTINUE
20217 CONTINUE
20213 CONTINUE
      GO TO 20206
C
C   COMPUTE NORM OF DIFFERENCE AND CHECK FOR FEASIBILITY.
20208 RESNRM=DASUM(MRELAS,WW,1)
      FEAS=RESNRM.LE.TOLLS*(RPRNRM*ANORM+RHSNRM)
C
C     TRY AN ABSOLUTE ERROR TEST IF THE RELATIVE TEST FAILS.
      IF(.NOT. FEAS)FEAS=RESNRM.LE.TOLABS
      IF (.NOT.(FEAS)) GO TO 20227
      PRIMAL(NVARS+1)=ZERO
      CALL DCOPY(MRELAS,PRIMAL(NVARS+1),0,PRIMAL(NVARS+1),1)
20227 CONTINUE
      GO TO NPR008, (20024,20032,20040)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (INITIALIZE REDUCED COSTS AND STEEPEST EDGE WEIGHTS)
30014 CALL DPINCW(
     *MRELAS,NVARS,LMX,LBM,NPP,JSTRT,
     *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB,
     *COSTSC,GG,ERDNRM,DULNRM,
     *AMAT,BASMAT,CSC,WR,WW,RZ,RG,COSTS,COLNRM,DUALS,
     *STPEDG)
C
      GO TO NPR014, (20135,20246)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (CHECK AND RETURN WITH EXCESS ITERATIONS)
30019 IF (.NOT.(ITLP.GT.MXITLP)) GO TO 20230
      NERR=25
      ASSIGN 20233 TO NPR011
      GO TO 30011
C++  CODE FOR OUTPUT=YES IS ACTIVE
20233 IF (.NOT.(KPRINT.GE.1)) GO TO 20234
      ASSIGN 20237 TO NPR012
      GO TO 30012
20237 CONTINUE
20234 CONTINUE
C++  CODE FOR OUTPUT=NO IS INACTIVE
C++  END
      IDUM(1)=0
      IF(SAVEDT) IDUM(1)=ISAVE
      WRITE (XERN1, '(I8)') MXITLP
      WRITE (XERN2, '(I8)') IDUM(1)
      CALL XERMSG ('SLATEC', 'DPLPMN',
     *   'IN DSPLP, MAX ITERATIONS = ' // XERN1 //
     *   ' TAKEN.  UP-TO-DATE RESULTS SAVED ON FILE NO. ' // XERN2 //
     *   '.   IF FILE NO. = 0, NO SAVE.', NERR, IOPT)
      INFO=-NERR
      GO TO 30001
20230 CONTINUE
      GO TO 20155
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (REDECOMPOSE BASIS MATRIX AND TRY AGAIN)
30016 IF (.NOT.(.NOT.REDBAS)) GO TO 20239
      ASSIGN 20242 TO NPR004
      GO TO 30004
20242 ASSIGN 20243 TO NPR005
      GO TO 30005
20243 ASSIGN 20244 TO NPR006
      GO TO 30006
20244 ASSIGN 20245 TO NPR013
      GO TO 30013
20245 ASSIGN 20246 TO NPR014
      GO TO 30014
20246 CONTINUE
C
C     ERASE NON-CYCLING MARKERS NEAR COMPLETION.
20239 I=MRELAS+1
      N20247=MRELAS+NVARS
      GO TO 20248
20247 I=I+1
20248 IF ((N20247-I).LT.0) GO TO 20249
      IBASIS(I)=ABS(IBASIS(I))
      GO TO 20247
20249 ASSIGN 20251 TO NPR015
      GO TO 30015
20251 CONTINUE
      GO TO 20145
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (COMPUTE NEW PRIMAL)
C
C     COPY RHS INTO WW(*), SOLVE SYSTEM.
30006 CALL DCOPY(MRELAS,RHS,1,WW,1)
      TRANS = .FALSE.
      CALL LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS)
      CALL DCOPY(MRELAS,WW,1,RPRIM,1)
      RPRNRM=DASUM(MRELAS,RPRIM,1)
      GO TO NPR006, (20019,20031,20039,20244,20275)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (COMPUTE NEW DUALS)
C
C     SOLVE FOR DUAL VARIABLES. FIRST COPY COSTS INTO DUALS(*).
30013 I=1
      N20252=MRELAS
      GO TO 20253
20252 I=I+1
20253 IF ((N20252-I).LT.0) GO TO 20254
      J=IBASIS(I)
      IF (.NOT.(J.LE.NVARS)) GO TO 20256
      DUALS(I)=COSTSC*COSTS(J)*CSC(J) + XLAMDA*PRIMAL(I+NVARS)
      GO TO 20257
20256 DUALS(I)=XLAMDA*PRIMAL(I+NVARS)
20257 CONTINUE
      GO TO 20252
C
20254 TRANS=.TRUE.
      CALL LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,DUALS,TRANS)
      DULNRM=DASUM(MRELAS,DUALS,1)
      GO TO NPR013, (20134,20245,20267)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (FIND VARIABLE TO ENTER BASIS AND GET SEARCH DIRECTION)
30015 CALL DPLPFE(
     *MRELAS,NVARS,LMX,LBM,IENTER,
     *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB,
     *ERDNRM,EPS,GG,DULNRM,DIRNRM,
     *AMAT,BASMAT,CSC,WR,WW,BL,BU,RZ,RG,COLNRM,DUALS,
     *FOUND)
      GO TO NPR015, (20141,20251)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (CHOOSE VARIABLE TO LEAVE BASIS)
30017 CALL DPLPFL(
     *MRELAS,NVARS,IENTER,ILEAVE,
     *IBASIS,IND,IBB,
     *THETA,DIRNRM,RPRNRM,
     *CSC,WW,BL,BU,ERP,RPRIM,PRIMAL,
     *FINITE,ZEROLV)
      GO TO 20149
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (MAKE MOVE AND UPDATE)
30018 CALL DPLPMU(
     *MRELAS,NVARS,LMX,LBM,NREDC,INFO,IENTER,ILEAVE,IOPT,NPP,JSTRT,
     *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB,
     *ANORM,EPS,UU,GG,RPRNRM,ERDNRM,DULNRM,THETA,COSTSC,XLAMDA,RHSNRM,
     *AMAT,BASMAT,CSC,WR,RPRIM,WW,BU,BL,RHS,ERD,ERP,RZ,RG,COLNRM,COSTS,
     *PRIMAL,DUALS,SINGLR,REDBAS,ZEROLV,STPEDG)
      IF (.NOT.(INFO.EQ.(-26))) GO TO 20259
      GO TO 30001
C++  CODE FOR OUTPUT=YES IS ACTIVE
20259 IF (.NOT.(KPRINT.GE.2)) GO TO 20263
      GO TO 30021
20266 CONTINUE
C++  CODE FOR OUTPUT=NO IS INACTIVE
C++  END
20263 CONTINUE
      GO TO 20153
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE(RESCALE AND REARRANGE VARIABLES)
C
C     RESCALE THE DUAL VARIABLES.
30011 ASSIGN 20267 TO NPR013
      GO TO 30013
20267 IF (.NOT.(COSTSC.NE.ZERO)) GO TO 20268
      I=1
      N20271=MRELAS
      GO TO 20272
20271 I=I+1
20272 IF ((N20271-I).LT.0) GO TO 20273
      DUALS(I)=DUALS(I)/COSTSC
      GO TO 20271
20273 CONTINUE
20268 ASSIGN 20275 TO NPR006
      GO TO 30006
C
C     REAPPLY COLUMN SCALING TO PRIMAL.
20275 I=1
      N20276=MRELAS
      GO TO 20277
20276 I=I+1
20277 IF ((N20276-I).LT.0) GO TO 20278
      J=IBASIS(I)
      IF (.NOT.(J.LE.NVARS)) GO TO 20280
      SCALR=CSC(J)
      IF(IND(J).EQ.2)SCALR=-SCALR
      RPRIM(I)=RPRIM(I)*SCALR
20280 GO TO 20276
C
C     REPLACE TRANSLATED BASIC VARIABLES INTO ARRAY PRIMAL(*)
20278 PRIMAL(1)=ZERO
      CALL DCOPY(NVARS+MRELAS,PRIMAL,0,PRIMAL,1)
      J=1
      N20283=NVARS+MRELAS
      GO TO 20284
20283 J=J+1
20284 IF ((N20283-J).LT.0) GO TO 20285
      IBAS=ABS(IBASIS(J))
      XVAL=ZERO
      IF (J.LE.MRELAS) XVAL=RPRIM(J)
      IF (IND(IBAS).EQ.1) XVAL=XVAL+BL(IBAS)
      IF (IND(IBAS).EQ.2) XVAL=BU(IBAS)-XVAL
      IF (.NOT.(IND(IBAS).EQ.3)) GO TO 20287
      IF (MOD(IBB(IBAS),2).EQ.0) XVAL=BU(IBAS)-BL(IBAS)-XVAL
      XVAL = XVAL+BL(IBAS)
20287 PRIMAL(IBAS)=XVAL
      GO TO 20283
C
C     COMPUTE DUALS FOR INDEPENDENT VARIABLES WITH BOUNDS.
C     OTHER ENTRIES ARE ZERO.
20285 J=1
      N20290=NVARS
      GO TO 20291
20290 J=J+1
20291 IF ((N20290-J).LT.0) GO TO 20292
      RZJ=ZERO
      IF (.NOT.(IBB(J).GT.ZERO .AND. IND(J).NE.4)) GO TO 20294
      RZJ=COSTS(J)
      I=0
20297 CALL DPNNZR(I,AIJ,IPLACE,AMAT,IMAT,J)
      IF (.NOT.(I.LE.0)) GO TO 20299
      GO TO 20298
20299 CONTINUE
      RZJ=RZJ-AIJ*DUALS(I)
      GO TO 20297
20298 CONTINUE
20294 DUALS(MRELAS+J)=RZJ
      GO TO 20290
20292 CONTINUE
      GO TO NPR011, (20051,20233)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C++  CODE FOR OUTPUT=YES IS ACTIVE
C     PROCEDURE (PRINT PROLOGUE)
30003 IDUM(1)=MRELAS
      CALL IVOUT(1,IDUM,'(''1NUM. OF DEPENDENT VARS., MRELAS'')',IDG)
      IDUM(1)=NVARS
      CALL IVOUT(1,IDUM,'('' NUM. OF INDEPENDENT VARS., NVARS'')',IDG)
      CALL IVOUT(1,IDUM,'('' DIMENSION OF COSTS(*)='')',IDG)
      IDUM(1)=NVARS+MRELAS
      CALL IVOUT(1,IDUM, '('' DIMENSIONS OF BL(*),BU(*),IND(*)''
     */'' PRIMAL(*),DUALS(*) ='')',IDG)
      CALL IVOUT(1,IDUM,'('' DIMENSION OF IBASIS(*)='')',IDG)
      IDUM(1)=LPRG+1
      CALL IVOUT(1,IDUM,'('' DIMENSION OF PRGOPT(*)='')',IDG)
      CALL IVOUT(0,IDUM,
     * '('' 1-NVARS=INDEPENDENT VARIABLE INDICES.''/
     * '' (NVARS+1)-(NVARS+MRELAS)=DEPENDENT VARIABLE INDICES.''/
     * '' CONSTRAINT INDICATORS ARE 1-4 AND MEAN'')',IDG)
      CALL IVOUT(0,IDUM,
     * '('' 1=VARIABLE HAS ONLY LOWER BOUND.''/
     * '' 2=VARIABLE HAS ONLY UPPER BOUND.''/
     * '' 3=VARIABLE HAS BOTH BOUNDS.''/
     * '' 4=VARIABLE HAS NO BOUNDS, IT IS FREE.'')',IDG)
      CALL DVOUT(NVARS,COSTS,'('' ARRAY OF COSTS'')',IDG)
      CALL IVOUT(NVARS+MRELAS,IND,
     * '('' CONSTRAINT INDICATORS'')',IDG)
      CALL DVOUT(NVARS+MRELAS,BL,
     *'('' LOWER BOUNDS FOR VARIABLES  (IGNORE UNUSED ENTRIES.)'')',IDG)
      CALL DVOUT(NVARS+MRELAS,BU,
     *'('' UPPER BOUNDS FOR VARIABLES  (IGNORE UNUSED ENTRIES.)'')',IDG)
      IF (.NOT.(KPRINT.GE.2)) GO TO 20302
      CALL IVOUT(0,IDUM,
     * '(''0NON-BASIC INDICES THAT ARE NEGATIVE SHOW VARIABLES''
     * '' EXCHANGED AT A ZERO''/'' STEP LENGTH'')',IDG)
      CALL IVOUT(0,IDUM,
     * '('' WHEN COL. NO. LEAVING=COL. NO. ENTERING, THE ENTERING ''
     * ''VARIABLE MOVED''/'' TO ITS BOUND.  IT REMAINS NON-BASIC.''/
     * '' WHEN COL. NO. OF BASIS EXCHANGED IS NEGATIVE, THE LEAVING''/
     * '' VARIABLE IS AT ITS UPPER BOUND.'')',IDG)
20302 CONTINUE
      GO TO 20011
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (PRINT SUMMARY)
30012 IDUM(1)=INFO
      CALL IVOUT(1,IDUM,'('' THE OUTPUT VALUE OF INFO IS'')',IDG)
      IF (.NOT.(MINPRB)) GO TO 20305
      CALL IVOUT(0,IDUM,'('' THIS IS A MINIMIZATION PROBLEM.'')',IDG)
      GO TO 20306
20305 CALL IVOUT(0,IDUM,'('' THIS IS A MAXIMIZATION PROBLEM.'')',IDG)
20306 IF (.NOT.(STPEDG)) GO TO 20308
      CALL IVOUT(0,IDUM,'('' STEEPEST EDGE PRICING WAS USED.'')',IDG)
      GO TO 20309
20308 CALL IVOUT(0,IDUM,'('' MINIMUM REDUCED COST PRICING WAS USED.'')',
     * IDG)
20309 RDUM(1)=DDOT(NVARS,COSTS,1,PRIMAL,1)
      CALL DVOUT(1,RDUM,
     * '('' OUTPUT VALUE OF THE OBJECTIVE FUNCTION'')',IDG)
      CALL DVOUT(NVARS+MRELAS,PRIMAL,
     * '('' THE OUTPUT INDEPENDENT AND DEPENDENT VARIABLES'')',IDG)
      CALL DVOUT(MRELAS+NVARS,DUALS,
     * '('' THE OUTPUT DUAL VARIABLES'')',IDG)
      CALL IVOUT(NVARS+MRELAS,IBASIS,
     * '('' VARIABLE INDICES IN POSITIONS 1-MRELAS ARE BASIC.'')',IDG)
      IDUM(1)=ITLP
      CALL IVOUT(1,IDUM,'('' NO. OF ITERATIONS'')',IDG)
      IDUM(1)=NREDC
      CALL IVOUT(1,IDUM,'('' NO. OF FULL REDECOMPS'')',IDG)
      GO TO NPR012, (20096,20237)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (PRINT ITERATION SUMMARY)
30021 IDUM(1)=ITLP+1
      CALL IVOUT(1,IDUM,'(''0ITERATION NUMBER'')',IDG)
      IDUM(1)=IBASIS(ABS(ILEAVE))
      CALL IVOUT(1,IDUM,
     * '('' INDEX OF VARIABLE ENTERING THE BASIS'')',IDG)
      IDUM(1)=ILEAVE
      CALL IVOUT(1,IDUM,'('' COLUMN OF THE BASIS EXCHANGED'')',IDG)
      IDUM(1)=IBASIS(IENTER)
      CALL IVOUT(1,IDUM,
     * '('' INDEX OF VARIABLE LEAVING THE BASIS'')',IDG)
      RDUM(1)=THETA
      CALL DVOUT(1,RDUM,'('' LENGTH OF THE EXCHANGE STEP'')',IDG)
      IF (.NOT.(KPRINT.GE.3)) GO TO 20311
      CALL DVOUT(MRELAS,RPRIM,'('' BASIC (INTERNAL) PRIMAL SOLN.'')',
     * IDG)
      CALL IVOUT(NVARS+MRELAS,IBASIS,
     * '('' VARIABLE INDICES IN POSITIONS 1-MRELAS ARE BASIC.'')',IDG)
      CALL IVOUT(NVARS+MRELAS,IBB,'('' IBB ARRAY'')',IDG)
      CALL DVOUT(MRELAS,RHS,'('' TRANSLATED RHS'')',IDG)
      CALL DVOUT(MRELAS,DUALS,'('' BASIC (INTERNAL) DUAL SOLN.'')',IDG)
20311 CONTINUE
      GO TO 20266
C++  CODE FOR OUTPUT=NO IS INACTIVE
C++  END
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (RETURN TO USER)
30001 IF (.NOT.(SAVEDT)) GO TO 20314
      GO TO 30020
20317 CONTINUE
20314 IF(IMAT(LMX-1).NE.(-1)) CALL SCLOSM(IPAGEF)
C
C     THIS TEST IS THERE ONLY TO AVOID DIAGNOSTICS ON SOME FORTRAN
C     COMPILERS.
      RETURN
      END