PDP-10 Archive: 43,50466/sg1rvs.for from decuslib10-09

Trailing-Edge - PDP-10 Archives - decuslib10-09 - 43,50466/sg1rvs.for
There are 2 other files named sg1rvs.for in the archive. Click here to see a list.
C	WESTERN MICHIGAN UNIVERSITY
C	SG1RVS.FOR (FILENAME ON LIBRARY DECTAPE)
C	CALLED BY SUBR. MAIN2 IN RVSLPR.FOR
C	ABOVE COMMENTS AND RIGHT ADJUSTED COMMENTS PUT IN BY WG
C	COMMON /IOB/, /IOD/, /NONDYN/ ARE SHARED BY MAIN PROG.,
C	  SUBR. MAIN1, MAIN2, AND SEGMT2
C	BINIT, ISLACK, AMAT, IBASIS, ITEST, CWOBJ, NART ORIGBA
C	 ARE INPUT.  OTHER ARGS. ARE RETURNED FOR SUBR. SEGMT2.
C	LSTOP RETURNED BY SEGMT1 THRU COMMON /NONDYN/
	SUBROUTINE SEGMT1(BINIT,ISLACK,AMAT,IBASIS,SHADPR,WSHAD,COBJ,
	1ITEST,CWOBJ,NART,RELCOS,BCONST,PRINV,JPRINV,
	2PIVCOL,BSTAR,IMIN,NBASIS,NONBA,DCOS,ORIGBA)
	COMMON/NONDYN/NR,NC,NR2,NCFIN,JTYPE,TABLO,ICOND,ISWST
	1,FIRST1,FIRST2,ITERRI,FLAG1,FLAG2,LSTOP,FLAG,
	2TOL1,TOL2,TOL3,TOL4,TOL5,TOL6,TOL7,TOL8,IPHASE,
	3TOL9,TOL10,TOL11,GREAT,NEQUAL,ITERR
	COMMON/IOD/NDEVO,DEVNAM,IDVO,IFLNMO,IPJ,IPG,IBNK,
	1NDEVI,IDVI,IFLNMI
	COMMON/IOB/LEFBK,IRTBK,IART,MAXPAG,IPAGE,IPAGCT,IDLG
	1,IRSP,ICODE,JDUMMY
	DOUBLE PRECISION LABEL1,LABEL2,NBASIS
	DIMENSION AMAT(1),BINIT(1),IBASIS(1),SHADPR(1),WSHAD(1),
	1COBJ(1),ITEST(1),ISLACK(1),CWOBJ(1),NART(1),RELCOS(1)
	2,BCONST(1),PRINV(1),JPRINV(1),PIVCOL(1),BSTAR(1),
	3IMIN(1),NBASIS(1),NONBA(1),DCOS(1),ORIGBA(1)
1	NCOL=5
	ITER=0
	ITERRI=0
2	GREAT=1.7E+38
	LSTOP=0
C---------------ISWST=1 MEANS POST SOL OPTIONS BVALU AND/OR INEQ
C--------------- AND/OR OBJ. WERE CHOSEN.  ISWST = 0 MEANS WE ARE
C--------------- IN PRE SOLUTION STAGE.
	IF(ISWST.EQ.1)GO TO 20
	IF(ICOND.EQ.0)GO TO 20
C---------------ICOND=1 MEANS MAX, =0 MEANS MIN.
C---------------IF OBJ. FUNCTION IS TO BE MAX., CHANGE TO NEG.,
C--------------- AS PROG. SOLVES FOR MIN.
	DO 10 J=1,NC
	COBJ(J)=-COBJ(J)
10	CONTINUE
20	DO 5007 I=NC+1,NCFIN
5007	COBJ(I)=0
	DO 30 I=1,NR
	IMIN(I)=0
	BSTAR(I)=0
	PIVCOL(I)=0
	WSHAD(I)=0
	SHADPR(I)=0
30	CONTINUE
	DO 40 J=1,NCFIN
	DCOS(J)=0
	NONBA(J)=0
	RELCOS(J)=0
40	CONTINUE
	ZOBJ=0
	WOBJ=0
	WZ=0
85	IF(IPHASE.LT.NR)GO TO 90
	NPHASE=2
	DO 80 J=1,NC
	RELCOS(J)=COBJ(J)
80	CONTINUE
	GO TO 130
