Google
 

Trailing-Edge - PDP-10 Archives - decus_20tap5_198111 - decus/20-0137/zerone/zerone.for
There is 1 other file named zerone.for in the archive. Click here to see a list.
00100	C	WESTERN MICHIGAN UNIVERSITY
00200	C	ZERONE.F4 (FILE NAME ON LIBRARY DECTAPE)
00300	C	ZERONE, 2.2.4 (CALLING NAME, SUBLST. NO.)
00400	C	0-1 INTEGER PROGRAMMING
00500	C	THIS PROGRAM IS AN ADAPTATION OF "SOLUTION OF LINEAR 
00600	C	 PROGRAMMING IN 0-1 VARIABLES" FROM COMMUNICATIONS OF THE
00700	C	 ACM, JULY 1973, VOL. 16, NUMBER 7, PAGES 445--447.  THIS
00800	C	 PROGRAM CONTAINS SUBSTANTIAL ADDITIONAL PROGRAMMING BY MR.
00900	C	 J. GROESSER.
01000	C	REPRINTING PRIVILEGES WERE GRANTED BY PERMISSION OF THE 
01100	C	ASSOCIATION FOR COMPUTING MACHINERY, BUT NOT FOR PROFIT.
01200	C	LIBRARY DECTAPE PROGS. USED:  USAGE.MAC
01300	C	FORWMU PROGS. USED:  ALLCOR, TTYPTY, DEVCHG, DEVICE, 
01400	C	 EXISTS, PRINTS
01500	C	APLIB PROGS. USED:  IOB
01600	C	INTERNAL SUBR. USED:  TEST
01700	C	ABOVE COMMENTS AND RIGHT ADJUSTED COMMENTS PUT IN BY WG
01800	C
01900	C
02000		COMMON /IOBLK/IDLG,INT,INP,IRP,IDEV,IDEVA,ICODE,IC,NAMI(2)
02100		COMMON /IOBLKA/NAMO(2),IPJ,IPG,NCOPYS,IAUX
02200		COMMON IDL,IDR,INC,NESTEX,ITYCH,ITYPE,NSEE
02300		DIMENSION B(1)
02400		ITYCH=1
02500		NSEE=0
02600		INT=5
02700		IDLG=-1
02800	C---------------TTYPTY RETURNS ZERO - TTYJOB, MINUS ONE - BATCH JOB
02900		CALL TTYPTY (ICODE)
03000		IRP=2
03100		CALL DEFINE FILE (ITYCH,0,NV,'LPRTMP',0,0)
03200		INP=3
03300		IDEV='DSK'
03400		WRITE(IDLG,5001)
03500	5001	FORMAT(1X,'WMU 0-1 PROGRAMMING',/)
03600	C	CALL USAGE('ZERONE')
03700	C---------------1 MEANS OUTPUT? PRINTS.  IDLG, INT, IRP, IDEV,
03800	C--------------- ICODE ARE INPUT AND NAMI(2), IC ARE
03900	C--------------- RETURNED THRU COMMON /IOBLK/
04000		CALL IOB(1)
04100	13	CALL DEVCHG (IDEV,INP)
04200		CALL IOB(0)
04300		REWIND (ITYCH)
04400	99	WRITE (IDLG,5000)
04500	5000  FORMAT (' ','TYPE 1ST CONTROL LINE'/)
04600	      READ(INT,9901,END=7999)ITYPE,IDL,IDR,IEQNS,INBVS
04700	9901  FORMAT(3A5,2I,A5)
04800		IF (ITYPE.EQ.'ALTER') GO TO 5013
04900		WRITE (IDLG,2)
05000	2	FORMAT (1X,'ENTER # OF INEQUALITIES AND UNKNOWNS',
05100	     1 ' SEPARATED BY A COMMA.'/)
05200		READ (INT,3) IEQNS,INBVS
05300	3	FORMAT (2I)
05400	4     IF(ITYPE.EQ.'PROB-') GO TO 117
05500	      CALL DEVICE   (INT)
05600	      GO TO 99
05700	5013	READ (ITYCH,9903,END=7999) DUM1,DUM2,IEQNS,INBVS
05800	9903	FORMAT (2A5,2I)
05900		IEQNS=IEQNS-1
06000		WRITE (IDLG,5014)
06100	5014	FORMAT (1X,'ENTER OUTPUT HEADER(10 CHARACTERS MAXIMUM)'/)
06200		READ (INT,9902) IDL,IDR
06300	9902	FORMAT (2A5)
06400	117	WRITE (IDLG,129)
06500	129	FORMAT (1X,'ESTIMATED # OF MAXIMIZING POINTS?  '$)
06600		READ (INT,130) MOPT
06700	130	FORMAT (I)
06800		M=IEQNS+1
06900		N=INBVS
07000		MN=M*N
07100		MAX=(M*N)*2+5*M+6*N+MOPT*N
07200	C---------------MAX IS INPUT
07300	      CALL ALLCOR(MAX,IERR,I1,B)
07400	      IF(IERR.EQ.0) GO TO 126
07500	      WRITE(IDLG,5)
07600	5     FORMAT(1X,'NOT ABLE TO ALLOCATE CORE'/)
07700	      GO TO 99
07800	126	WRITE (IDLG,127)
07900	127	FORMAT (1X,'DO WANT TO SEE CURRENT SYSTEM AT EACH ITERATION?',
08000	     1	'(YES OR NO)  '$)
08100		READ (INT,128) JSEE
08200	128	FORMAT (A3)
08300		IF (JSEE.NE.'YES') NSEE=1
08400		I2=I1+M*N
08500		I3=I2+M*N
08600		I4=I3+M
08700		I5=I4+M
08800		I6=I5+M
08900		I7=I6+M
09000		I8=I7+N
09100		I9=I8+N
09200		I10=I9+N
09300		I11=I10+N
09400		I12=I11+N
09500		I13=I12+N
09600		I14=I13+M
09700		CALL TEST(M,N,MOPT,MN,B(I1),B(I2),B(I3),B(I4),B(I5),
09800		1B(I6),B(I7),B(I8),B(I9),B(I10),B(I11),B(I12),B(I13),B(I14))
09900		GO TO 13
10000	7999  CALL EXIT
10100	      END
10200	C	ZERO-ONE LINEAR PROGRAMMING
10300	C	INITIAL DATE 4/24/74
10400	C	THIS PROGRAM WAS TAKEN FROM THE JULY,1973 ISSUE OF THE 
10500	C	"COMMUNICATIONS OF THE ACM".  IT WAS MODIFIED TO ACCEPT  OUR
10600	C	LIBRARY SUBROUTINES AND OUTPUT FORMAT BY JERRY GROESSER.
10700	C     SUBROUTINE IO WAS WRITTEN BY MR. SAM ANEMA.
10800	C     THE FOLLOWING SUBROUTINES(MACRO) WERE WRITTEN BY MR. NORM GRANT.
10900	C     SUBROUTINES USED  DEVICE  RETURNS CONTROL TO INSTRUCTION FOLLOWING
11000	C                               IF JOB ON TELETYPE. CALLS EXIT IF JOB IS
11100	C                               BATCH.
11200	C                       TTYPTY  RETURNS -1 IF JOB IS ON BATCH AND 0 IF J
11300	C                               ON TELETYPE. HOWEVER THE RETURN ARGUMENT
11400	C                               NOT USED.
11500	C                       PRINTS  PRINTING SUBROUTINE
11600	C                       DEVCHG  ASSOCIATES DSK,CDR,ETC. WITH LOGICAL DEV
11700	C                       EXISTS  CHECKS FOR EXISTENCE OF FILE.
11800	C                       CLRUWP,ALLCOR,CALMYN--(DYNAMIC ALLOCATION OF MEM
11900	C	MO-DIMENSION OF CONSTRAINTS
12000	C	NO-DIMENSION OF VARIABLES
12100	C	NEST-ALTERNATIVE OPTIMAL SOLUTIONS
12200	C	M- # OF CONSTRAINTS PLUS SUPPLEMENTRY
12300	C	N- # OF VARIABLES
12400	C	AO- COEFFICIENTS OF CONSTRAINTS
12500	C	BO-TERMS OF THE COEFFICIENTS
12600	C	BO(1)- ABSOLUTE TERM OF THE OBJECTIVE FUNCTION
12700	C	A(MO,NO)- COEFFICIENTS OF THE CURRENT SYSTEM
12800	C	B(N)- RIGHT HAND TERMS OF THE CURRENT SYSTEM
12900	C	VNEG- SUM OF NEG COEFFICINETS IN OBJECTIVE FUNC. MINUS ONE
13000	C	ITEST = 1  SYSTEM OF CONSTRAINTS IS REDUNDENT
13100	C		=2 SYSTEM OF CONSTRAINTS IS NOT REDUNDENT
13200	C	IND- THE I-TH ELEMENT IS REDUNDENT OR NOT
13300	C	X- CURRENT PARTIAL SOLUTION. A FREE VAR. IS REPRESENTED
13400	C	  BY COMPONET =2
13500	C	S- ORDER OF FIXED VAR.
13600	C	BC- BRANCHING NODE
13700	C	T- BRANCHING NODE AT WHICH ACCELERATING TEST CAN BE APPLIED
13800	C	NS- # OF COMPONETS IN S AND BC
13900	C	B1,S1,SO,C- ARE FOR AUXILLARY CHAR.
14000	C	INC=0  ESTIMATED # OF FEASIBLE SOL WAS NOT EXCEEDED
14100	C	   =1  ESTIMATED # OF FEASIBLE SOL WAS EXCEEDED
14200	C	V= MAX VALUE OF OBJECTIVE FUNC.
14300	C	NOPT- # OF MAX POINTS
14400	C	OPTS- 1ST NOPT ROWS ALL MAX POINTS
14500	C	      A COMPONET OF 2 SAYS THE VALUE OF THE CORRESPONDING
14600	C	      VAR CAN BE ARBITARY
14700	C	NI- # OF ITERATIONS
14800	C	NAT- # OF OF SUCCESFUL APPLICATIONS OF ACCELERATING TEST
14900	C---------------M, N, MOPT, MN ARE INPUT.  MN IS USED IN ST. 1000 - 4.
15000	C---------------FOR OTHER ARGS. SPACE IS RESERVED BY DYNAMIC ALLOC.  SEE
15100	C--------------- MAIN PROG. ST. 7999-2,3.
15200	C---------------IDLG, INT, INP, IRP, IDEV ARE INPUT THRU COMMON
15300	C--------------- /IOBLK/.  IDL, IDR, INC, NEXTEX, ITYCH, ITYPE, NSEE
15400	C--------------- ARE INPUT THRU COMMON.
15500		SUBROUTINE TEST (M,N,MOPT,MN,AO,A,B,BO,B1,
15600	     *S1,C,X,S,SO,BC,T,IND,OPTS)
15700		COMMON /IOBLK/IDLG,INT,INP,IRP,IDEV,IDEVA,ICODE,IC,NAMI(2)
15800		COMMON /IOBLKA/ NAMO(2),IPJ,IPG,NCOPYS,IAUX
15900		COMMON IDL,IDR,INC,NEXTEX,ITYCH,ITYPE,NSEE
16000		INTEGER AO(MN),A(MN),BO(M),B(M),B1(M),
16100	     * S1(M),C(N),X(N),S(N),SO(N),BC(N),T(N),
16200	     * IND(M),V,VNEB,OPTS(MOPT)
16300		DIMENSION LIGN (40),NGO(80),MGO(15),LGO(3),PAREN(40)
16400	1000	FORMAT ('1',11X,'WESTERN MICHIGAN UNIVERISTY LINEAR ZERO-
16500	     *ONE RESULTS',//2X,'PROG. ID = ',2A5,5X,I3,2X,'CONSTRAINTS
16600	     * AND',1X,I3,2X,'UNKNOWNS'/)
16700		INC=0
16800		NEST=MOPT
16900		NESTEX=0
17000		NOPT=0
17100		NS=0
17200		NI=0
17300		NAT=0
17400		IALTER=1
17500		NDAT=-1
17600		NDATT=0
17700		PROC=0
17800		DO 10 J=1,N
17900	10	T(J)=0
18000		IF (ITYPE.EQ.'ALTER') GO TO 21
18100	17	IF (IDEV.NE.'TTY') GO TO 1
18200		IF (PROC.NE.0) GOTO 1
18300		WRITE (IDLG,3)
18400		PROC=1
18500	3	FORMAT (1X,'TYPE IN DATA LINE(S).'/)
18600	1	READ (INP,2) JTYPE
18700	2	FORMAT (A5)
18800		IF (JTYPE.EQ.'START') GO TO 33
18900		IF (JTYPE.EQ.'COEFF') GO TO 11
19000		IF (JTYPE.EQ.'B-VEC') GO TO 13
19100		WRITE (IDLG,6) JTYPE,I
19200	6	FORMAT(1X,'CARD',3X,A5,3X,I,3X,'NOT VALID'//)
19300		CALL DEVICE (INT)
19400		GO TO 17
19500	C	READ IN COEFFS. OF CONSTRAINTS
19600	11	DO 12 I=1,M
19700		ISUB=(I-1)*N
19800	12	READ (INP,14) (AO(ISUB+J),J=1,N)
19900	14	FORMAT (20I)
20000		NDAT=NDAT+1
20100		IF (NDAT) 17,17,33
20200	C	GET RIGHT TERMS OF CONST.
20300	13	READ (INP,16) (BO(J),J=1,M)
20400	16	FORMAT (20I)
20500		NDAT=NDAT+1
20600		IF (NDAT) 17,17,33
20700	C	COPY THE ARRAYS AO,BO
20800	21	IF (IDEV.EQ.'TTY') GO TO 1016
20900		NDATT=2
21000		GOTO 1016
21100	33	WRITE (IDLG,28)
21200	28	FORMAT (1X,'DO YOU WANT TO ALTER DATA?(YES OR NO)  '$)
21300		READ (INT,29) OKK
21400	29	FORMAT (A3)
21500		IF (OKK.NE.'YES') GOTO 15
21600	222	JSWICH=-2
21700	22	WRITE (IDLG,23)
21800	23	FORMAT (1X,'ENTER 1 FOR COEFF MATRIX',/1XT8,'2 FOR B-VECTOR',
21900	     1/,1X,T8,'3 FOR BOTH'/1XT8,'4 FOR NEITHER',/)
22000		READ (INT,24) NCHNG
22100	24	FORMAT (I1)
22200		IF(JSWICH+NCHNG.EQ.2)GO TO 15
22300		IF (JSWICH+NCHNG) 1004,1010,1004
22400	1004	WRITE (IDLG,1005)
22500	1005	FORMAT (1X,'ENTER I,J,NEW VALUE OF COEFF. MATRIX SEPARATED BY',
22600	     1	' COMMAS(START IF NONE)',/)
22700	10666	READ (INT,1013) NGO
22800	1013	FORMAT (80A1)
22900		IF ((NGO(1).EQ.'S').AND.(NGO(2).EQ.'T').AND.(NGO(3).EQ.'A')
23000	     1.AND.(NGO(4).EQ.'R').AND.(NGO(5).EQ.'T')) GOTO 1007
23100		LGO(1)=0
23200		LGO(2)=0
23300		LGO(3)=0
23400		IGO=1
23500		DO 1014	KKK=1,3
23600		DO 10144 KGO=1,15
23700	10144	MGO(KGO)=' '
23800		JJGO=1
23900	10145	IF (NGO(IGO).EQ.',') GOTO 10148
24000		IF (NGO(IGO).EQ.' ') GOTO 10148
24100		IF ((NGO(IGO).LE.'9').AND.(NGO(IGO).GE.'0')) GOTO 10146
24200		WRITE (5,20145)
24300	20145	FORMAT (1X,'ERROR CODE'/)
24400		GOTO 1004
24500	
24600	10146	IF (JJGO.GT.15) GOTO 10147
24700		MGO(JJGO)=NGO(IGO)
24800		JJGO=JJGO+1
24900	10147	IGO=IGO+1
25000		GOTO 10145
25100	10148	IGO=IGO+1
25200	10149	IF (MGO(15).NE.' ') GOTO 10451
25300		DO 10452 JJGO=15,2,-1
25400	10452	MGO(JJGO)=MGO(JJGO-1)
25500		MGO(1)=' '
25600		GOTO 10149
25700	10451	ENCODE (15,1013,LLGO) MGO
25800		DECODE (15,10456,LLGO) LGO(KKK)
25900	10456	FORMAT (I15)
26000	1014	CONTINUE
26100		ISUB=(LGO(1)-1)*M+LGO(2)
26200		AO(ISUB)=LGO(3)
26300		GO TO 10666
26400	1007	IF (NCHNG+JSWICH) 15,1010,1010
26500	1010	WRITE (IDLG,1011)
26600	1011	FORMAT (1X,'ENTER I AND NEW VALUE OF B-VECTOR SEPARATED BY',
26700	     1	' A COMMA(START IF NONE)',/)
26800	1015	READ (INT,1013)NGO
26900		IF ((NGO(1).EQ.'S').AND.(NGO(2).EQ.'T').AND.(NGO(3).EQ.'A')
27000	     1.AND.(NGO(4).EQ.'R').AND.(NGO(5).EQ.'T')) GOTO 15
27100		LGO(1)=0
27200		LGO(2)=0
27300		IGO=1
27400		DO 1012 KKK=1,2
27500		DO 10121 KGO=1,10
27600	10121	MGO(KGO)=' '
27700		JJGO=1
27800	10122	IF (NGO(IGO).EQ.',') GOTO 10125
27900		IF (NGO(IGO).EQ.' ') GOTO 10125
28000		IF((NGO(IGO).LE.'9').AND.(NGO(IGO).GE.'0')) GOTO 10123
28100		PAUSE
28200	10123	IF (JJGO.GT.10)  GOTO 10124
28300		MGO(JJGO)=NGO(IGO)
28400		JJGO=JJGO+1
28500	10124	IGO=IGO+1
28600		GOTO 10122
28700	10125	IGO=IGO+1
28800	10126	IF (MGO(10).NE.' ') GOTO 10128
28900		DO 10127 JJGO=10,2,-1
29000	10127	MGO(JJGO)=MGO(JJGO-1)
29100		MGO(1)=' '
29200		GOTO 10126
29300	10128	ENCODE (10,1013,LLGO) (MGO(JJGO),JJGO=1,10)
29400		DECODE (10,10457,LLGO) LGO(KKK)
29500	10457	FORMAT (I10)
29600	1012	CONTINUE
29700		BO(LGO(1))=LGO(2)
29800		GO TO 1015
29900	1016	CALL RELEASE (INP)
30000		DO 34 I=1,M
30100		ISUB=(I-1)*N
30200	34	READ (ITYCH,14) (AO(ISUB+J),J=1,N)
30300		READ (ITYCH,14) (BO(J),J=1,N)
30400		CALL RELEASE (ITYCH)
30500		IF (ITYPE.EQ.'ALTER') CALL DEVCHG('TTY',INP)
30600		GOTO 222
30700	15		WRITE (IDLG,5)
30800	5	FORMAT (1X,'DATA BEING PROCESSED'/)
30900		DO 30 I=1,M
31000		B(I)=BO(I)
31100		KK=(I-1)*N
31200		DO 20 J=1,N
31300		ISUB=KK+J
31400	20	A(ISUB)=AO(ISUB)
31500	30	CONTINUE
31600		CALL RELEASE (INP)
31700		REWIND (ITYCH)
31800		WRITE (ITYCH,9901) IDL,IDR,M,N
31900	9901	FORMAT (2A5,2I)
32000		DO 31 I=1,M
32100		ISUB=(I-1)*N
32200	31	WRITE (ITYCH,165) (AO(ISUB+J),J=1,N)
32300		WRITE (ITYCH,165) (BO(J),J=1,N)
32400	165	FORMAT (20I)
32500		MM1=M-1
32600		WRITE (IRP,1000) IDL,IDR,MM1,N
32700	C	ADD THE SUPPLEMENTARY CONSTRAINT,DETERMINE THE INITIAL
32800	C	PARTIAL SOULUTION
32900		CALL DEVCHG ('DSK',INP)
33000		VNEG=-1
33100		DO 40 J=1,N
33200		X(J)=2
33300		IF (A(J).LT.0.) VNEG=VNEG+A(J)
33400	40	CONTINUE
33500		B(1)=VNEG
33600		V=VNEG
33700	50	DO 60 I=1,M
33800	60	IND(I)=0
33900	C	EXAMINE THE CURRENT SYSTEM OF CONSTRAINTS
34000	70	IF (NSEE.NE.0) GOTO 75
34100		WRITE (IRP,71) NI
34200	71	FORMAT(1X,//,1X,'ITER. # ',I2,15X,'CURRENT SYSTEM'//)
34300		KB=0
34400		DO 74 I=1,M
34500		KB=KB+1
34600		ISUB=(I-1)*N
34700		WRITE (IRP,73) (A(ISUB+J),J=1,N),B(KB)
34800	73	FORMAT (11X,12(I5,2X)/)
34900	74	CONTINUE
35000	75	DO 80 I=1,M
35100	80	B1(I)=B(I)
35200		NI=NI+1
35300		ITEST=1
35400		DO 110 I=1,M
35500		S1(I)=0
35600		IF (IND(I).EQ.1) GO TO 110
35700		ISUB=(I-1)*N
35800		DO  90 J=1,N
35900		IF (A(ISUB+J).LT.0) B1(I)=B1(I)-A(ISUB+J)
36000	90	S1(I)=S1(I)+IABS(A(ISUB+J))
36100		IF (B1(I).LE.0) GO TO 100
36200		ITEST=0
36300		GO TO 110
36400	100	IND(I)=1
36500	110	CONTINUE
36600		IF (ITEST.EQ.1) GO TO 420
36700	C	THE SUSTEM CONTAINS AT LEAST ONE IRREDUNDANT INEQUALITY
36800		DO 120 I=1,M
36900		IF (IND(I).EQ.1) GO TO 120
37000		IF (S1(I)-B1(I).LT.0) GO TO 560
37100	120	CONTINUE
37200	C	THE SYSTEM DOES NOT CONTAIN ANY INCONSISTENT INEQUALITY
37300	C	CONSIDER EACH INEQUALITY SEPARATELY
37400		I=1
37500	130	IF (IND(I).EQ.1) GO TO 360
37600		IF (S1(I)-B1(I).GT.0) GO TO 200
37700	C	SOME OF THE FREE VARIABLES ARE FORCED TO CERTAIN FIXED
37800	C	VALUES
37900	140	KK=(I-1)*N
38000		DO 190 J=1,N
38100		ISUB=KK+J
38200		IF (A(ISUB).EQ.0) GO TO 190
38300		NS=NS+1
38400		BC(NS)=1
38500		IF (A(ISUB).LT.0) GO TO 160
38600		S(NS)=J
38700		X(J)=1
38800		DO 150 IJ=1,M
38900		ISUB=(IJ-1)*N+J
39000	150	B(IJ)=B(IJ)-A(ISUB)
39100		GO TO 170
39200	160	S(NS)=-J
39300		X(J)=0
39400	170	DO 180 IJ=1,M
39500		ISUB=(IJ-1)*N+J
39600	180	A(ISUB)=0
39700	190	CONTINUE
39800		GO TO 70
39900	200	KK=(I-1)*N
40000		DO 210	J=1,N
40100		ISUB=KK+J
40200	210	C(J)=IABS(A(ISUB))
40300		L1=1
40400	220	J=L1+1
40500	230	IF (C(L1).GE.C(J)) GO TO 240
40600		IP=C(L1)
40700		C(L1)=C(J)
40800		C(J)=IP
40900	240	J=J+1
41000		IF (J.GT.N) GO TO 250
41100		GO TO 230
41200	250	L1=L1+1
41300		IF (L1.LT.N) GO TO 220
41400	260	IF (C(L1).GT.0) GO TO 270
41500		L1=L1-1
41600		GO TO 260
41700	270	IF (S1(I)-C(L1).LT.B1(I)) GO TO 140
41800		IF (S1(I)-C(1)-B1(I).GE.0) GO TO 360
41900	C	ONE FREE VARIABLE IS FORCED TO A CERTAIN FIXED VALUE
42000		NS=NS+1
42100		BC(NS)=1
42200	280	KK=(I-1)*N
42300		DO 290 J=1,N
42400		ISUB=KK+J
42500		IF (IABS(A(ISUB)).EQ.C(1)) GO TO 300
42600	290	CONTINUE
42700	300	ISUB=KK+J
42800		IF (A(ISUB).LT.0) GO TO 330
42900	310	S(NS)=J
43000		X(J)=1
43100		DO 320	IJ=1,M
43200		ISUB=(IJ-1)*N+J
43300	320	B(IJ)=B(IJ)-A(ISUB)
43400		GO TO 340
43500	330	S(NS)=-J
43600		X(J)=0
43700	340	DO 350	IJ=1,M
43800		ISUB=(IJ-1)*N+J
43900	350	A(ISUB)=0
44000		GO TO 70
44100	360	I=I+1
44200		IF (I.LE.M) GO TO 130
44300		IF (NS.EQ.N) GO TO 480
44400	C	FIND A NEW BRANCHING POINT
44500		DO 370 J=1,N
44600	370	C(J)=IABS(A(J))
44700		DO 380	J=2,N
44800		IF (C(1).GE.C(J)) GO TO 380
44900		C(1)=C(J)
45000	380	CONTINUE
45100		IF (C(1).EQ.0) GO TO 390
45200		NS=NS+1
45300		BC(NS)=0
45400		I=1
45500		GO TO 280
45600	390	DO 410 J=1,N
45700		DO 400 J1=1,NS
45800		IF (J.EQ.IABS(S(J1))) GO TO 410
45900	400	CONTINUE
46000		NS=NS+1
46100		BC(NS)=0
46200		GO TO 310
46300	410	CONTINUE
46400	C	THE SYSTEM OF CONSTRAINTS IS REDUNDANT. SOLVE AN
46500	C	UNCONSTRAINED ROBLEM.
46600	420	DO  470 J=1,N
46700		IF (NS.EQ.N) GO TO 480
46800		IF ((X(J).NE.2).OR.(A(J).EQ.0)) GO TO 470
46900		NS=NS+1
47000		BC(NS)=1
47100		IF (A(J).LT.0) GO TO 440
47200		S(NS)=J
47300		X(J)=1
47400		DO 430 I=1,M
47500		ISUB=(I-1)*N+J
47600	430	B(I)=B(I)-A(ISUB)
47700		GO TO 450
47800	440	S(NS)=-J
47900		X(J)=0
48000	450	DO 460 I=1,M
48100		ISUB=(I-1)*N+J
48200	460	A(ISUB)=0
48300	470	CONTINUE
48400	C	FIND THE NEW VALUE OF THE OBJECTIVE FUNCTION
48500	C	ADJUST THE ACCELERATING TEST AEQUEANCE T.
48600	480	NEWV=0
48700		DO 490 J=1,N
48800	490	NEWV=NEWV+X(J)*AO(J)
48900		DO 500 J=1,NS
49000		K=NS+1-J
49100		IF (BC(K).EQ.0) T(K)=1
49200	500	CONTINUE
49300		IF (NEWV.GT.V) GO TO 510
49400		NOPT=NOPT+1
49500		IF (NOPT.LE.NEST) GO TO 540
49600	C	THE ESTIMATED FIRST DIMENSION OF THE ARRAY OPTS IS
49700	C	EXCEEDED
49800		NESTEX=1
49900		WRITE (IRP,501)
50000	501	FORMAT (1X,'ESTIMATED # OF MAXIMIZING POINTS IS ',
50100	     *'EXCEEDED!'//)
50200		GO TO 800
50300	C	THE NEW SOLUTION FOUNDGIVES A BETTER VALUE TO THE
50400	C	OBJECTIVE FUNCTION. CHANGE THE SUPPLEMENTARY CONSTRAINT.
50500	510	NOPT=1
50600		V=NEWV
50700		B(1)=V
50800		DO 520 J=1,N
50900		IF (X(J).NE.1) GO TO 520
51000		B(1)=B(1)-AO(J)
51100	520	CONTINUE
51200		DO 530	J=1,N
51300	530	SO(J)=S(J)
51400	C	MODIFY THE SET OPTS
51500	540	DO 550 J=1,N
51600		ISUB=(NOPT-1)*N+J
51700	550	OPTS(ISUB)=X(J)
51800	560	IF (NS.EQ.0) GO TO 580
51900	C	QUESTION IF A BACKTRACKING IS POSSIBLE
52000		IS=0
52100		DO 570 J=1,NS
52200	570	IS=IS+BC(J)
52300		IF (IS.LT.NS) GO TO 600
52400		IF (V.GT.VNEG) GO TO 590
52500	C	THE SYSTEM OF CONSTRAINTS IS INCONSISTENT. NO SOLUTIONS
52600	580	INC=1
52700		WRITE (IRP,581)
52800	581	FORMAT (1X,'SYSTEM OF CONSTRAINTS IS INCONSISTENT.'/,1X,'
52900	     *NO FEASIBLE SOLUTION'//)
53000		GO TO 800
53100	C	THE GIVEN PROBLEM HAS A SOLUTION. ALL THE SOLUTIONS HAVE
53200	C	BENN FOUND
53300	590	V=V+BO(1)
53400		WRITE (IRP,591)
53500	591	FORMAT (1X,//,1X,'ALL SOL. HAVE BEEN FOUND'//)
53600		GO TO 800
53700	C	THE BACKTRACKING IS POSSIBLE
53800	600	DO 610 J1=1,NS
53900		K=NS+1-J1
54000		IF (BC(K).EQ.0) GO TO 620
54100	610	CONTINUE
54200	620	IF (T(K).EQ.1) GO TO 750
54300	C	BACKTRACKING
54400	630	DO 740 J1=K,NS
54500		DO 640 J=1,N
54600		IF (J.EQ.IABS(S(J1))) GO TO 650
54700	640	CONTINUE
54800	650	IF (K.EQ.J1) GO TO 700
54900		IF (X(J).EQ.1) GO TO 670
55000		DO 660	I=1,M
55100		ISUB=(I-1)*N+J
55200	660	A(ISUB)=AO(ISUB)
55300		GO TO 690
55400	670	DO 680 I=1,M
55500		ISUB=(I-1)*N+J
55600		A(ISUB)=AO(ISUB)
55700	680	B(I)=B(I)+A(ISUB)
55800	690	X(J)=2
55900		GO TO 740
56000	700	S(K)=-S(K)
56100		BC(K)=1
56200		X(J)=1-X(J)
56300		IF (X(J).EQ.0) GO TO 720
56400		DO 710 I=1,M
56500		ISUB=(I-1)*N+J
56600	710	B(I)=B(I)-AO(ISUB)
56700		GO TO 740
56800	720	DO 730 I=1,M
56900		ISUB=(I-1)*N+J
57000	730	B(I)=B(I)+AO(ISUB)
57100	740	CONTINUE
57200		NS=K
57300		GO TO 50
57400	C	THE ACCELERATING TEST
57500	750	T(K)=0
57600		IT1=0
57700		IT2=0
57800		DO 790 J1=K,N
57900		DO 760 J=1,N
58000		IF (J.EQ.IABS(SO(J1))) GO TO 770
58100	760	CONTINUE
58200	770	IF (K.EQ.J1) GO TO 780
58300		IF (((X(J).EQ.0).AND.(AO(J).GT.0)).OR.
58400	     * ((X(J).EQ.1).AND.(AO(J).LT.0)))IT2=IT2+
58500	     * IABS(AO(J))
58600		GOTO 790
58700	780	IT1=IABS(AO(J))
58800	790	CONTINUE
58900		IF (IT1.LE.IT2) GO TO 630
59000	C	THE APPLICATION OF THE ACCELERAITING TEST WAS SUCCESSFUL
59100		BC(K)=1
59200		NAT=NAT+1
59300		GO TO 560
59400	800		IF (NSEE.NE.0) GOTO 8066
59500		WRITE (IRP,801)
59600	801	FORMAT (26X,'FINAL SYSTEM'//)
59700		KB=0
59800		DO 802	I=1,M
59900		KB=KB+1
60000		ISUB=(I-1)*N
60100	802	WRITE  (IRP,73) (A(ISUB+J),J=1,N),B(KB)
60200		IF ((INC.EQ.1).OR.(NESTEX.EQ.1)) GO TO 11111
60300	8066	WRITE (IRP,806) V
60400	806	FORMAT (1X,//,1X,'MAX VALUE :',I/)
60500	807	WRITE(IRP,820)
60600	820	FORMAT(1X,'MAXIMIZING POINT(S):')
60700		DO 803 I=1,NEST
60800	803	WRITE(IRP,805)I,(OPTS(IJ),IJ=(I-1)*N+1,(I-1)*N+N)
60900	805	FORMAT(1X,I2,'***',(1X,I1,25(1X,I1)/))
61000	813	WRITE (IRP,808) NAT
61100	808	FORMAT (1X,'ACCELERATING TEST :',I4/)
61200	11111	CALL	RELEASE (INP)
61300		RETURN
61400		END