PDP-10 Archive: decus/20-0137/rvslpr/sg2rvs.for from decuslib20-05

Trailing-Edge - PDP-10 Archives - decuslib20-05 - decus/20-0137/rvslpr/sg2rvs.for
There are 2 other files named sg2rvs.for in the archive. Click here to see a list.
C	WESTERN MICHIGAN UNIVERSITY
C	SG2RVS.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/, AND /NONDVN/ SHARED BY MAIN PROG.,
C	 MAIN1, MAIN2, AND SEGMT1.
C	SENAN IS SPACE RESERVED BY DYN. ALLOC. OTHER ARGS. ARE INPUT.
C	ISWST RETURNED BY SUBR. SEGMT2 THRU COMMON /NONDYN/
C
	SUBROUTINE SEGMT2(BINIT,ISLACK,AMAT,IBASIS,SHADPR,WSHAD,COBJ,
	1ITEST,CWOBJ,NART,RELCOS,BCONST,PRINV,JPRINV,
	2PIVCOL,BSTAR,IMIN,NBASIS,NONBA,DCOS,ORIGBA,SENAN)
	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
	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
	DOUBLE PRECISION NBASIS,TEMP1,TEMP2,TEMP3
	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),SENAN(1)
	INTEGER POSTOP(13)
C---------------POST SOLUTION OPTIONS
	DATA POSTOP/'RELCO','INVER','BASEN','NBSEN','BVSEN','HELP',
	1'TABLE','TABLO','START','END',
	2'INEQ','OBJ','BVALU'/
	NCOL=5
10	WRITE(IDLG,6)
6	FORMAT(1X,'ENTER POST SOLUTION OPTION(S).'/)
14	WRITE(IDLG,43)
43	FORMAT(/' *',$)
4	READ(NDEVI,8)JTYPE
	KKK=0
8	FORMAT(A5)
	DO 28 I=1,13
	IF(POSTOP(I).EQ.JTYPE)
	1GO TO(13,35,32,33,34,37,103,103,104,105,44,45,46),I
28	CONTINUE
	IF(ICODE.EQ.-1)CALL EXIT
	WRITE(IDLG,9)JTYPE
9	FORMAT(1X,A5,3X,'IS NOT VALID. TRY AGAIN.'/)
	GO TO 14
C---------------RELCO OPTION
13	WRITE(NDEVO,2510)
2510	FORMAT(1X,'RELATIVE COST COEFFS'/)
	NFIRST=1
	NLAST=NCOL
	NCF=NCFIN
	IF(NLAST.GT.NCF)NLAST=NCF
2525	WRITE(NDEVO,2560)(NBASIS(J),J=NFIRST,NLAST)
2560	FORMAT(1H0,10(3X,A10))
	WRITE(NDEVO,2570)(RELCOS(J),J=NFIRST,NLAST)
	IF(NLAST.GE.NCF)GO TO 14
	NFIRST=NFIRST+NCOL
	NLAST=NLAST+NCOL
	IF(NLAST.GT.NCF)NLAST=NCF
	GO TO 2525
2570	FORMAT(1X,10(3X,E10.3))
	WRITE(NDEVO,1000)