90	NPHASE=1
	DO 100 J=1,NCFIN
C---------------ONES (1) AND ZEROS WERE PUT INTO CWOBJ IN SUBR. MAIN 2.
C--------------- SEE ST. 107+2 AND ST. 260+6 IN SUBR. MAIN 2.
	RELCOS(J)=CWOBJ(J)
100	CONTINUE
C---------------IN PHASE 1 SUBTRACT ALL ROWS CORRSP. TO ART. VARS.
C--------------- FROM THE RELCOST COEFFS.
	DO 120 I=1,NR
	IF(NART(I).EQ.0)GO TO 120
	DO 110 J=1,NCFIN
	IJ=(I-1)*NCFIN+J
	RELCOS(J)=RELCOS(J)-AMAT(IJ)
110	CONTINUE
120	CONTINUE
130	ITER=0
	DO 170 I=1,NR
	SHADPR(I)=0
	BCONST(I)=BINIT(I)
	JPRINV(I)=0
C---------------FORM THE IDENTITY MATRIX IN THE LOCATIONS WHERE
C--------------- AT THE END OF PHASE II THERE WILL BE INVERSE OF 
C--------------- BASIS MATRIX.
	DO 150 J=1,NR
	IJ=(I-1)*NR+J
	IF(J.EQ.I)GO TO 140
	PRINV(IJ)=0
	GO TO 150
140	PRINV(IJ)=1.0
150	CONTINUE
	IF(NART(I).EQ.0)GO TO 160
C---------------SEE "INTRO TO LIN PROG" BY W.W. GARVIN
C--------------- PP. 198-202.  WSHAD=-1 WITH ST. 240+1 IS EQUIV.
C--------------- TO ST. 110-1
	WSHAD(I)=-1.0
C---------------CALC. INITIAL VALUE OF OBJ. FUNCTION (INF. FORM)
C--------------- FOR PHASE 1.
	WZ=WZ-BCONST(I)
	GO TO 170
160	WSHAD(I)=0
170	CONTINUE
	ZOBJ=0
	ZZ=0
	WOBJ=-WZ
C---------------ITERR=-1 MEANS USER CHOSE INOUT OPTION
	IF(ITERR.NE.-1)GO TO 175
	IF(NPHASE.NE.1)GO TO 179
	IF(FIRST1.NE.1)GO TO 175
	WRITE(NDEVO,177)
177	FORMAT(1X,50(1H-),/9X,1HI,18X,1HI,14X,1HI/
	11X,'ITER.NO.',1HI,' VALUE OF FUNCTION',1HI
	2' VARIABLE OUT ',1HI,' VAR. IN',/9X,1HI,18X,1HI,14X,
	31HI/1X,8(1H-),1H+,18(1H-),1H+,14(1H-),1H+,7(1H-),/)
	ZZOBJ=WOBJ
	IF(ICOND.EQ.1)ZZOBJ=-WOBJ
	WRITE(NDEVO,181)ZZOBJ
181	FORMAT(1X,/1X,'PHASE 1',4X,G15.8/)
C---------------FIRST1 INITIALIZED TO 1 IN MAIN PROG. NOW FIRST1=2
C--------------- MEANS WE WILL BYPASS PRINTING OF HEADER JUST ABOVE
	FIRST1=2
	GO TO 175
179	IF(FIRST2.NE.1)GO TO 175
	ZZOBJ=ZOBJ
	IF(ICOND.EQ.1)ZZOBJ=-ZOBJ
	WRITE(NDEVO,182)
182	FORMAT(1X,/1X,'PHASE 2'/)
C---------------FIRST2=2 MEANS WE CAN BYPASS PRINTING "PHASE 2"
C--------------- JUST ABOVE
	FIRST2=2
C---------------ITER=NO. OF PIVOTS IN REV. SIMP. PROC.
175	IF(ITER.EQ.0)GO TO 255
176	CONTINUE
C---------------CALCULATE NEXT SET OF REL.COST COEFFS.
C--------------- THIS IS SKIPPED THE FIRST TIME. SEE ST. 175
C--------------- JUST ABOVE AND ST. 110-1.
190	DO 250 J=1,NCFIN
	IF(ITEST(J).EQ.1)GO TO 200
	RELCOS(J)=0
	GO TO 250
200	IF(NPHASE.EQ.1)GO TO 210
	RELCOS(J)=COBJ(J)
	GO TO 220
