Trailing-Edge
-
PDP-10 Archives
-
decuslib20-05
-
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