1000	FORMAT(1X,'INVERSE',///)
C---------------INVER OPTION
35	NUMIN=1
	NUMEND =NCOL
	IF(NUMEND.GT.NR)NUMEND=NR
5013	WRITE(NDEVO,5014)(J,J=NUMIN,NUMEND)
5014	FORMAT(/,7X,I4,9(9X,I4))
	DO 5015 I=1,NR
	IJ=(I-1)*NR
	WRITE(NDEVO,5016)(PRINV(IJ+J),J=NUMIN,NUMEND)
5015	CONTINUE
5016	FORMAT(1X,10(3X,E10.3))
	NUMIN=NUMIN+NCOL
	NUMEND=NUMEND+NCOL
	IF(NUMIN.GT.NR)GO TO 14
	IF(NUMEND.GT.NR)NUMEND=NR
	GO TO 5013
C---------------BASEN OPTION
32	IF(KKK.EQ.1)GO TO 5034
	LL=1
	GO TO 5033
C---------------NBSEN OPTION
33	IF(KKK.EQ.1)GO TO 5035
	LL=2
5033	K=1
	DO 5022 I=1,NCFIN
	IF(ITEST(I).EQ.0.OR.ABS(DCOS(I)).GT.TOL1)GO TO 5022
	NONBA(K)=I
	K=K+1
5022	CONTINUE
	IF((K-1).EQ.0)GO TO 5085
	KLIM=K-1
	GO TO 5086
5085	WRITE(NDEVO,5087)
5087	FORMAT(1X,'ALL NONBASIC VARIABLES ARE ARTIFICIAL.',
	1' THIS SENSITIVITY ANALYSIS OMITTED.'/)
	GO TO 14
5086	DO 5020 K=1,KLIM
	KK=NONBA(K)
	DO 5020 I=1,NR
	TEMP=0
	IJ=(I-1)*NR
C---------------MULTIPLY INVERSE BY COLS. OF ORIG. TABLEAUX
C--------------- WHICH ARE NOT IN BASIS AND WHOSE PHASE 1 REL.COST
C--------------- COEFF. ARE LE TOL1. SEE ST. 5033+2.  ALSO SEE
C--------------- BOOK BY DANTZIG "LIN. PROG. & EXTENSIONS"
	DO 5021 J=1,NR
	IJ=IJ+1
	JKK=(J-1)*NCFIN+KK
5021	TEMP=PRINV(IJ)*AMAT(JKK)+TEMP
	IK=(I-1)*KLIM+K
5020	SENAN(IK)=TEMP
	KKK=1
	GO TO(5034,5035),LL
C---------------COME FROM ST. 32
5034	WRITE(NDEVO,5030)
5030	FORMAT(1X,'SENSITIVITY ANAL. TABLE FOR BASIS',
	1' (SOLUTION) VARIABLES'//)
	WRITE(NDEVO,5044)
5044	FORMAT(1X,62(1H-)/11X,1HI,10X,1HI,
	214X,1HI,10X,1HI/' VAR. NAM. ', 1HI,'L.L. VAR. ',1HI,
	3'  LOW LIMIT   ',
	41HI,'TOP L. VAR',1HI,'TOP LIMIT'/11X,1HI,10X,1HI,14X,1HI,10X,
	51HI,/1X,62(1H-)/11X,1HI,10X,1HI,14X,1HI,10X,1HI)

	JJ=1
	DO 5028 I=1,NR
	UPPER=-GREAT
	UNDER=GREAT
	K1=1
	K2=1
	IB=IBASIS(I)
	IK=(I-1)*KLIM
	DO 5023 K=1,KLIM
	IK=IK+1
	II=NONBA(K)
	IF(SENAN(IK).EQ.0)GO TO 5023
	RATIO=RELCOS(II)/SENAN(IK)
	IF(SENAN(IK))5024,5023,5025
5025	IF(RATIO-UNDER)5026,5026,5023
5026	UNDER=RATIO
	K1=K
	GO TO 5023
5024	IF(RATIO-UPPER)5023,5027,5027
5027	UPPER=RATIO
	K2=K
5023	CONTINUE
	TEMP1=NBASIS(NONBA(K1))
	TEMP2=NBASIS(NONBA(K2))
	TEMP3=NBASIS(IB)
	UNLIM=-COBJ(IB)-UNDER
	UPLIM=-COBJ(IB)-UPPER
	GO TO 5066
5028	CONTINUE
5029	FORMAT(1X,A10,'I',A10,'I',G14.8,'I',A10,'I',G14.8)
	GO TO 14
C---------------COME FROM ST. 33.
5035	WRITE(NDEVO,5043)
5043	FORMAT(//1X,'SENSITIVITY ANAL. TABLE FOR NON',
	1'BASIS VARIABLES'//)
	JJ=2
	WRITE(NDEVO,5044)
	DO 5036 J=1,KLIM
	UPLIM=GREAT
	UNLIM=-GREAT
	K1=1
	K2=1
	DO 5037 I=1,NR
	IJ=(I-1)*KLIM+J
	IF(SENAN(IJ))5038,5037,5038
5038	RATIO=BCONST(I)/SENAN(IJ)
	IF(SENAN(IJ))5039,5037,5040
5039	IF(RATIO-UNLIM)5037,5041,5041
5041	UNLIM=RATIO
	K1=I
	GO TO 5037
5040	IF(RATIO-UPLIM)5042,5042,5037
5042	UPLIM=RATIO
	K2=I
5037	CONTINUE
	TEMP1=NBASIS(IBASIS(K1))
	TEMP2=NBASIS(IBASIS(K2))
	TEMP3=NBASIS(NONBA(J))
	GO TO 5066
5036	CONTINUE
	GO TO 14
5066	IF(UNLIM.NE.-GREAT.AND.UPLIM.NE.GREAT)GO TO 5067
	IF(UNLIM.NE.-GREAT)GO TO 5068
	TEMP1='NONE  '
5068	IF(UPLIM.NE.GREAT)GO TO 5067
	TEMP2='NONE  '
5067	WRITE(NDEVO,5029)TEMP3,TEMP1,UNLIM,TEMP2,UPLIM
	GO TO(5028,5036),JJ
C---------------BVSEN OPTION
34	WRITE(NDEVO,5054)
5054	FORMAT(1X,'SENSITIVITY ANAL. TABLE FOR THE',
	1' B VALUES'//)
	WRITE(NDEVO,5055)
5055	FORMAT(1X,62(1H-)/15X,1HI,10X,1HI,
	114X,1HI,10X,1HI/5X,'B VALUES  ',1HI,'L.L. VAR. ',1HI
	2,'  LOW LIMIT   ',
	31HI,'TOP L. VAR',1HI,'TOP LIMIT',/15X,1HI,10X,1HI,14X,1HI,10X,
	41HI/1X,62(1H-)/15X,1HI,10X,1HI,14X,1HI,10X,1HI)
	DO 5045 J=1,NR
	UPPER=GREAT
	UNDER=-GREAT
	K1=1
	K2=1
	DO 5046 I=1,NR
	IJ=(I-1)*NR+J
	IF(PRINV(IJ))5047,5046,5047
5047	RATIO=BCONST(I)/PRINV(IJ)
	IF(PRINV(IJ))5049,5046,5050
5049	IF(RATIO-UNDER)5046,5051,5051
5051	UNDER=RATIO
	K1=I
	GO TO 5046
5050	IF(RATIO-UPPER)5052,5052,5046
5052	UPPER=RATIO
	K2=I
5046	CONTINUE
	BMAX=BINIT(J)+ABS(UNDER)
	BMIN=BINIT(J)-UPPER
	IB1=IBASIS(K1)
	IB2=IBASIS(K2)
	TEMP1=NBASIS(IB2)
	TEMP2=NBASIS(IB1)
	IF(BMIN.NE.-GREAT.AND.BMAX.NE.GREAT)GO TO 5045
	IF(BMIN.NE.-GREAT)GO TO 5070
	TEMP1='NONE '
5070	IF(BMAX.NE.GREAT)GO TO 5045
	TEMP2='NONE '
5045	WRITE(NDEVO,5048)BINIT(J),TEMP1,BMIN,TEMP2,BMAX
5048	FORMAT(1X,G14.8,1HI,A10,1HI,G14.8,1HI,A10,1HI,G14.8)
	GO TO 14
C---------------HELP OPTION
37	WRITE(NDEVO,5059)
5059	FORMAT(1X,'AVAILABLE OPTIONS ARE RELCO,INVER,BASEN,NBSEN,'/1X,
	1'BVSEN,TABLO,TABLE,INEQ,OBJ,BVALU,START,AND END.'/1X,
	2'1)END MUST BE LAST OPTION. IT IS ONLY REQUIRED OPTION.'/1X,
	3'IT CAUSES EXIT FROM PROG.'/1X,
	4'2)RELCO PRINTS RELATIVE COST COEFFS.'/1X,
	5'3)INVER PRINTS INVERSE OF BASIS MATRIX.'/1X,
	6'4)BASEN PRINTS SENS. ANAL. TABLE FOR BASIS VARS.'/1X,
	7'5)NBSEN PRINTS SENS. ANAL. TABLE FOR NON-BASIS VARS.'/1X,
	8'6)BVSEN PRINTS SENS. ANAL. TABLE FOR CONTRAINT CONSTANTS.'/1X,
	9'7)TABLO OR TABLE PRINTS CURRENT TABLEAU.'/1X,
	1'WE MAY CHANGE TABLEAU VALUES AND RERUN AS BELOW:'/1X,
	2'1)AFTER INEQ ENTER 3 VALUES SEPARATED BY 2 COMMAS.'/1X,
	3'FIRST IS SEQ. ID. I OF INEQ. SECOND IS SEQ. ID. J OF '/1X,
	4'UNKNOWN. THIRD IS NEW COEFF. A(I,J). AFTER LAST CHANGE,'/1X,
	5'ENTER 0 OR CTRL Z.'/1X,
	6'2)AFTER OBJ ENTER 2 VALUES SEP. BY COMMA. FIRST IS SEQ.'/1X,
	7'ID. J OF COST COEFF. SECOND IS NEW COST COEFF.'/1X,
	8'3)AFTER BVALU ENTER 2 VALUES SEP. BY COMMA. FIRST IS SEQ.')
	WRITE(IDLG,200)
200	FORMAT(1X,'ID. I OF INEQ. SECOND IS NEW CONSTRAINT'/1X,
	1'CONSTANT B(I) OF ITH INEQ.'/1X,
	2'DO NOT CHANGE SIGN OF BVALU.'/1X,
	3'4)START CAUSES NEW PROB. TO BE SOLVED.'/)
	CALL TYPEON
	GO TO 14
C---------------INEQ OPTION
44	IE=1
5100	READ(NDEVI,5078,ERR=5077,END=14)I,J,VALUE
	IJ=(I-1)*NCFIN+J
	IF(I.EQ.0)GO TO 14
	IF(I.LT.1.OR.I.GT.NR.OR.J.LT.1.OR.J.GT.NC)GO TO 5077
	IF(BINIT(I).GE.0)GO TO 5082
	AMAT(IJ)=-VALUE
	GO TO 5100
5082	AMAT(IJ)=VALUE
	GO TO 5100
5077	WRITE(IDLG,5079)
5079	FORMAT(1X,'ERROR IN INPUT DATA;TRY AGAIN.'/)
	GO TO(44,45,46),IE
C---------------OBJ OPTION OPTION
45	IE=2
5101	READ(NDEVI,5076,ERR=5077,END=14)J,VALUE
	IF(J.EQ.0)GO TO 14
	IF(J.GT.NC.OR.J.LT.1)GO TO 5077
	IF(ICOND.NE.0)COBJ(J)=-VALUE
	GO TO 5101
5076	FORMAT(I,F)
5078	FORMAT(2I,F)
C---------------BVALU OPTION
46	IE=3
47	READ(NDEVI,5076,ERR=5077,END=14)I,VALUE
	IF(I.EQ.0)GO TO 14
	IF(I.LT.1.OR.I.GT.NR)GO TO 5077
	SGN1=SIGN(1.0,VALUE)
	SGN2=SIGN(1.0,BINIT(I))
	IF(SGN1.NE.SGN2)GO TO 5083
	IF(BINIT(I).GE.0)GO TO 5080
	BINIT(I)=-VALUE
	GO TO 47
5080	BINIT(I)=VALUE
	GO TO 47
5083	WRITE(IDLG,5084)
5084	FORMAT(1X,'SIGN OF NEW B VALUE MUST EQUAL SIGN OF',
	1' OLD VALUE.'/)
	GO TO 14
C---------------START OPTION
104	ISWST=1
	RETURN
C---------------END OPTION
105	ISWST=2
	RETURN
C---------------TABLE, TABLO OPTIONS
103	WRITE(IRSP,700)
700	FORMAT(1X,'INITIAL COEFF. MATRIX'/)
710	FORMAT(1X,3X,9(3X,A10)/)
720	FORMAT(1X,I3,10(3X,E10.3))
740	NFIRST=1
	NLAST=NCOL
	IF(NLAST.GT.NC)NLAST=NC
760	WRITE(IRSP,710)(NBASIS(J),J=NFIRST,NLAST)
	DO 770 I=1,NR
	IJ=(I-1)*NCFIN
	WRITE(IRSP,720)I,(AMAT(IJ+J),J=NFIRST,NLAST)
770	CONTINUE
	IF(NLAST.GE.NC)GO TO 780
	NFIRST=NFIRST+NCOL
	NLAST=NLAST+NCOL
	IF(NLAST.GT.NC)NLAST=NC
	GO TO 760
780	NFIRST=NC+1
	NLAST=NC+NCOL
	IF(NLAST.GT.NCFIN)NLAST=NCFIN
772	WRITE(IRSP,710)(NBASIS(J),J=NFIRST,NLAST)
	IF(NLAST.GE.NCFIN)GO TO 771
	NFIRST=NFIRST+NCOL
	NLAST=NLAST+NCOL
	IF(NLAST.GT.NCFIN)NLAST=NCFIN
	GO TO 772
771	WRITE(IRSP,790)
790	FORMAT(1H0,3X,'INITIAL',/,5X,'BASIS',3X,'CONSTANTS'/)
	DO 810 I=1,NR
	II=ORIGBA(I)
	WRITE(IRSP,800)NBASIS(II),BINIT(I)
810	CONTINUE
800	FORMAT(5X,A10,' = ',E10.3)
	WRITE(IRSP,820)
820	FORMAT(1H0,'COEFFS. OF OBJECTIVE FUNCTION,Z')
	NFIRST=1
	NLAST=NCOL
830	IF(NLAST.GT.NCFIN)NLAST=NCFIN
840	WRITE(IRSP,850)(NBASIS(J),J=NFIRST,NLAST)
850	FORMAT(1H0,3X,9(3X,A10)/)
	WRITE(IRSP,860)(COBJ(J),J=NFIRST,NLAST)
860	FORMAT(4X,10(3X,E10.3))
	IF(NLAST.GE.NCFIN)GO TO 14
	NFIRST=NFIRST+NCOL
	NLAST=NLAST+NCOL
	IF(NLAST.GT.NCFIN)NLAST=NCFIN
	GO TO 840
	END