210	RELCOS(J)=CWOBJ(J)
220	DO 251 I=1,NR
	IF(NPHASE.EQ.1)GO TO 230
	PI=SHADPR(I)
	GO TO 240
230	PI=WSHAD(I)
240	IJ=(I-1)*NCFIN+J
	RELCOS(J)=RELCOS(J)+PI*AMAT(IJ)
242	IF(ABS(RELCOS(J)).LT.TOL11)RELCOS(J)=0
251	CONTINUE
250	CONTINUE
255	CONTINUE
260	SMALL=GREAT
270	NLAST=NCFIN
C---------------LOOK FOR SMALLEST PHASE 2 REL.COST COEFF. AMONG
C--------------- THOSE COLS. WHICH ARE NOT IN THE BASIS AND WHOSE
C--------------- PHASE 1 REL.COST COEFFS. IN ABS. VALUE ARE GREATER
C--------------- THAN TOL 1.
280	DO 290 J=1,NCFIN
	IF(ITEST(J).EQ.0.OR.ABS(DCOS(J)).GT.TOL1)GO TO 290
	IF(RELCOS(J).GE.SMALL)GO TO 290
	SMALL=RELCOS(J)
	JEXCH=J
290	CONTINUE
	IF(SMALL.LT.0)GO TO 300
C---------------GO TO 520 IF HAVE OPTIMAL SOL.
	IF(NPHASE.EQ.2)GO TO 520
C---------------GO TO 295 IF FINISHED PHASE 1
	IF(ABS(WOBJ).LE.TOL2)GO TO 295
	GO TO 515
295	DO 296 I=1,NCFIN
296	DCOS(I)=RELCOS(I)
	NPHASE=2
	GO TO 175
C---------------CALCULATE VALUES IN PIVOTAL CAL.
300	DO 310 I=1,NR
	PIVCOL(I)=0
310	CONTINUE
	DO 340 I=1,NR
	IJ=(I-1)*NR
	DO 340 J=1,NR
	IJ=IJ+1
C---------------JEXCH=COL. WITH SMALLEST REL.COST COEFF.
	JJEXCH=(J-1)*NCFIN+JEXCH
C---------------FIRST TIME ALL JPRINV(J)=0, SO WE MOVE 
C--------------- JEXCH. COL. TO PIVCOL, LATER ONE OR MORE OF
C--------------- JPRINV(J) NE 0 (SEE ST. 412).  THIS IS
C--------------- REALLY MULT. OF INVERSE BY JEXCH COL. BUT
C--------------- USING JPRINV(J) TO SAVE COMPUTATIONS.
	IF(JPRINV(J).EQ.0)GO TO 320
	PIVCOL(I)=PIVCOL(I)+PRINV(IJ)*AMAT(JJEXCH)
	GO TO 335
320	IF(I.EQ.J)GO TO 330
	GO TO 340
330	PIVCOL(I)=PIVCOL(I)+AMAT(JJEXCH)
335	IF(ABS(PIVCOL(I)).GE.TOL3)GO TO 340
	PIVCOL(I)=0
340	CONTINUE
	IF(NPHASE.EQ.1)GO TO 350
C---------------IN PHASE 2 ONLY CSPRIM IS NEEDED TO UPDATE
C--------------- SHADPR.  SEE ST. 435.
	CSPRIM=RELCOS(JEXCH)
	GO TO 365
C---------------IN PHASE 1 WE NEED BOTH DSPRIM AND CSPRIM.
C--------------- SEE ST. 435.
350	DSPRIM=RELCOS(JEXCH)
	CSPRIM=COBJ(JEXCH)
	DO 360 I=1,NR
	IJEXCH=(I-1)*NCFIN+JEXCH
	CSPRIM=CSPRIM+SHADPR(I)*AMAT(IJEXCH)
360	CONTINUE
365	CONTINUE
C---------------DETERMINE EXCHANGE ROW=ROW FOR WHICH
C--------------- BCONST(I)/PIVCOL(I) IS SMALLEST FOR
C--------------- PIVCOL(I) GREATER THAN ZERO.
370	RSMALL=GREAT
	NUM=0
	NMIN=0
	K=0
	DO 372 I=1,NR
	IMIN(I)=0
372	CONTINUE
	DO 400 I=1,NR
	IF(PIVCOL(I))390,390,375
