1*DECK DPLPMN
2      SUBROUTINE DPLPMN (DUSRMT, MRELAS, NVARS, COSTS, PRGOPT, DATTRV,
3     +   BL, BU, IND, INFO, PRIMAL, DUALS, AMAT, CSC, COLNRM, ERD, ERP,
4     +   BASMAT, WR, RZ, RG, RPRIM, RHS, WW, LMX, LBM, IBASIS, IBB,
5     +   IMAT, IBRC, IPR, IWR)
6C***BEGIN PROLOGUE  DPLPMN
7C***SUBSIDIARY
8C***PURPOSE  Subsidiary to DSPLP
9C***LIBRARY   SLATEC
10C***TYPE      DOUBLE PRECISION (SPLPMN-S, DPLPMN-D)
11C***AUTHOR  (UNKNOWN)
12C***DESCRIPTION
13C
14C     MARVEL OPTION(S).. OUTPUT=YES/NO TO ELIMINATE PRINTED OUTPUT.
15C     THIS DOES NOT APPLY TO THE CALLS TO THE ERROR PROCESSOR.
16C
17C     MAIN SUBROUTINE FOR DSPLP PACKAGE.
18C
19C***SEE ALSO  DSPLP
20C***ROUTINES CALLED  DASUM, DCOPY, DDOT, DPINCW, DPINIT, DPINTM, DPLPCE,
21C                    DPLPDM, DPLPFE, DPLPFL, DPLPMU, DPLPUP, DPNNZR,
22C                    DPOPT, DPRWPG, DVOUT, IVOUT, LA05BD, SCLOSM, XERMSG
23C***COMMON BLOCKS    LA05DD
24C***REVISION HISTORY  (YYMMDD)
25C   811215  DATE WRITTEN
26C   890531  Changed all specific intrinsics to generic.  (WRB)
27C   890605  Removed unreferenced labels.  (WRB)
28C   891009  Removed unreferenced variable.  (WRB)
29C   891214  Prologue converted to Version 4.0 format.  (BAB)
30C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
31C   900328  Added TYPE section.  (WRB)
32C   900510  Convert XERRWV calls to XERMSG calls.  (RWC)
33C***END PROLOGUE  DPLPMN
34      DOUBLE PRECISION ABIG,AIJ,AMAT(*),ANORM,ASMALL,BASMAT(*),
35     * BL(*),BU(*),COLNRM(*),COSTS(*),COSTSC,CSC(*),DATTRV(*),
36     * DIRNRM,DUALS(*),DULNRM,EPS,TUNE,ERD(*),ERDNRM,ERP(*),FACTOR,GG,
37     * ONE,PRGOPT(*),PRIMAL(*),RESNRM,RG(*),RHS(*),RHSNRM,ROPT(07),
38     * RPRIM(*),RPRNRM,RZ(*),RZJ,SCALR,SCOSTS,SIZE,SMALL,THETA,
39     * TOLLS,UPBND,UU,WR(*),WW(*),XLAMDA,XVAL,ZERO,RDUM(01),TOLABS
40      DOUBLE PRECISION DDOT,DASUM
41C
42      INTEGER IBASIS(*),IBB(*),IBRC(LBM,2),IMAT(*),IND(*),
43     * IPR(*),IWR(*),INTOPT(08),IDUM(01)
44C
45C     ARRAY LOCAL VARIABLES
46C     NAME(LENGTH)          DESCRIPTION
47C
48C     COSTS(NVARS)          COST COEFFICIENTS
49C     PRGOPT( )             OPTION VECTOR
50C     DATTRV( )             DATA TRANSFER VECTOR
51C     PRIMAL(NVARS+MRELAS)  AS OUTPUT IT IS PRIMAL SOLUTION OF LP.
52C                           INTERNALLY, THE FIRST NVARS POSITIONS HOLD
53C                           THE COLUMN CHECK SUMS.  THE NEXT MRELAS
54C                           POSITIONS HOLD THE CLASSIFICATION FOR THE
55C                           BASIC VARIABLES  -1 VIOLATES LOWER
56C                           BOUND, 0 FEASIBLE, +1 VIOLATES UPPER BOUND
57C     DUALS(MRELAS+NVARS)   DUAL SOLUTION. INTERNALLY HOLDS R.H. SIDE
58C                           AS FIRST MRELAS ENTRIES.
59C     AMAT(LMX)             SPARSE FORM OF DATA MATRIX
60C     IMAT(LMX)             SPARSE FORM OF DATA MATRIX
61C     BL(NVARS+MRELAS)      LOWER BOUNDS FOR VARIABLES
62C     BU(NVARS+MRELAS)      UPPER BOUNDS FOR VARIABLES
63C     IND(NVARS+MRELAS)     INDICATOR FOR VARIABLES
64C     CSC(NVARS)            COLUMN SCALING
65C     IBASIS(NVARS+MRELAS)  COLS. 1-MRELAS ARE BASIC, REST ARE NON-BASIC
66C     IBB(NVARS+MRELAS)     INDICATOR FOR NON-BASIC VARS., POLARITY OF
67C                           VARS., AND POTENTIALLY INFINITE VARS.
68C                           IF IBB(J).LT.0, VARIABLE J IS BASIC
69C                           IF IBB(J).GT.0, VARIABLE J IS NON-BASIC
70C                           IF IBB(J).EQ.0, VARIABLE J HAS TO BE IGNORED
71C                           BECAUSE IT WOULD CAUSE UNBOUNDED SOLN.
72C                           WHEN MOD(IBB(J),2).EQ.0, VARIABLE IS AT ITS
73C                           UPPER BOUND, OTHERWISE IT IS AT ITS LOWER
74C                           BOUND
75C     COLNRM(NVARS)         NORM OF COLUMNS
76C     ERD(MRELAS)           ERRORS IN DUAL VARIABLES
77C     ERP(MRELAS)           ERRORS IN PRIMAL VARIABLES
78C     BASMAT(LBM)           BASIS MATRIX FOR HARWELL SPARSE CODE
79C     IBRC(LBM,2)           ROW AND COLUMN POINTERS FOR BASMAT(*)
80C     IPR(2*MRELAS)         WORK ARRAY FOR HARWELL SPARSE CODE
81C     IWR(8*MRELAS)         WORK ARRAY FOR HARWELL SPARSE CODE
82C     WR(MRELAS)            WORK ARRAY FOR HARWELL SPARSE CODE
83C     RZ(NVARS+MRELAS)      REDUCED COSTS
84C     RPRIM(MRELAS)         INTERNAL PRIMAL SOLUTION
85C     RG(NVARS+MRELAS)      COLUMN WEIGHTS
86C     WW(MRELAS)            WORK ARRAY
87C     RHS(MRELAS)           HOLDS TRANSLATED RIGHT HAND SIDE
88C
89C     SCALAR LOCAL VARIABLES
90C     NAME       TYPE         DESCRIPTION
91C
92C     LMX        INTEGER      LENGTH OF AMAT(*)
93C     LPG        INTEGER      LENGTH OF PAGE FOR AMAT(*)
94C     EPS        DOUBLE       MACHINE PRECISION
95C     TUNE       DOUBLE       PARAMETER TO SCALE ERROR ESTIMATES
96C     TOLLS      DOUBLE       RELATIVE TOLERANCE FOR SMALL RESIDUALS
97C     TOLABS     DOUBLE       ABSOLUTE TOLERANCE FOR SMALL RESIDUALS.
98C                             USED IF RELATIVE ERROR TEST FAILS.
99C                             IN CONSTRAINT EQUATIONS
100C     FACTOR     DOUBLE      .01--DETERMINES IF BASIS IS SINGULAR
101C                             OR COMPONENT IS FEASIBLE.  MAY NEED TO
102C                             BE INCREASED TO 1.D0 ON SHORT WORD
103C                             LENGTH MACHINES.
104C     ASMALL     DOUBLE       LOWER BOUND FOR NON-ZERO MAGN. IN AMAT(*)
105C     ABIG       DOUBLE       UPPER BOUND FOR NON-ZERO MAGN. IN AMAT(*)
106C     MXITLP     INTEGER      MAXIMUM NUMBER OF ITERATIONS FOR LP
107C     ITLP       INTEGER      ITERATION COUNTER FOR TOTAL LP ITERS
108C     COSTSC     DOUBLE       COSTS(*) SCALING
109C     SCOSTS     DOUBLE       TEMP LOC. FOR COSTSC.
110C     XLAMDA     DOUBLE       WEIGHT PARAMETER FOR PEN. METHOD.
111C     ANORM      DOUBLE       NORM OF DATA MATRIX AMAT(*)
112C     RPRNRM     DOUBLE       NORM OF THE SOLUTION
113C     DULNRM     DOUBLE       NORM OF THE DUALS
114C     ERDNRM     DOUBLE       NORM OF ERROR IN DUAL VARIABLES
115C     DIRNRM     DOUBLE       NORM OF THE DIRECTION VECTOR
116C     RHSNRM     DOUBLE       NORM OF TRANSLATED RIGHT HAND SIDE VECTOR
117C     RESNRM     DOUBLE       NORM OF RESIDUAL VECTOR FOR CHECKING
118C                             FEASIBILITY
119C     NZBM       INTEGER      NUMBER OF NON-ZEROS IN BASMAT(*)
120C     LBM        INTEGER      LENGTH OF BASMAT(*)
121C     SMALL      DOUBLE       EPS*ANORM  USED IN HARWELL SPARSE CODE
122C     LP         INTEGER      USED IN HARWELL LA05*() PACK AS OUTPUT
123C                             FILE NUMBER. SET=I1MACH(4) NOW.
124C     UU         DOUBLE       0.1--USED IN HARWELL SPARSE CODE
125C                             FOR RELATIVE PIVOTING TOLERANCE.
126C     GG         DOUBLE       OUTPUT INFO FLAG IN HARWELL SPARSE CODE
127C     IPLACE     INTEGER      INTEGER USED BY SPARSE MATRIX CODES
128C     IENTER     INTEGER      NEXT COLUMN TO ENTER BASIS
129C     NREDC      INTEGER      NO. OF FULL REDECOMPOSITIONS
130C     KPRINT     INTEGER      LEVEL OF OUTPUT, =0-3
131C     IDG        INTEGER      FORMAT AND PRECISION OF OUTPUT
132C     ITBRC      INTEGER      NO. OF ITERS. BETWEEN RECALCULATING
133C                             THE ERROR IN THE PRIMAL SOLUTION.
134C     NPP        INTEGER      NO. OF NEGATIVE REDUCED COSTS REQUIRED
135C                             IN PARTIAL PRICING
136C     JSTRT      INTEGER      STARTING PLACE FOR PARTIAL PRICING.
137C
138      LOGICAL COLSCP,SAVEDT,CONTIN,CSTSCP,UNBND,
139     *        FEAS,FINITE,FOUND,MINPRB,REDBAS,
140     *        SINGLR,SIZEUP,STPEDG,TRANS,USRBAS,ZEROLV,LOPT(08)
141      CHARACTER*8 XERN1, XERN2
142      EQUIVALENCE (CONTIN,LOPT(1)),(USRBAS,LOPT(2)),
143     *  (SIZEUP,LOPT(3)),(SAVEDT,LOPT(4)),(COLSCP,LOPT(5)),
144     *  (CSTSCP,LOPT(6)),(MINPRB,LOPT(7)),(STPEDG,LOPT(8)),
145     *  (IDG,INTOPT(1)),(IPAGEF,INTOPT(2)),(ISAVE,INTOPT(3)),
146     *  (MXITLP,INTOPT(4)),(KPRINT,INTOPT(5)),(ITBRC,INTOPT(6)),
147     *  (NPP,INTOPT(7)),(LPRG,INTOPT(8)),(EPS,ROPT(1)),(ASMALL,ROPT(2)),
148     *  (ABIG,ROPT(3)),(COSTSC,ROPT(4)),(TOLLS,ROPT(5)),(TUNE,ROPT(6)),
149     *   (TOLABS,ROPT(7))
150C
151C     COMMON BLOCK USED BY LA05 () PACKAGE..
152      COMMON /LA05DD/ SMALL,LP,LENL,LENU,NCP,LROW,LCOL
153      EXTERNAL DUSRMT
154C
155C     SET LP=0 SO NO ERROR MESSAGES WILL PRINT WITHIN LA05 () PACKAGE.
156C***FIRST EXECUTABLE STATEMENT  DPLPMN
157      LP=0
158C
159C     THE VALUES ZERO AND ONE.
160      ZERO=0.D0
161      ONE=1.D0
162      FACTOR=0.01D0
163      LPG=LMX-(NVARS+4)
164      IOPT=1
165      INFO=0
166      UNBND=.FALSE.
167      JSTRT=1
168C
169C     PROCESS USER OPTIONS IN PRGOPT(*).
170C     CHECK THAT ANY USER-GIVEN CHANGES ARE WELL-DEFINED.
171      CALL DPOPT(PRGOPT,MRELAS,NVARS,INFO,CSC,IBASIS,ROPT,INTOPT,LOPT)
172      IF (.NOT.(INFO.LT.0)) GO TO 20002
173      GO TO 30001
17420002 IF (.NOT.(CONTIN)) GO TO 20003
175      GO TO 30002
17620006 GO TO 20004
177C
178C     INITIALIZE SPARSE DATA MATRIX, AMAT(*) AND IMAT(*).
17920003 CALL DPINTM(MRELAS,NVARS,AMAT,IMAT,LMX,IPAGEF)
180C
181C     UPDATE MATRIX DATA AND CHECK BOUNDS FOR CONSISTENCY.
18220004 CALL DPLPUP(DUSRMT,MRELAS,NVARS,PRGOPT,DATTRV,
183     *     BL,BU,IND,INFO,AMAT,IMAT,SIZEUP,ASMALL,ABIG)
184      IF (.NOT.(INFO.LT.0)) GO TO 20007
185      GO TO 30001
186C
187C++  CODE FOR OUTPUT=YES IS ACTIVE
18820007 IF (.NOT.(KPRINT.GE.1)) GO TO 20008
189      GO TO 30003
19020011 CONTINUE
191C++  CODE FOR OUTPUT=NO IS INACTIVE
192C++  END
193C
194C     INITIALIZATION. SCALE DATA, NORMALIZE BOUNDS, FORM COLUMN
195C     CHECK SUMS, AND FORM INITIAL BASIS MATRIX.
19620008 CALL DPINIT(MRELAS,NVARS,COSTS,BL,BU,IND,PRIMAL,INFO,
197     * AMAT,CSC,COSTSC,COLNRM,XLAMDA,ANORM,RHS,RHSNRM,
198     * IBASIS,IBB,IMAT,LOPT)
199      IF (.NOT.(INFO.LT.0)) GO TO 20012
200      GO TO 30001
201C
20220012 NREDC=0
203      ASSIGN 20013 TO NPR004
204      GO TO 30004
20520013 IF (.NOT.(SINGLR)) GO TO 20014
206      NERR=23
207      CALL XERMSG ('SLATEC', 'DPLPMN',
208     +   'IN DSPLP,  A SINGULAR INITIAL BASIS WAS ENCOUNTERED.', NERR,
209     +   IOPT)
210      INFO=-NERR
211      GO TO 30001
21220014 ASSIGN 20018 TO NPR005
213      GO TO 30005
21420018 ASSIGN 20019 TO NPR006
215      GO TO 30006
21620019 ASSIGN 20020 TO NPR007
217      GO TO 30007
21820020 IF (.NOT.(USRBAS)) GO TO 20021
219      ASSIGN 20024 TO NPR008
220      GO TO 30008
22120024 IF (.NOT.(.NOT.FEAS)) GO TO 20025
222      NERR=24
223      CALL XERMSG ('SLATEC', 'DPLPMN',
224     +   'IN DSPLP, AN INFEASIBLE INITIAL BASIS WAS ENCOUNTERED.',
225     +   NERR, IOPT)
226      INFO=-NERR
227      GO TO 30001
22820025 CONTINUE
22920021 ITLP=0
230C
231C     LAMDA HAS BEEN SET TO A CONSTANT, PERFORM PENALTY METHOD.
232      ASSIGN 20029 TO NPR009
233      GO TO 30009
23420029 ASSIGN 20030 TO NPR010
235      GO TO 30010
23620030 ASSIGN 20031 TO NPR006
237      GO TO 30006
23820031 ASSIGN 20032 TO NPR008
239      GO TO 30008
24020032 IF (.NOT.(.NOT.FEAS)) GO TO 20033
241C
242C     SET LAMDA TO INFINITY BY SETTING COSTSC TO ZERO (SAVE THE VALUE OF
243C     COSTSC) AND PERFORM STANDARD PHASE-1.
244      IF(KPRINT.GE.2)CALL IVOUT(0,IDUM,'('' ENTER STANDARD PHASE-1'')',
245     *IDG)
246      SCOSTS=COSTSC
247      COSTSC=ZERO
248      ASSIGN 20036 TO NPR007
249      GO TO 30007
25020036 ASSIGN 20037 TO NPR009
251      GO TO 30009
25220037 ASSIGN 20038 TO NPR010
253      GO TO 30010
25420038 ASSIGN 20039 TO NPR006
255      GO TO 30006
25620039 ASSIGN 20040 TO NPR008
257      GO TO 30008
25820040 IF (.NOT.(FEAS)) GO TO 20041
259C
260C     SET LAMDA TO ZERO, COSTSC=SCOSTS, PERFORM STANDARD PHASE-2.
261      IF(KPRINT.GT.1)CALL IVOUT(0,IDUM,'('' ENTER STANDARD PHASE-2'')',
262     *IDG)
263      XLAMDA=ZERO
264      COSTSC=SCOSTS
265      ASSIGN 20044 TO NPR009
266      GO TO 30009
26720044 CONTINUE
26820041 GO TO 20034
269C     CHECK IF ANY BASIC VARIABLES ARE STILL CLASSIFIED AS
270C     INFEASIBLE.  IF ANY ARE, THEN THIS MAY NOT YET BE AN
271C     OPTIMAL POINT.  THEREFORE SET LAMDA TO ZERO AND TRY
272C     TO PERFORM MORE SIMPLEX STEPS.
27320033 I=1
274      N20046=MRELAS
275      GO TO 20047
27620046 I=I+1
27720047 IF ((N20046-I).LT.0) GO TO 20048
278      IF (PRIMAL(I+NVARS).NE.ZERO) GO TO 20045
279      GO TO 20046
28020048 GO TO 20035
28120045 XLAMDA=ZERO
282      ASSIGN 20050 TO NPR009
283      GO TO 30009
28420050 CONTINUE
28520034 CONTINUE
286C
28720035 ASSIGN 20051 TO NPR011
288      GO TO 30011
28920051 IF (.NOT.(FEAS.AND.(.NOT.UNBND))) GO TO 20052
290      INFO=1
291      GO TO 20053
29220052 IF (.NOT.((.NOT.FEAS).AND.(.NOT.UNBND))) GO TO 10001
293      NERR=1
294      CALL XERMSG ('SLATEC', 'DPLPMN',
295     +   'IN DSPLP, THE PROBLEM APPEARS TO BE INFEASIBLE', NERR, IOPT)
296      INFO=-NERR
297      GO TO 20053
29810001 IF (.NOT.(FEAS .AND. UNBND)) GO TO 10002
299      NERR=2
300      CALL XERMSG ('SLATEC', 'DPLPMN',
301     +   'IN DSPLP, THE PROBLEM APPEARS TO HAVE NO FINITE SOLUTION.',
302     +   NERR, IOPT)
303      INFO=-NERR
304      GO TO 20053
30510002 IF (.NOT.((.NOT.FEAS).AND.UNBND)) GO TO 10003
306      NERR=3
307      CALL XERMSG ('SLATEC', 'DPLPMN',
308     +   'IN DSPLP, THE PROBLEM APPEARS TO BE INFEASIBLE AND TO ' //
309     +   'HAVE NO FINITE SOLN.', NERR, IOPT)
310      INFO=-NERR
31110003 CONTINUE
31220053 CONTINUE
313C
314      IF (.NOT.(INFO.EQ.(-1) .OR. INFO.EQ.(-3))) GO TO 20055
315      SIZE=DASUM(NVARS,PRIMAL,1)*ANORM
316      SIZE=SIZE/DASUM(NVARS,CSC,1)
317      SIZE=SIZE+DASUM(MRELAS,PRIMAL(NVARS+1),1)
318      I=1
319      N20058=NVARS+MRELAS
320      GO TO 20059
32120058 I=I+1
32220059 IF ((N20058-I).LT.0) GO TO 20060
323      NX0066=IND(I)
324      IF (NX0066.LT.1.OR.NX0066.GT.4) GO TO 20066
325      GO TO (20062,20063,20064,20065), NX0066
32620062 IF (.NOT.(SIZE+ABS(PRIMAL(I)-BL(I))*FACTOR.EQ.SIZE)) GO TO 20068
327      GO TO 20058
32820068 IF (.NOT.(PRIMAL(I).GT.BL(I))) GO TO 10004
329      GO TO 20058
33010004 IND(I)=-4
331      GO TO 20067
33220063 IF (.NOT.(SIZE+ABS(PRIMAL(I)-BU(I))*FACTOR.EQ.SIZE)) GO TO 20071
333      GO TO 20058
33420071 IF (.NOT.(PRIMAL(I).LT.BU(I))) GO TO 10005
335      GO TO 20058
33610005 IND(I)=-4
337      GO TO 20067
33820064 IF (.NOT.(SIZE+ABS(PRIMAL(I)-BL(I))*FACTOR.EQ.SIZE)) GO TO 20074
339      GO TO 20058
34020074 IF (.NOT.(PRIMAL(I).LT.BL(I))) GO TO 10006
341      IND(I)=-4
342      GO TO 20075
34310006 IF (.NOT.(SIZE+ABS(PRIMAL(I)-BU(I))*FACTOR.EQ.SIZE)) GO TO 10007
344      GO TO 20058
34510007 IF (.NOT.(PRIMAL(I).GT.BU(I))) GO TO 10008
346      IND(I)=-4
347      GO TO 20075
34810008 GO TO 20058
34920075 GO TO 20067
35020065 GO TO 20058
35120066 CONTINUE
35220067 GO TO 20058
35320060 CONTINUE
35420055 CONTINUE
355C
356      IF (.NOT.(INFO.EQ.(-2) .OR. INFO.EQ.(-3))) GO TO 20077
357      J=1
358      N20080=NVARS
359      GO TO 20081
36020080 J=J+1
36120081 IF ((N20080-J).LT.0) GO TO 20082
362      IF (.NOT.(IBB(J).EQ.0)) GO TO 20084
363      NX0091=IND(J)
364      IF (NX0091.LT.1.OR.NX0091.GT.4) GO TO 20091
365      GO TO (20087,20088,20089,20090), NX0091
36620087 BU(J)=BL(J)
367      IND(J)=-3
368      GO TO 20092
36920088 BL(J)=BU(J)
370      IND(J)=-3
371      GO TO 20092
37220089 GO TO 20080
37320090 BL(J)=ZERO
374      BU(J)=ZERO
375      IND(J)=-3
37620091 CONTINUE
37720092 CONTINUE
37820084 GO TO 20080
37920082 CONTINUE
38020077 CONTINUE
381C++  CODE FOR OUTPUT=YES IS ACTIVE
382      IF (.NOT.(KPRINT.GE.1)) GO TO 20093
383      ASSIGN 20096 TO NPR012
384      GO TO 30012
38520096 CONTINUE
38620093 CONTINUE
387C++  CODE FOR OUTPUT=NO IS INACTIVE
388C++  END
389      GO TO 30001
390C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
391C     PROCEDURE (COMPUTE RIGHT HAND SIDE)
39230010 RHS(1)=ZERO
393      CALL DCOPY(MRELAS,RHS,0,RHS,1)
394      J=1
395      N20098=NVARS+MRELAS
396      GO TO 20099
39720098 J=J+1
39820099 IF ((N20098-J).LT.0) GO TO 20100
399      NX0106=IND(J)
400      IF (NX0106.LT.1.OR.NX0106.GT.4) GO TO 20106
401      GO TO (20102,20103,20104,20105), NX0106
40220102 SCALR=-BL(J)
403      GO TO 20107
40420103 SCALR=-BU(J)
405      GO TO 20107
40620104 SCALR=-BL(J)
407      GO TO 20107
40820105 SCALR=ZERO
40920106 CONTINUE
41020107 IF (.NOT.(SCALR.NE.ZERO)) GO TO 20108
411      IF (.NOT.(J.LE.NVARS)) GO TO 20111
412      I=0
41320114 CALL DPNNZR(I,AIJ,IPLACE,AMAT,IMAT,J)
414      IF (.NOT.(I.LE.0)) GO TO 20116
415      GO TO 20115
41620116 RHS(I)=RHS(I)+AIJ*SCALR
417      GO TO 20114
41820115 GO TO 20112
41920111 RHS(J-NVARS)=RHS(J-NVARS)-SCALR
42020112 CONTINUE
42120108 GO TO 20098
42220100 J=1
423      N20119=NVARS+MRELAS
424      GO TO 20120
42520119 J=J+1
42620120 IF ((N20119-J).LT.0) GO TO 20121
427      SCALR=ZERO
428      IF(IND(J).EQ.3.AND.MOD(IBB(J),2).EQ.0) SCALR=BU(J)-BL(J)
429      IF (.NOT.(SCALR.NE.ZERO)) GO TO 20123
430      IF (.NOT.(J.LE.NVARS)) GO TO 20126
431      I=0
43220129 CALL DPNNZR(I,AIJ,IPLACE,AMAT,IMAT,J)
433      IF (.NOT.(I.LE.0)) GO TO 20131
434      GO TO 20130
43520131 RHS(I)=RHS(I)-AIJ*SCALR
436      GO TO 20129
43720130 GO TO 20127
43820126 RHS(J-NVARS)=RHS(J-NVARS)+SCALR
43920127 CONTINUE
44020123 GO TO 20119
44120121 CONTINUE
442      GO TO NPR010, (20030,20038)
443C     PROCEDURE (PERFORM SIMPLEX STEPS)
44430009 ASSIGN 20134 TO NPR013
445      GO TO 30013
44620134 ASSIGN 20135 TO NPR014
447      GO TO 30014
44820135 IF (.NOT.(KPRINT.GT.2)) GO TO 20136
449      CALL DVOUT(MRELAS,DUALS,'('' BASIC (INTERNAL) DUAL SOLN.'')',IDG)
450      CALL DVOUT(NVARS+MRELAS,RZ,'('' REDUCED COSTS'')',IDG)
45120136 CONTINUE
45220139 ASSIGN 20141 TO NPR015
453      GO TO 30015
45420141 IF (.NOT.(.NOT. FOUND)) GO TO 20142
455      GO TO 30016
45620145 CONTINUE
45720142 IF (.NOT.(FOUND)) GO TO 20146
458      IF (KPRINT.GE.3) CALL DVOUT(MRELAS,WW,'('' SEARCH DIRECTION'')',
459     *IDG)
460      GO TO 30017
46120149 IF (.NOT.(FINITE)) GO TO 20150
462      GO TO 30018
46320153 ASSIGN 20154 TO NPR005
464      GO TO 30005
46520154 GO TO 20151
46620150 UNBND=.TRUE.
467      IBB(IBASIS(IENTER))=0
46820151 GO TO 20147
46920146 GO TO 20140
47020147 ITLP=ITLP+1
471      GO TO 30019
47220155 GO TO 20139
47320140 CONTINUE
474      GO TO NPR009, (20029,20037,20044,20050)
475C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
476C     PROCEDURE (RETRIEVE SAVED DATA FROM FILE ISAVE)
47730002 LPR=NVARS+4
478      REWIND ISAVE
479      READ(ISAVE) (AMAT(I),I=1,LPR),(IMAT(I),I=1,LPR)
480      KEY=2
481      IPAGE=1
482      GO TO 20157
48320156 IF (NP.LT.0) GO TO 20158
48420157 LPR1=LPR+1
485      READ(ISAVE) (AMAT(I),I=LPR1,LMX),(IMAT(I),I=LPR1,LMX)
486      CALL DPRWPG(KEY,IPAGE,LPG,AMAT,IMAT)
487      NP=IMAT(LMX-1)
488      IPAGE=IPAGE+1
489      GO TO 20156
49020158 NPARM=NVARS+MRELAS
491      READ(ISAVE) (IBASIS(I),I=1,NPARM)
492      REWIND ISAVE
493      GO TO 20006
494C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
495C     PROCEDURE (SAVE DATA ON FILE ISAVE)
496C
497C     SOME PAGES MAY NOT BE WRITTEN YET.
49830020 IF (.NOT.(AMAT(LMX).EQ.ONE)) GO TO 20159
499      AMAT(LMX)=ZERO
500      KEY=2
501      IPAGE=ABS(IMAT(LMX-1))
502      CALL DPRWPG(KEY,IPAGE,LPG,AMAT,IMAT)
503C
504C     FORCE PAGE FILE TO BE OPENED ON RESTARTS.
50520159 KEY=AMAT(4)
506      AMAT(4)=ZERO
507      LPR=NVARS+4
508      WRITE(ISAVE) (AMAT(I),I=1,LPR),(IMAT(I),I=1,LPR)
509      AMAT(4)=KEY
510      IPAGE=1
511      KEY=1
512      GO TO 20163
51320162 IF (NP.LT.0) GO TO 20164
51420163 CALL DPRWPG(KEY,IPAGE,LPG,AMAT,IMAT)
515      LPR1=LPR+1
516      WRITE(ISAVE) (AMAT(I),I=LPR1,LMX),(IMAT(I),I=LPR1,LMX)
517      NP=IMAT(LMX-1)
518      IPAGE=IPAGE+1
519      GO TO 20162
52020164 NPARM=NVARS+MRELAS
521      WRITE(ISAVE) (IBASIS(I),I=1,NPARM)
522      ENDFILE ISAVE
523C
524C     CLOSE FILE, IPAGEF, WHERE PAGES ARE STORED. THIS IS NEEDED SO THAT
525C     THE PAGES MAY BE RESTORED AT A CONTINUATION OF DSPLP().
526      GO TO 20317
527C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
528C     PROCEDURE (DECOMPOSE BASIS MATRIX)
529C++  CODE FOR OUTPUT=YES IS ACTIVE
53030004 IF (.NOT.(KPRINT.GE.2)) GO TO 20165
531      CALL IVOUT(MRELAS,IBASIS,
532     *'('' SUBSCRIPTS OF BASIC VARIABLES DURING REDECOMPOSITION'')',
533     *IDG)
534C++  CODE FOR OUTPUT=NO IS INACTIVE
535C++  END
536C
537C     SET RELATIVE PIVOTING FACTOR FOR USE IN LA05 () PACKAGE.
53820165 UU=0.1
539      CALL DPLPDM(
540     *MRELAS,NVARS,LMX,LBM,NREDC,INFO,IOPT,
541     *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB,
542     *ANORM,EPS,UU,GG,
543     *AMAT,BASMAT,CSC,WR,
544     *SINGLR,REDBAS)
545      IF (.NOT.(INFO.LT.0)) GO TO 20168
546      GO TO 30001
54720168 CONTINUE
548      GO TO NPR004, (20013,20204,20242)
549C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
550C     PROCEDURE (CLASSIFY VARIABLES)
551C
552C     DEFINE THE CLASSIFICATION OF THE BASIC VARIABLES
553C     -1 VIOLATES LOWER BOUND, 0 FEASIBLE, +1 VIOLATES UPPER BOUND.
554C     (THIS INFO IS STORED IN PRIMAL(NVARS+1)-PRIMAL(NVARS+MRELAS))
555C     TRANSLATE VARIABLE TO ITS UPPER BOUND, IF .GT. UPPER BOUND
55630007 PRIMAL(NVARS+1)=ZERO
557      CALL DCOPY(MRELAS,PRIMAL(NVARS+1),0,PRIMAL(NVARS+1),1)
558      I=1
559      N20172=MRELAS
560      GO TO 20173
56120172 I=I+1
56220173 IF ((N20172-I).LT.0) GO TO 20174
563      J=IBASIS(I)
564      IF (.NOT.(IND(J).NE.4)) GO TO 20176
565      IF (.NOT.(RPRIM(I).LT.ZERO)) GO TO 20179
566      PRIMAL(I+NVARS)=-ONE
567      GO TO 20180
56820179 IF (.NOT.(IND(J).EQ.3)) GO TO 10009
569      UPBND=BU(J)-BL(J)
570      IF (J.LE.NVARS) UPBND=UPBND/CSC(J)
571      IF (.NOT.(RPRIM(I).GT.UPBND)) GO TO 20182
572      RPRIM(I)=RPRIM(I)-UPBND
573      IF (.NOT.(J.LE.NVARS)) GO TO 20185
574      K=0
57520188 CALL DPNNZR(K,AIJ,IPLACE,AMAT,IMAT,J)
576      IF (.NOT.(K.LE.0)) GO TO 20190
577      GO TO 20189
57820190 RHS(K)=RHS(K)-UPBND*AIJ*CSC(J)
579      GO TO 20188
58020189 GO TO 20186
58120185 RHS(J-NVARS)=RHS(J-NVARS)+UPBND
58220186 PRIMAL(I+NVARS)=ONE
58320182 CONTINUE
584      CONTINUE
58510009 CONTINUE
58620180 CONTINUE
58720176 GO TO 20172
58820174 CONTINUE
589      GO TO NPR007, (20020,20036)
590C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
591C     PROCEDURE (COMPUTE ERROR IN DUAL AND PRIMAL SYSTEMS)
59230005 NTRIES=1
593      GO TO 20195
59420194 NTRIES=NTRIES+1
59520195 IF ((2-NTRIES).LT.0) GO TO 20196
596      CALL DPLPCE(
597     *MRELAS,NVARS,LMX,LBM,ITLP,ITBRC,
598     *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB,
599     *ERDNRM,EPS,TUNE,GG,
600     *AMAT,BASMAT,CSC,WR,WW,PRIMAL,ERD,ERP,
601     *SINGLR,REDBAS)
602      IF (.NOT.(.NOT. SINGLR)) GO TO 20198
603C++  CODE FOR OUTPUT=YES IS ACTIVE
604      IF (.NOT.(KPRINT.GE.3)) GO TO 20201
605      CALL DVOUT(MRELAS,ERP,'('' EST. ERROR IN PRIMAL COMPS.'')',IDG)
606      CALL DVOUT(MRELAS,ERD,'('' EST. ERROR IN DUAL COMPS.'')',IDG)
60720201 CONTINUE
608C++  CODE FOR OUTPUT=NO IS INACTIVE
609C++  END
610      GO TO 20193
61120198 IF (NTRIES.EQ.2) GO TO 20197
612      ASSIGN 20204 TO NPR004
613      GO TO 30004
61420204 CONTINUE
615      GO TO 20194
61620196 CONTINUE
61720197 NERR=26
618      CALL XERMSG ('SLATEC', 'DPLPMN',
619     +   'IN DSPLP, MOVED TO A SINGULAR POINT. THIS SHOULD NOT HAPPEN.',
620     +   NERR, IOPT)
621      INFO=-NERR
622      GO TO 30001
62320193 CONTINUE
624      GO TO NPR005, (20018,20154,20243)
625C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
626C     PROCEDURE (CHECK FEASIBILITY)
627C
628C     SEE IF NEARBY FEASIBLE POINT SATISFIES THE CONSTRAINT
629C     EQUATIONS.
630C
631C     COPY RHS INTO WW(*), THEN UPDATE WW(*).
63230008 CALL DCOPY(MRELAS,RHS,1,WW,1)
633      J=1
634      N20206=MRELAS
635      GO TO 20207
63620206 J=J+1
63720207 IF ((N20206-J).LT.0) GO TO 20208
638      IBAS=IBASIS(J)
639      XVAL=RPRIM(J)
640C
641C     ALL VARIABLES BOUNDED BELOW HAVE ZERO AS THAT BOUND.
642      IF (IND(IBAS).LE.3) XVAL=MAX(ZERO,XVAL)
643C
644C     IF THE VARIABLE HAS AN UPPER BOUND, COMPUTE THAT BOUND.
645      IF (.NOT.(IND(IBAS).EQ.3)) GO TO 20210
646      UPBND=BU(IBAS)-BL(IBAS)
647      IF (IBAS.LE.NVARS) UPBND=UPBND/CSC(IBAS)
648      XVAL=MIN(UPBND,XVAL)
64920210 CONTINUE
650C
651C     SUBTRACT XVAL TIMES COLUMN VECTOR FROM RIGHT-HAND SIDE IN WW(*)
652      IF (.NOT.(XVAL.NE.ZERO)) GO TO 20213
653      IF (.NOT.(IBAS.LE.NVARS)) GO TO 20216
654      I=0
65520219 CALL DPNNZR(I,AIJ,IPLACE,AMAT,IMAT,IBAS)
656      IF (.NOT.(I.LE.0)) GO TO 20221
657      GO TO 20220
65820221 WW(I)=WW(I)-XVAL*AIJ*CSC(IBAS)
659      GO TO 20219
66020220 GO TO 20217
66120216 IF (.NOT.(IND(IBAS).EQ.2)) GO TO 20224
662      WW(IBAS-NVARS)=WW(IBAS-NVARS)-XVAL
663      GO TO 20225
66420224 WW(IBAS-NVARS)=WW(IBAS-NVARS)+XVAL
66520225 CONTINUE
666      CONTINUE
66720217 CONTINUE
66820213 CONTINUE
669      GO TO 20206
670C
671C   COMPUTE NORM OF DIFFERENCE AND CHECK FOR FEASIBILITY.
67220208 RESNRM=DASUM(MRELAS,WW,1)
673      FEAS=RESNRM.LE.TOLLS*(RPRNRM*ANORM+RHSNRM)
674C
675C     TRY AN ABSOLUTE ERROR TEST IF THE RELATIVE TEST FAILS.
676      IF(.NOT. FEAS)FEAS=RESNRM.LE.TOLABS
677      IF (.NOT.(FEAS)) GO TO 20227
678      PRIMAL(NVARS+1)=ZERO
679      CALL DCOPY(MRELAS,PRIMAL(NVARS+1),0,PRIMAL(NVARS+1),1)
68020227 CONTINUE
681      GO TO NPR008, (20024,20032,20040)
682C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
683C     PROCEDURE (INITIALIZE REDUCED COSTS AND STEEPEST EDGE WEIGHTS)
68430014 CALL DPINCW(
685     *MRELAS,NVARS,LMX,LBM,NPP,JSTRT,
686     *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB,
687     *COSTSC,GG,ERDNRM,DULNRM,
688     *AMAT,BASMAT,CSC,WR,WW,RZ,RG,COSTS,COLNRM,DUALS,
689     *STPEDG)
690C
691      GO TO NPR014, (20135,20246)
692C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
693C     PROCEDURE (CHECK AND RETURN WITH EXCESS ITERATIONS)
69430019 IF (.NOT.(ITLP.GT.MXITLP)) GO TO 20230
695      NERR=25
696      ASSIGN 20233 TO NPR011
697      GO TO 30011
698C++  CODE FOR OUTPUT=YES IS ACTIVE
69920233 IF (.NOT.(KPRINT.GE.1)) GO TO 20234
700      ASSIGN 20237 TO NPR012
701      GO TO 30012
70220237 CONTINUE
70320234 CONTINUE
704C++  CODE FOR OUTPUT=NO IS INACTIVE
705C++  END
706      IDUM(1)=0
707      IF(SAVEDT) IDUM(1)=ISAVE
708      WRITE (XERN1, '(I8)') MXITLP
709      WRITE (XERN2, '(I8)') IDUM(1)
710      CALL XERMSG ('SLATEC', 'DPLPMN',
711     *   'IN DSPLP, MAX ITERATIONS = ' // XERN1 //
712     *   ' TAKEN.  UP-TO-DATE RESULTS SAVED ON FILE NO. ' // XERN2 //
713     *   '.   IF FILE NO. = 0, NO SAVE.', NERR, IOPT)
714      INFO=-NERR
715      GO TO 30001
71620230 CONTINUE
717      GO TO 20155
718C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
719C     PROCEDURE (REDECOMPOSE BASIS MATRIX AND TRY AGAIN)
72030016 IF (.NOT.(.NOT.REDBAS)) GO TO 20239
721      ASSIGN 20242 TO NPR004
722      GO TO 30004
72320242 ASSIGN 20243 TO NPR005
724      GO TO 30005
72520243 ASSIGN 20244 TO NPR006
726      GO TO 30006
72720244 ASSIGN 20245 TO NPR013
728      GO TO 30013
72920245 ASSIGN 20246 TO NPR014
730      GO TO 30014
73120246 CONTINUE
732C
733C     ERASE NON-CYCLING MARKERS NEAR COMPLETION.
73420239 I=MRELAS+1
735      N20247=MRELAS+NVARS
736      GO TO 20248
73720247 I=I+1
73820248 IF ((N20247-I).LT.0) GO TO 20249
739      IBASIS(I)=ABS(IBASIS(I))
740      GO TO 20247
74120249 ASSIGN 20251 TO NPR015
742      GO TO 30015
74320251 CONTINUE
744      GO TO 20145
745C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
746C     PROCEDURE (COMPUTE NEW PRIMAL)
747C
748C     COPY RHS INTO WW(*), SOLVE SYSTEM.
74930006 CALL DCOPY(MRELAS,RHS,1,WW,1)
750      TRANS = .FALSE.
751      CALL LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS)
752      CALL DCOPY(MRELAS,WW,1,RPRIM,1)
753      RPRNRM=DASUM(MRELAS,RPRIM,1)
754      GO TO NPR006, (20019,20031,20039,20244,20275)
755C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
756C     PROCEDURE (COMPUTE NEW DUALS)
757C
758C     SOLVE FOR DUAL VARIABLES. FIRST COPY COSTS INTO DUALS(*).
75930013 I=1
760      N20252=MRELAS
761      GO TO 20253
76220252 I=I+1
76320253 IF ((N20252-I).LT.0) GO TO 20254
764      J=IBASIS(I)
765      IF (.NOT.(J.LE.NVARS)) GO TO 20256
766      DUALS(I)=COSTSC*COSTS(J)*CSC(J) + XLAMDA*PRIMAL(I+NVARS)
767      GO TO 20257
76820256 DUALS(I)=XLAMDA*PRIMAL(I+NVARS)
76920257 CONTINUE
770      GO TO 20252
771C
77220254 TRANS=.TRUE.
773      CALL LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,DUALS,TRANS)
774      DULNRM=DASUM(MRELAS,DUALS,1)
775      GO TO NPR013, (20134,20245,20267)
776C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
777C     PROCEDURE (FIND VARIABLE TO ENTER BASIS AND GET SEARCH DIRECTION)
77830015 CALL DPLPFE(
779     *MRELAS,NVARS,LMX,LBM,IENTER,
780     *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB,
781     *ERDNRM,EPS,GG,DULNRM,DIRNRM,
782     *AMAT,BASMAT,CSC,WR,WW,BL,BU,RZ,RG,COLNRM,DUALS,
783     *FOUND)
784      GO TO NPR015, (20141,20251)
785C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
786C     PROCEDURE (CHOOSE VARIABLE TO LEAVE BASIS)
78730017 CALL DPLPFL(
788     *MRELAS,NVARS,IENTER,ILEAVE,
789     *IBASIS,IND,IBB,
790     *THETA,DIRNRM,RPRNRM,
791     *CSC,WW,BL,BU,ERP,RPRIM,PRIMAL,
792     *FINITE,ZEROLV)
793      GO TO 20149
794C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
795C     PROCEDURE (MAKE MOVE AND UPDATE)
79630018 CALL DPLPMU(
797     *MRELAS,NVARS,LMX,LBM,NREDC,INFO,IENTER,ILEAVE,IOPT,NPP,JSTRT,
798     *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB,
799     *ANORM,EPS,UU,GG,RPRNRM,ERDNRM,DULNRM,THETA,COSTSC,XLAMDA,RHSNRM,
800     *AMAT,BASMAT,CSC,WR,RPRIM,WW,BU,BL,RHS,ERD,ERP,RZ,RG,COLNRM,COSTS,
801     *PRIMAL,DUALS,SINGLR,REDBAS,ZEROLV,STPEDG)
802      IF (.NOT.(INFO.EQ.(-26))) GO TO 20259
803      GO TO 30001
804C++  CODE FOR OUTPUT=YES IS ACTIVE
80520259 IF (.NOT.(KPRINT.GE.2)) GO TO 20263
806      GO TO 30021
80720266 CONTINUE
808C++  CODE FOR OUTPUT=NO IS INACTIVE
809C++  END
81020263 CONTINUE
811      GO TO 20153
812C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
813C     PROCEDURE(RESCALE AND REARRANGE VARIABLES)
814C
815C     RESCALE THE DUAL VARIABLES.
81630011 ASSIGN 20267 TO NPR013
817      GO TO 30013
81820267 IF (.NOT.(COSTSC.NE.ZERO)) GO TO 20268
819      I=1
820      N20271=MRELAS
821      GO TO 20272
82220271 I=I+1
82320272 IF ((N20271-I).LT.0) GO TO 20273
824      DUALS(I)=DUALS(I)/COSTSC
825      GO TO 20271
82620273 CONTINUE
82720268 ASSIGN 20275 TO NPR006
828      GO TO 30006
829C
830C     REAPPLY COLUMN SCALING TO PRIMAL.
83120275 I=1
832      N20276=MRELAS
833      GO TO 20277
83420276 I=I+1
83520277 IF ((N20276-I).LT.0) GO TO 20278
836      J=IBASIS(I)
837      IF (.NOT.(J.LE.NVARS)) GO TO 20280
838      SCALR=CSC(J)
839      IF(IND(J).EQ.2)SCALR=-SCALR
840      RPRIM(I)=RPRIM(I)*SCALR
84120280 GO TO 20276
842C
843C     REPLACE TRANSLATED BASIC VARIABLES INTO ARRAY PRIMAL(*)
84420278 PRIMAL(1)=ZERO
845      CALL DCOPY(NVARS+MRELAS,PRIMAL,0,PRIMAL,1)
846      J=1
847      N20283=NVARS+MRELAS
848      GO TO 20284
84920283 J=J+1
85020284 IF ((N20283-J).LT.0) GO TO 20285
851      IBAS=ABS(IBASIS(J))
852      XVAL=ZERO
853      IF (J.LE.MRELAS) XVAL=RPRIM(J)
854      IF (IND(IBAS).EQ.1) XVAL=XVAL+BL(IBAS)
855      IF (IND(IBAS).EQ.2) XVAL=BU(IBAS)-XVAL
856      IF (.NOT.(IND(IBAS).EQ.3)) GO TO 20287
857      IF (MOD(IBB(IBAS),2).EQ.0) XVAL=BU(IBAS)-BL(IBAS)-XVAL
858      XVAL = XVAL+BL(IBAS)
85920287 PRIMAL(IBAS)=XVAL
860      GO TO 20283
861C
862C     COMPUTE DUALS FOR INDEPENDENT VARIABLES WITH BOUNDS.
863C     OTHER ENTRIES ARE ZERO.
86420285 J=1
865      N20290=NVARS
866      GO TO 20291
86720290 J=J+1
86820291 IF ((N20290-J).LT.0) GO TO 20292
869      RZJ=ZERO
870      IF (.NOT.(IBB(J).GT.ZERO .AND. IND(J).NE.4)) GO TO 20294
871      RZJ=COSTS(J)
872      I=0
87320297 CALL DPNNZR(I,AIJ,IPLACE,AMAT,IMAT,J)
874      IF (.NOT.(I.LE.0)) GO TO 20299
875      GO TO 20298
87620299 CONTINUE
877      RZJ=RZJ-AIJ*DUALS(I)
878      GO TO 20297
87920298 CONTINUE
88020294 DUALS(MRELAS+J)=RZJ
881      GO TO 20290
88220292 CONTINUE
883      GO TO NPR011, (20051,20233)
884C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
885C++  CODE FOR OUTPUT=YES IS ACTIVE
886C     PROCEDURE (PRINT PROLOGUE)
88730003 IDUM(1)=MRELAS
888      CALL IVOUT(1,IDUM,'(''1NUM. OF DEPENDENT VARS., MRELAS'')',IDG)
889      IDUM(1)=NVARS
890      CALL IVOUT(1,IDUM,'('' NUM. OF INDEPENDENT VARS., NVARS'')',IDG)
891      CALL IVOUT(1,IDUM,'('' DIMENSION OF COSTS(*)='')',IDG)
892      IDUM(1)=NVARS+MRELAS
893      CALL IVOUT(1,IDUM, '('' DIMENSIONS OF BL(*),BU(*),IND(*)''
894     */'' PRIMAL(*),DUALS(*) ='')',IDG)
895      CALL IVOUT(1,IDUM,'('' DIMENSION OF IBASIS(*)='')',IDG)
896      IDUM(1)=LPRG+1
897      CALL IVOUT(1,IDUM,'('' DIMENSION OF PRGOPT(*)='')',IDG)
898      CALL IVOUT(0,IDUM,
899     * '('' 1-NVARS=INDEPENDENT VARIABLE INDICES.''/
900     * '' (NVARS+1)-(NVARS+MRELAS)=DEPENDENT VARIABLE INDICES.''/
901     * '' CONSTRAINT INDICATORS ARE 1-4 AND MEAN'')',IDG)
902      CALL IVOUT(0,IDUM,
903     * '('' 1=VARIABLE HAS ONLY LOWER BOUND.''/
904     * '' 2=VARIABLE HAS ONLY UPPER BOUND.''/
905     * '' 3=VARIABLE HAS BOTH BOUNDS.''/
906     * '' 4=VARIABLE HAS NO BOUNDS, IT IS FREE.'')',IDG)
907      CALL DVOUT(NVARS,COSTS,'('' ARRAY OF COSTS'')',IDG)
908      CALL IVOUT(NVARS+MRELAS,IND,
909     * '('' CONSTRAINT INDICATORS'')',IDG)
910      CALL DVOUT(NVARS+MRELAS,BL,
911     *'('' LOWER BOUNDS FOR VARIABLES  (IGNORE UNUSED ENTRIES.)'')',IDG)
912      CALL DVOUT(NVARS+MRELAS,BU,
913     *'('' UPPER BOUNDS FOR VARIABLES  (IGNORE UNUSED ENTRIES.)'')',IDG)
914      IF (.NOT.(KPRINT.GE.2)) GO TO 20302
915      CALL IVOUT(0,IDUM,
916     * '(''0NON-BASIC INDICES THAT ARE NEGATIVE SHOW VARIABLES''
917     * '' EXCHANGED AT A ZERO''/'' STEP LENGTH'')',IDG)
918      CALL IVOUT(0,IDUM,
919     * '('' WHEN COL. NO. LEAVING=COL. NO. ENTERING, THE ENTERING ''
920     * ''VARIABLE MOVED''/'' TO ITS BOUND.  IT REMAINS NON-BASIC.''/
921     * '' WHEN COL. NO. OF BASIS EXCHANGED IS NEGATIVE, THE LEAVING''/
922     * '' VARIABLE IS AT ITS UPPER BOUND.'')',IDG)
92320302 CONTINUE
924      GO TO 20011
925C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
926C     PROCEDURE (PRINT SUMMARY)
92730012 IDUM(1)=INFO
928      CALL IVOUT(1,IDUM,'('' THE OUTPUT VALUE OF INFO IS'')',IDG)
929      IF (.NOT.(MINPRB)) GO TO 20305
930      CALL IVOUT(0,IDUM,'('' THIS IS A MINIMIZATION PROBLEM.'')',IDG)
931      GO TO 20306
93220305 CALL IVOUT(0,IDUM,'('' THIS IS A MAXIMIZATION PROBLEM.'')',IDG)
93320306 IF (.NOT.(STPEDG)) GO TO 20308
934      CALL IVOUT(0,IDUM,'('' STEEPEST EDGE PRICING WAS USED.'')',IDG)
935      GO TO 20309
93620308 CALL IVOUT(0,IDUM,'('' MINIMUM REDUCED COST PRICING WAS USED.'')',
937     * IDG)
93820309 RDUM(1)=DDOT(NVARS,COSTS,1,PRIMAL,1)
939      CALL DVOUT(1,RDUM,
940     * '('' OUTPUT VALUE OF THE OBJECTIVE FUNCTION'')',IDG)
941      CALL DVOUT(NVARS+MRELAS,PRIMAL,
942     * '('' THE OUTPUT INDEPENDENT AND DEPENDENT VARIABLES'')',IDG)
943      CALL DVOUT(MRELAS+NVARS,DUALS,
944     * '('' THE OUTPUT DUAL VARIABLES'')',IDG)
945      CALL IVOUT(NVARS+MRELAS,IBASIS,
946     * '('' VARIABLE INDICES IN POSITIONS 1-MRELAS ARE BASIC.'')',IDG)
947      IDUM(1)=ITLP
948      CALL IVOUT(1,IDUM,'('' NO. OF ITERATIONS'')',IDG)
949      IDUM(1)=NREDC
950      CALL IVOUT(1,IDUM,'('' NO. OF FULL REDECOMPS'')',IDG)
951      GO TO NPR012, (20096,20237)
952C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
953C     PROCEDURE (PRINT ITERATION SUMMARY)
95430021 IDUM(1)=ITLP+1
955      CALL IVOUT(1,IDUM,'(''0ITERATION NUMBER'')',IDG)
956      IDUM(1)=IBASIS(ABS(ILEAVE))
957      CALL IVOUT(1,IDUM,
958     * '('' INDEX OF VARIABLE ENTERING THE BASIS'')',IDG)
959      IDUM(1)=ILEAVE
960      CALL IVOUT(1,IDUM,'('' COLUMN OF THE BASIS EXCHANGED'')',IDG)
961      IDUM(1)=IBASIS(IENTER)
962      CALL IVOUT(1,IDUM,
963     * '('' INDEX OF VARIABLE LEAVING THE BASIS'')',IDG)
964      RDUM(1)=THETA
965      CALL DVOUT(1,RDUM,'('' LENGTH OF THE EXCHANGE STEP'')',IDG)
966      IF (.NOT.(KPRINT.GE.3)) GO TO 20311
967      CALL DVOUT(MRELAS,RPRIM,'('' BASIC (INTERNAL) PRIMAL SOLN.'')',
968     * IDG)
969      CALL IVOUT(NVARS+MRELAS,IBASIS,
970     * '('' VARIABLE INDICES IN POSITIONS 1-MRELAS ARE BASIC.'')',IDG)
971      CALL IVOUT(NVARS+MRELAS,IBB,'('' IBB ARRAY'')',IDG)
972      CALL DVOUT(MRELAS,RHS,'('' TRANSLATED RHS'')',IDG)
973      CALL DVOUT(MRELAS,DUALS,'('' BASIC (INTERNAL) DUAL SOLN.'')',IDG)
97420311 CONTINUE
975      GO TO 20266
976C++  CODE FOR OUTPUT=NO IS INACTIVE
977C++  END
978C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
979C     PROCEDURE (RETURN TO USER)
98030001 IF (.NOT.(SAVEDT)) GO TO 20314
981      GO TO 30020
98220317 CONTINUE
98320314 IF(IMAT(LMX-1).NE.(-1)) CALL SCLOSM(IPAGEF)
984C
985C     THIS TEST IS THERE ONLY TO AVOID DIAGNOSTICS ON SOME FORTRAN
986C     COMPILERS.
987      RETURN
988      END
989