375	RATIO=BCONST(I)/PIVCOL(I)
C---------------ROUND OFF RATIO TO EXACTLY 7 DECIMAL PLACES TO ALLOW
C---------------NUMBERS WHICH ARE CLOSE ENOUGH TOGETHER TO BE 
C--------------- DESIGNATED AS TIES.
373	RAT=RATIO*TOL4+0.5
374	RATIO=AINT(RAT)*TOL5
	IF(RATIO.LT.RSMALL)GO TO 380
	GO TO 385
380	RSMALL=RATIO
	IEXCH=I
	IMIN(I)=I
	NMIN=1
	IX=I-1
	IF(IX.EQ.0)GO TO 400
	DO 381 N=1,IX
	IMIN(N)=0
381	CONTINUE
	GO TO 400
385	IF(RATIO.EQ.RSMALL)GO TO 386
	GO TO 400
386	NMIN=NMIN+1
	IMIN(I)=I
	GO TO 400
C---------------COME HERE FROM ST. 372+2
390	NUM=NUM+1
400	CONTINUE
C---------------COME HERE FROM JUST ABOVE AND/OR ST. 406+1
388	IF(NMIN.GT.1)GO TO 401
	GO TO 407
401	CONTINUE
C---------------ITERATION "ITER" HAS A "NMIN" FOLD DEGENERACY.
C--------------- RESOLVE DEGENERACY.
C---------------SEE "INTRO TO LIN. PROG." BY W.W. GARVIN PP.215-216.
411	K=K+1
403	RSMALL=GREAT
	DO 406 L=1,NR
	IF(IMIN(L).EQ.0)GO TO 406
	IM=IMIN(L)
	IMK=(IM-1)*NR+K
	RATIO=PRINV(IMK)/PIVCOL(IM)
402	RAT=RATIO*TOL4+0.5
409	RATIO=AINT(RAT)*TOL5
	IF(RATIO.LT.RSMALL)GO TO 404
	IF(RATIO.GT.RSMALL)GO TO 405
	NMIN=NMIN+1
	GO TO 406
404	RSMALL=RATIO
	IEXCH=L
	IL=L-1
	NMIN=1
	IF(IL.EQ.0)GO TO 406
	DO 408 I=1,IL
	IMIN(I)=0
408	CONTINUE
	GO TO 406
405	IMIN(L)=0
406	CONTINUE
	GO TO 388
C---------------COME HERE FROM ST. 388+1.  NUM = # OF PIVCOL(I) LE 0
407	IF(NUM.EQ.NR)GO TO 500
C---------------COL. WITH SMALLEST REL.COST COEFF. (JEXCH)
C--------------- DETERMINE THAT A VAR. GOES INTO THE BASIS.
C---------------ROW WITH SMALLEST BCONST/PIVCOL RATIO (IEXCH)
C--------------- DETERMINES THAT A VAR. GOES OUT OF BASIS.
	IB=IBASIS(IEXCH)
	ITEST(IB)=1
	ITEST(JEXCH)=0
	IBASIS(IEXCH)=JEXCH
C---------------ITER=NO. OF PIVOTS IN THE REVISED SIMPLEX PROCEDURE.
	ITER=ITER+1
C---------------CALCULATE VALUES OF BASIS VARS.
	PIVOT=PIVCOL(IEXCH)
	BBASE=BCONST(IEXCH)/PIVOT
	DO 420 I=1,NR
	IF(I.EQ.IEXCH)GO TO 410
	BCONST(I)=BCONST(I)-PIVCOL(I)*BBASE
	GO TO 415
410	BCONST(I)=BBASE
415	IF(BCONST(I).LT.TOL6)BCONST(I)=0
420	CONTINUE
C---------------CALCULATE INVERSE.
412	JPRINV(IEXCH)=IEXCH
	DO 430 J=1,NR
	IF(JPRINV(J).EQ.0)GO TO 430
	IEXCHJ=(IEXCH-1)*NR+J
	PRINV(IEXCHJ)=PRINV(IEXCHJ)/PIVOT
	BSTAR(J)=PRINV(IEXCHJ)
	DO 431 I=1,NR
	IJ=(I-1)*NR+J
	IF(I.EQ.IEXCH)GO TO 425
	PRINV(IJ)=PRINV(IJ)-PIVCOL(I)*BSTAR(J)
425	IF(ABS(PRINV(IJ)).GE.TOL7)GO TO 431
	PRINV(IJ)=0
431	CONTINUE
430	CONTINUE
C---------------CALCULATE SIMPLEX MULTIPLIERS (SHADOW PRICES).
C--------------- IN PHASE 1 UPDATE BOTH SHADPR AND WSHAD.  IN
C--------------- PHASE 2 UPDATE ONLY SHADPR.
435	DO 440 J=1,NR
	IEXCHJ=(IEXCH-1)*NR+J
	SHADPR(J)=SHADPR(J)-CSPRIM*PRINV(IEXCHJ)
	IF(ABS(SHADPR(J)).LT.TOL8)SHADPR(J)=0
	IF(NPHASE.EQ.2)GO TO 440
	WSHAD(J)=WSHAD(J)-DSPRIM*PRINV(IEXCHJ)
	IF(ABS(WSHAD(J)).LT.TOL9)WSHAD(J)=0
440	CONTINUE
C---------------CALCULATE VALS. OF OBJ. FUNCTION.
	ZZ=ZZ-CSPRIM*BBASE
	ZOBJ=-ZZ
	IF(NPHASE.EQ.2)GO TO 4400
	WZ=WZ-DSPRIM*BBASE
	WOBJ=-WZ
442	IF(WOBJ.LT.TOL10)WOBJ=0
4400	CONTINUE
C---------------ITERR=-1 MEANS USER SPEC. INOUT OPTION
	IF(ITERR.NE.-1)GO TO 175
	IF(NPHASE.NE.1)GO TO 517
C---------------IN PHASE 1 WE PRINT WOBJ. IN PHASE 2 WE PRINT ZOBJ.
	ZZOBJ=WOBJ
	IF(ICOND.EQ.1)ZZOBJ=-WOBJ
443	ITERRI=ITERRI+1
	WRITE(NDEVO,444)ITERRI,ZZOBJ,NBASIS(IB),NBASIS(JEXCH)
444	FORMAT(3X,I3,5X,G15.8,5X,A10,5X,A10)
	GO TO 175
C---------------FIRST2=2 MEANS WE ALREADY PRINTED 'PHASE 2'
C--------------- IN ST. 182.
517	IF(FIRST2.NE.2)GO TO 518
C---------------IN PHASE 2 WE PRINT ZOBJ. IN PHASE 1 WE PRINT WOBJ.
	ZZOBJ=ZOBJ
	IF(ICOND.EQ.1)ZZOBJ=-ZOBJ
	GO TO 443
518	WRITE(NDEVO,519)
519	FORMAT(1X,/1X,'PHASE 2'/)
	FIRST2=2
	GO TO 517
C---------------COME HERE FROM ST. 407
500	WRITE(NDEVO,510)
510	FORMAT(1H0,'SOLUTION IS UNBOUNDED.'/)
	LSTOP=1
	RETURN
515	WRITE(NDEVO,516)
516	FORMAT(1H0,'PROBLEM HAS NO FEASIBLE SOLUTION.'/)
	LSTOP=1
	RETURN
520	CONTINUE
	IF(ICOND.EQ.1)ZOBJ=-ZOBJ
	IF(ICOND.EQ.1)GO TO 5001
	LABEL1='MINIMUM'
	LABEL2='MINIMIZE'
	GO TO 5002
5001	LABEL1='MAXIMUM'
	LABEL2='MAXIMIZE'
5002	WRITE(NDEVO,5000)LABEL1,ZOBJ
5000	FORMAT(1X,'THE ',A10,'VALUE OF OBJECTIVE FUNCTION IS '
	1,/,1X,G15.8,/)
	WRITE(NDEVO,5003)LABEL2
5003	FORMAT(//,' THE VARIABLES AND NUMBER OF UNITS THAT
	1 SHOULD BE USED TO ',A10,/,' THE OBJECTIVE FUNCTION
	2 ARE AS FOLLOWS:'/)
	DO 5004 I=1,NR
	WRITE(NDEVO,5005)NBASIS(IBASIS(I)),BCONST(I)
5004	CONTINUE
5005	FORMAT(1X,10X,A10,3X,G15.8)
	WRITE(NDEVO,5006)
5006	FORMAT(//,1X,'ZERO UNITS OF OTHER VARIABLES ARE ',
	1'TO BE USED.'/)
	FLAG=0
	RETURN
	END