Trailing-Edge
-
PDP-10 Archives
-
decuslib10-09
-
43,50466/zerone.f4
There are no other files named zerone.f4 in the archive.
C WESTERN MICHIGAN UNIVERSITY
C ZERONE.F4 (FILE NAME ON LIBRARY DECTAPE)
C ZERONE, 2.2.4 (CALLING NAME, SUBLST. NO.)
C 0-1 INTEGER PROGRAMMING
C THIS PROGRAM IS AN ADAPTATION OF "SOLUTION OF LINEAR
C PROGRAMMING IN 0-1 VARIABLES" FROM COMMUNICATIONS OF THE
C ACM, JULY 1973, VOL. 16, NUMBER 7, PAGES 445--447. THIS
C PROGRAM CONTAINS SUBSTANTIAL ADDITIONAL PROGRAMMING BY MR.
C J. GROESSER.
C REPRINTING PRIVILEGES WERE GRANTED BY PERMISSION OF THE
C ASSOCIATION FOR COMPUTING MACHINERY, BUT NOT FOR PROFIT.
C LIBRARY DECTAPE PROGS. USED: USAGE.MAC
C FORWMU PROGS. USED: ALLCOR, TTYPTY, DEVCHG, DEVICE,
C EXISTS, PRINTS
C APLIB PROGS. USED: IOB
C INTERNAL SUBR. USED: TEST
C ABOVE COMMENTS AND RIGHT ADJUSTED COMMENTS PUT IN BY WG
C
C
COMMON /IOBLK/IDLG,INT,INP,IRP,IDEV,IDEVA,ICODE,IC,NAMI(2)
COMMON /IOBLKA/NAMO(2),IPJ,IPG,NCOPYS,IAUX
COMMON IDL,IDR,INC,NESTEX,ITYCH,ITYPE,NSEE
DIMENSION B(1)
ITYCH=1
NSEE=0
INT=5
IDLG=-1
C---------------TTYPTY RETURNS ZERO - TTYJOB, MINUS ONE - BATCH JOB
CALL TTYPTY (ICODE)
IRP=2
CALL DEFINE FILE (ITYCH,0,NV,'LPRTMP',0,0)
INP=3
IDEV='DSK'
WRITE(IDLG,5001)
5001 FORMAT(1X,'WMU 0-1 PROGRAMMING',/)
C CALL USAGE('ZERONE')
C---------------1 MEANS OUTPUT? PRINTS. IDLG, INT, IRP, IDEV,
C--------------- ICODE ARE INPUT AND NAMI(2), IC ARE
C--------------- RETURNED THRU COMMON /IOBLK/
CALL IOB(1)
13 CALL DEVCHG (IDEV,INP)
CALL IOB(0)
REWIND (ITYCH)
99 WRITE (IDLG,5000)
5000 FORMAT (' ','TYPE 1ST CONTROL LINE'/)
READ(INT,9901,END=7999)ITYPE,IDL,IDR,IEQNS,INBVS
9901 FORMAT(3A5,2I,A5)
IF (ITYPE.EQ.'ALTER') GO TO 5013
WRITE (IDLG,2)
2 FORMAT (1X,'ENTER # OF INEQUALITIES AND UNKNOWNS',
1 ' SEPARATED BY A COMMA.'/)
READ (INT,3) IEQNS,INBVS
3 FORMAT (2I)
4 IF(ITYPE.EQ.'PROB-') GO TO 117
CALL DEVICE (INT)
GO TO 99
5013 READ (ITYCH,9903,END=7999) DUM1,DUM2,IEQNS,INBVS
9903 FORMAT (2A5,2I)
IEQNS=IEQNS-1
WRITE (IDLG,5014)
5014 FORMAT (1X,'ENTER OUTPUT HEADER(10 CHARACTERS MAXIMUM)'/)
READ (INT,9902) IDL,IDR
9902 FORMAT (2A5)
117 WRITE (IDLG,129)
129 FORMAT (1X,'ESTIMATED # OF MAXIMIZING POINTS? '$)
READ (INT,130) MOPT
130 FORMAT (I)
M=IEQNS+1
N=INBVS
MN=M*N
MAX=(M*N)*2+5*M+6*N+MOPT*N
C---------------MAX IS INPUT
CALL ALLCOR(MAX,IERR,I1,B)
IF(IERR.EQ.0) GO TO 126
WRITE(IDLG,5)
5 FORMAT(1X,'NOT ABLE TO ALLOCATE CORE'/)
GO TO 99
126 WRITE (IDLG,127)
127 FORMAT (1X,'DO WANT TO SEE CURRENT SYSTEM AT EACH ITERATION?',
1 '(YES OR NO) '$)
READ (INT,128) JSEE
128 FORMAT (A3)
IF (JSEE.NE.'YES') NSEE=1
I2=I1+M*N
I3=I2+M*N
I4=I3+M
I5=I4+M
I6=I5+M
I7=I6+M
I8=I7+N
I9=I8+N
I10=I9+N
I11=I10+N
I12=I11+N
I13=I12+N
I14=I13+M
CALL TEST(M,N,MOPT,MN,B(I1),B(I2),B(I3),B(I4),B(I5),
1B(I6),B(I7),B(I8),B(I9),B(I10),B(I11),B(I12),B(I13),B(I14))
GO TO 13
7999 CALL EXIT
END
C ZERO-ONE LINEAR PROGRAMMING
C INITIAL DATE 4/24/74
C THIS PROGRAM WAS TAKEN FROM THE JULY,1973 ISSUE OF THE
C "COMMUNICATIONS OF THE ACM". IT WAS MODIFIED TO ACCEPT OUR
C LIBRARY SUBROUTINES AND OUTPUT FORMAT BY JERRY GROESSER.
C SUBROUTINE IO WAS WRITTEN BY MR. SAM ANEMA.
C THE FOLLOWING SUBROUTINES(MACRO) WERE WRITTEN BY MR. NORM GRANT.
C SUBROUTINES USED DEVICE RETURNS CONTROL TO INSTRUCTION FOLLOWING
C IF JOB ON TELETYPE. CALLS EXIT IF JOB IS
C BATCH.
C TTYPTY RETURNS -1 IF JOB IS ON BATCH AND 0 IF J
C ON TELETYPE. HOWEVER THE RETURN ARGUMENT
C NOT USED.
C PRINTS PRINTING SUBROUTINE
C DEVCHG ASSOCIATES DSK,CDR,ETC. WITH LOGICAL DEV
C EXISTS CHECKS FOR EXISTENCE OF FILE.
C CLRUWP,ALLCOR,CALMYN--(DYNAMIC ALLOCATION OF MEM
C MO-DIMENSION OF CONSTRAINTS
C NO-DIMENSION OF VARIABLES
C NEST-ALTERNATIVE OPTIMAL SOLUTIONS
C M- # OF CONSTRAINTS PLUS SUPPLEMENTRY
C N- # OF VARIABLES
C AO- COEFFICIENTS OF CONSTRAINTS
C BO-TERMS OF THE COEFFICIENTS
C BO(1)- ABSOLUTE TERM OF THE OBJECTIVE FUNCTION
C A(MO,NO)- COEFFICIENTS OF THE CURRENT SYSTEM
C B(N)- RIGHT HAND TERMS OF THE CURRENT SYSTEM
C VNEG- SUM OF NEG COEFFICINETS IN OBJECTIVE FUNC. MINUS ONE
C ITEST = 1 SYSTEM OF CONSTRAINTS IS REDUNDENT
C =2 SYSTEM OF CONSTRAINTS IS NOT REDUNDENT
C IND- THE I-TH ELEMENT IS REDUNDENT OR NOT
C X- CURRENT PARTIAL SOLUTION. A FREE VAR. IS REPRESENTED
C BY COMPONET =2
C S- ORDER OF FIXED VAR.
C BC- BRANCHING NODE
C T- BRANCHING NODE AT WHICH ACCELERATING TEST CAN BE APPLIED
C NS- # OF COMPONETS IN S AND BC
C B1,S1,SO,C- ARE FOR AUXILLARY CHAR.
C INC=0 ESTIMATED # OF FEASIBLE SOL WAS NOT EXCEEDED
C =1 ESTIMATED # OF FEASIBLE SOL WAS EXCEEDED
C V= MAX VALUE OF OBJECTIVE FUNC.
C NOPT- # OF MAX POINTS
C OPTS- 1ST NOPT ROWS ALL MAX POINTS
C A COMPONET OF 2 SAYS THE VALUE OF THE CORRESPONDING
C VAR CAN BE ARBITARY
C NI- # OF ITERATIONS
C NAT- # OF OF SUCCESFUL APPLICATIONS OF ACCELERATING TEST
C---------------M, N, MOPT, MN ARE INPUT. MN IS USED IN ST. 1000 - 4.
C---------------FOR OTHER ARGS. SPACE IS RESERVED BY DYNAMIC ALLOC. SEE
C--------------- MAIN PROG. ST. 7999-2,3.
C---------------IDLG, INT, INP, IRP, IDEV ARE INPUT THRU COMMON
C--------------- /IOBLK/. IDL, IDR, INC, NEXTEX, ITYCH, ITYPE, NSEE
C--------------- ARE INPUT THRU COMMON.
SUBROUTINE TEST (M,N,MOPT,MN,AO,A,B,BO,B1,
*S1,C,X,S,SO,BC,T,IND,OPTS)
COMMON /IOBLK/IDLG,INT,INP,IRP,IDEV,IDEVA,ICODE,IC,NAMI(2)
COMMON /IOBLKA/ NAMO(2),IPJ,IPG,NCOPYS,IAUX
COMMON IDL,IDR,INC,NEXTEX,ITYCH,ITYPE,NSEE
INTEGER AO(MN),A(MN),BO(M),B(M),B1(M),
* S1(M),C(N),X(N),S(N),SO(N),BC(N),T(N),
* IND(M),V,VNEB,OPTS(MOPT)
DIMENSION LIGN (40),NGO(80),MGO(15),LGO(3),PAREN(40)
1000 FORMAT ('1',11X,'WESTERN MICHIGAN UNIVERISTY LINEAR ZERO-
*ONE RESULTS',//2X,'PROG. ID = ',2A5,5X,I3,2X,'CONSTRAINTS
* AND',1X,I3,2X,'UNKNOWNS'/)
INC=0
NEST=MOPT
NESTEX=0
NOPT=0
NS=0
NI=0
NAT=0
IALTER=1
NDAT=-1
NDATT=0
PROC=0
DO 10 J=1,N
10 T(J)=0
IF (ITYPE.EQ.'ALTER') GO TO 21
17 IF (IDEV.NE.'TTY') GO TO 1
IF (PROC.NE.0) GOTO 1
WRITE (IDLG,3)
PROC=1
3 FORMAT (1X,'TYPE IN DATA LINE(S).'/)
1 READ (INP,2) JTYPE
2 FORMAT (A5)
IF (JTYPE.EQ.'START') GO TO 33
IF (JTYPE.EQ.'COEFF') GO TO 11
IF (JTYPE.EQ.'B-VEC') GO TO 13
WRITE (IDLG,6) JTYPE,I
6 FORMAT(1X,'CARD',3X,A5,3X,I,3X,'NOT VALID'//)
CALL DEVICE (INT)
GO TO 17
C READ IN COEFFS. OF CONSTRAINTS
11 DO 12 I=1,M
ISUB=(I-1)*N
12 READ (INP,14) (AO(ISUB+J),J=1,N)
14 FORMAT (20I)
NDAT=NDAT+1
IF (NDAT) 17,17,33
C GET RIGHT TERMS OF CONST.
13 READ (INP,16) (BO(J),J=1,M)
16 FORMAT (20I)
NDAT=NDAT+1
IF (NDAT) 17,17,33
C COPY THE ARRAYS AO,BO
21 IF (IDEV.EQ.'TTY') GO TO 1016
NDATT=2
GOTO 1016
33 WRITE (IDLG,28)
28 FORMAT (1X,'DO YOU WANT TO ALTER DATA?(YES OR NO) '$)
READ (INT,29) OKK
29 FORMAT (A3)
IF (OKK.NE.'YES') GOTO 15
222 JSWICH=-2
22 WRITE (IDLG,23)
23 FORMAT (1X,'ENTER 1 FOR COEFF MATRIX',/1XT8,'2 FOR B-VECTOR',
1/,1X,T8,'3 FOR BOTH'/1XT8,'4 FOR NEITHER',/)
READ (INT,24) NCHNG
24 FORMAT (I1)
IF(JSWICH+NCHNG.EQ.2)GO TO 15
IF (JSWICH+NCHNG) 1004,1010,1004
1004 WRITE (IDLG,1005)
1005 FORMAT (1X,'ENTER I,J,NEW VALUE OF COEFF. MATRIX SEPARATED BY',
1 ' COMMAS(START IF NONE)',/)
10666 READ (INT,1013) NGO
1013 FORMAT (80A1)
IF ((NGO(1).EQ.'S').AND.(NGO(2).EQ.'T').AND.(NGO(3).EQ.'A')
1.AND.(NGO(4).EQ.'R').AND.(NGO(5).EQ.'T')) GOTO 1007
LGO(1)=0
LGO(2)=0
LGO(3)=0
IGO=1
DO 1014 KKK=1,3
DO 10144 KGO=1,15
10144 MGO(KGO)=' '
JJGO=1
10145 IF (NGO(IGO).EQ.',') GOTO 10148
IF (NGO(IGO).EQ.' ') GOTO 10148
IF ((NGO(IGO).LE.'9').AND.(NGO(IGO).GE.'0')) GOTO 10146
WRITE (5,20145)
20145 FORMAT (1X,'ERROR CODE'/)
GOTO 1004
10146 IF (JJGO.GT.15) GOTO 10147
MGO(JJGO)=NGO(IGO)
JJGO=JJGO+1
10147 IGO=IGO+1
GOTO 10145
10148 IGO=IGO+1
10149 IF (MGO(15).NE.' ') GOTO 10451
DO 10452 JJGO=15,2,-1
10452 MGO(JJGO)=MGO(JJGO-1)
MGO(1)=' '
GOTO 10149
10451 ENCODE (15,1013,LLGO),MGO
DECODE (15,10456,LLGO) LGO(KKK)
10456 FORMAT (I15)
1014 CONTINUE
ISUB=(LGO(1)-1)*M+LGO(2)
AO(ISUB)=LGO(3)
GO TO 10666
1007 IF (NCHNG+JSWICH) 15,1010,1010
1010 WRITE (IDLG,1011)
1011 FORMAT (1X,'ENTER I AND NEW VALUE OF B-VECTOR SEPARATED BY',
1 ' A COMMA(START IF NONE)',/)
1015 READ (INT,1013)NGO
IF ((NGO(1).EQ.'S').AND.(NGO(2).EQ.'T').AND.(NGO(3).EQ.'A')
1.AND.(NGO(4).EQ.'R').AND.(NGO(5).EQ.'T')) GOTO 15
LGO(1)=0
LGO(2)=0
IGO=1
DO 1012 KKK=1,2
DO 10121 KGO=1,10
10121 MGO(KGO)=' '
JJGO=1
10122 IF (NGO(IGO).EQ.',') GOTO 10125
IF (NGO(IGO).EQ.' ') GOTO 10125
IF((NGO(IGO).LE.'9').AND.(NGO(IGO).GE.'0')) GOTO 10123
PAUSE
10123 IF (JJGO.GT.10) GOTO 10124
MGO(JJGO)=NGO(IGO)
JJGO=JJGO+1
10124 IGO=IGO+1
GOTO 10122
10125 IGO=IGO+1
10126 IF (MGO(10).NE.' ') GOTO 10128
DO 10127 JJGO=10,2,-1
10127 MGO(JJGO)=MGO(JJGO-1)
MGO(1)=' '
GOTO 10126
10128 ENCODE (10,1013,LLGO) (MGO(JJGO),JJGO=1,10)
DECODE (10,10457,LLGO) LGO(KKK)
10457 FORMAT (I10)
1012 CONTINUE
BO(LGO(1))=LGO(2)
GO TO 1015
1016 CALL RELEASE (INP)
DO 34 I=1,M
ISUB=(I-1)*N
34 READ (ITYCH,14) (AO(ISUB+J),J=1,N)
READ (ITYCH,14) (BO(J),J=1,N)
CALL RELEASE (ITYCH)
IF (ITYPE.EQ.'ALTER') CALL DEVCHG('TTY',INP)
GOTO 222
15 WRITE (IDLG,5)
5 FORMAT (1X,'DATA BEING PROCESSED'/)
DO 30 I=1,M
B(I)=BO(I)
KK=(I-1)*N
DO 20 J=1,N
ISUB=KK+J
20 A(ISUB)=AO(ISUB)
30 CONTINUE
CALL RELEASE (INP)
REWIND (ITYCH)
WRITE (ITYCH,9901) IDL,IDR,M,N
9901 FORMAT (2A5,2I)
DO 31 I=1,M
ISUB=(I-1)*N
31 WRITE (ITYCH,165) (AO(ISUB+J),J=1,N)
WRITE (ITYCH,165) (BO(J),J=1,N)
165 FORMAT (20I)
MM1=M-1
WRITE (IRP,1000) IDL,IDR,MM1,N
C ADD THE SUPPLEMENTARY CONSTRAINT,DETERMINE THE INITIAL
C PARTIAL SOULUTION
CALL DEVCHG ('DSK',INP)
VNEG=-1
DO 40 J=1,N
X(J)=2
IF (A(J).LT.0.) VNEG=VNEG+A(J)
40 CONTINUE
B(1)=VNEG
V=VNEG
50 DO 60 I=1,M
60 IND(I)=0
C EXAMINE THE CURRENT SYSTEM OF CONSTRAINTS
70 IF (NSEE.NE.0) GOTO 75
WRITE (IRP,71) NI
71 FORMAT(1X,//,1X,'ITER. # ',I2,15X,'CURRENT SYSTEM'//)
KB=0
DO 74 I=1,M
KB=KB+1
ISUB=(I-1)*N
WRITE (IRP,73) (A(ISUB+J),J=1,N),B(KB)
73 FORMAT (11X,12(I5,2X)/)
74 CONTINUE
75 DO 80 I=1,M
80 B1(I)=B(I)
NI=NI+1
ITEST=1
DO 110 I=1,M
S1(I)=0
IF (IND(I).EQ.1) GO TO 110
ISUB=(I-1)*N
DO 90 J=1,N
IF (A(ISUB+J).LT.0) B1(I)=B1(I)-A(ISUB+J)
90 S1(I)=S1(I)+IABS(A(ISUB+J))
IF (B1(I).LE.0) GO TO 100
ITEST=0
GO TO 110
100 IND(I)=1
110 CONTINUE
IF (ITEST.EQ.1) GO TO 420
C THE SUSTEM CONTAINS AT LEAST ONE IRREDUNDANT INEQUALITY
DO 120 I=1,M
IF (IND(I).EQ.1) GO TO 120
IF (S1(I)-B1(I).LT.0) GO TO 560
120 CONTINUE
C THE SYSTEM DOES NOT CONTAIN ANY INCONSISTENT INEQUALITY
C CONSIDER EACH INEQUALITY SEPARATELY
I=1
130 IF (IND(I).EQ.1) GO TO 360
IF (S1(I)-B1(I).GT.0) GO TO 200
C SOME OF THE FREE VARIABLES ARE FORCED TO CERTAIN FIXED
C VALUES
140 KK=(I-1)*N
DO 190 J=1,N
ISUB=KK+J
IF (A(ISUB).EQ.0) GO TO 190
NS=NS+1
BC(NS)=1
IF (A(ISUB).LT.0) GO TO 160
S(NS)=J
X(J)=1
DO 150 IJ=1,M
ISUB=(IJ-1)*N+J
150 B(IJ)=B(IJ)-A(ISUB)
GO TO 170
160 S(NS)=-J
X(J)=0
170 DO 180 IJ=1,M
ISUB=(IJ-1)*N+J
180 A(ISUB)=0
190 CONTINUE
GO TO 70
200 KK=(I-1)*N
DO 210 J=1,N
ISUB=KK+J
210 C(J)=IABS(A(ISUB))
L1=1
220 J=L1+1
230 IF (C(L1).GE.C(J)) GO TO 240
IP=C(L1)
C(L1)=C(J)
C(J)=IP
240 J=J+1
IF (J.GT.N) GO TO 250
GO TO 230
250 L1=L1+1
IF (L1.LT.N) GO TO 220
260 IF (C(L1).GT.0) GO TO 270
L1=L1-1
GO TO 260
270 IF (S1(I)-C(L1).LT.B1(I)) GO TO 140
IF (S1(I)-C(1)-B1(I).GE.0) GO TO 360
C ONE FREE VARIABLE IS FORCED TO A CERTAIN FIXED VALUE
NS=NS+1
BC(NS)=1
280 KK=(I-1)*N
DO 290 J=1,N
ISUB=KK+J
IF (IABS(A(ISUB)).EQ.C(1)) GO TO 300
290 CONTINUE
300 ISUB=KK+J
IF (A(ISUB).LT.0) GO TO 330
310 S(NS)=J
X(J)=1
DO 320 IJ=1,M
ISUB=(IJ-1)*N+J
320 B(IJ)=B(IJ)-A(ISUB)
GO TO 340
330 S(NS)=-J
X(J)=0
340 DO 350 IJ=1,M
ISUB=(IJ-1)*N+J
350 A(ISUB)=0
GO TO 70
360 I=I+1
IF (I.LE.M) GO TO 130
IF (NS.EQ.N) GO TO 480
C FIND A NEW BRANCHING POINT
DO 370 J=1,N
370 C(J)=IABS(A(J))
DO 380 J=2,N
IF (C(1).GE.C(J)) GO TO 380
C(1)=C(J)
380 CONTINUE
IF (C(1).EQ.0) GO TO 390
NS=NS+1
BC(NS)=0
I=1
GO TO 280
390 DO 410 J=1,N
DO 400 J1=1,NS
IF (J.EQ.IABS(S(J1))) GO TO 410
400 CONTINUE
NS=NS+1
BC(NS)=0
GO TO 310
410 CONTINUE
C THE SYSTEM OF CONSTRAINTS IS REDUNDANT. SOLVE AN
C UNCONSTRAINED ROBLEM.
420 DO 470 J=1,N
IF (NS.EQ.N) GO TO 480
IF ((X(J).NE.2).OR.(A(J).EQ.0)) GO TO 470
NS=NS+1
BC(NS)=1
IF (A(J).LT.0) GO TO 440
S(NS)=J
X(J)=1
DO 430 I=1,M
ISUB=(I-1)*N+J
430 B(I)=B(I)-A(ISUB)
GO TO 450
440 S(NS)=-J
X(J)=0
450 DO 460 I=1,M
ISUB=(I-1)*N+J
460 A(ISUB)=0
470 CONTINUE
C FIND THE NEW VALUE OF THE OBJECTIVE FUNCTION
C ADJUST THE ACCELERATING TEST AEQUEANCE T.
480 NEWV=0
DO 490 J=1,N
490 NEWV=NEWV+X(J)*AO(J)
DO 500 J=1,NS
K=NS+1-J
IF (BC(K).EQ.0) T(K)=1
500 CONTINUE
IF (NEWV.GT.V) GO TO 510
NOPT=NOPT+1
IF (NOPT.LE.NEST) GO TO 540
C THE ESTIMATED FIRST DIMENSION OF THE ARRAY OPTS IS
C EXCEEDED
NESTEX=1
WRITE (IRP,501)
501 FORMAT (1X,'ESTIMATED # OF MAXIMIZING POINTS IS ',
*'EXCEEDED!'//)
GO TO 800
C THE NEW SOLUTION FOUNDGIVES A BETTER VALUE TO THE
C OBJECTIVE FUNCTION. CHANGE THE SUPPLEMENTARY CONSTRAINT.
510 NOPT=1
V=NEWV
B(1)=V
DO 520 J=1,N
IF (X(J).NE.1) GO TO 520
B(1)=B(1)-AO(J)
520 CONTINUE
DO 530 J=1,N
530 SO(J)=S(J)
C MODIFY THE SET OPTS
540 DO 550 J=1,N
ISUB=(NOPT-1)*N+J
550 OPTS(ISUB)=X(J)
560 IF (NS.EQ.0) GO TO 580
C QUESTION IF A BACKTRACKING IS POSSIBLE
IS=0
DO 570 J=1,NS
570 IS=IS+BC(J)
IF (IS.LT.NS) GO TO 600
IF (V.GT.VNEG) GO TO 590
C THE SYSTEM OF CONSTRAINTS IS INCONSISTENT. NO SOLUTIONS
580 INC=1
WRITE (IRP,581)
581 FORMAT (1X,'SYSTEM OF CONSTRAINTS IS INCONSISTENT.'/,1X,'
*NO FEASIBLE SOLUTION'//)
GO TO 800
C THE GIVEN PROBLEM HAS A SOLUTION. ALL THE SOLUTIONS HAVE
C BENN FOUND
590 V=V+BO(1)
WRITE (IRP,591)
591 FORMAT (1X,//,1X,'ALL SOL. HAVE BEEN FOUND'//)
GO TO 800
C THE BACKTRACKING IS POSSIBLE
600 DO 610 J1=1,NS
K=NS+1-J1
IF (BC(K).EQ.0) GO TO 620
610 CONTINUE
620 IF (T(K).EQ.1) GO TO 750
C BACKTRACKING
630 DO 740 J1=K,NS
DO 640 J=1,N
IF (J.EQ.IABS(S(J1))) GO TO 650
640 CONTINUE
650 IF (K.EQ.J1) GO TO 700
IF (X(J).EQ.1) GO TO 670
DO 660 I=1,M
ISUB=(I-1)*N+J
660 A(ISUB)=AO(ISUB)
GO TO 690
670 DO 680 I=1,M
ISUB=(I-1)*N+J
A(ISUB)=AO(ISUB)
680 B(I)=B(I)+A(ISUB)
690 X(J)=2
GO TO 740
700 S(K)=-S(K)
BC(K)=1
X(J)=1-X(J)
IF (X(J).EQ.0) GO TO 720
DO 710 I=1,M
ISUB=(I-1)*N+J
710 B(I)=B(I)-AO(ISUB)
GO TO 740
720 DO 730 I=1,M
ISUB=(I-1)*N+J
730 B(I)=B(I)+AO(ISUB)
740 CONTINUE
NS=K
GO TO 50
C THE ACCELERATING TEST
750 T(K)=0
IT1=0
IT2=0
DO 790 J1=K,N
DO 760 J=1,N
IF (J.EQ.IABS(SO(J1))) GO TO 770
760 CONTINUE
770 IF (K.EQ.J1) GO TO 780
IF (((X(J).EQ.0).AND.(AO(J).GT.0)).OR.
* ((X(J).EQ.1).AND.(AO(J).LT.0)))IT2=IT2+
* IABS(AO(J))
GOTO 790
780 IT1=IABS(AO(J))
790 CONTINUE
IF (IT1.LE.IT2) GO TO 630
C THE APPLICATION OF THE ACCELERAITING TEST WAS SUCCESSFUL
BC(K)=1
NAT=NAT+1
GO TO 560
800 IF (NSEE.NE.0) GOTO 8066
WRITE (IRP,801)
801 FORMAT (26X,'FINAL SYSTEM'//)
KB=0
DO 802 I=1,M
KB=KB+1
ISUB=(I-1)*N
802 WRITE (IRP,73) (A(ISUB+J),J=1,N),B(KB)
IF ((INC.EQ.1).OR.(NESTEX.EQ.1)) GO TO 11111
8066 WRITE (IRP,806) V
806 FORMAT (1X,//,1X,'MAX VALUE :',I/)
807 WRITE(IRP,820)
820 FORMAT(1X,'MAXIMIZING POINT(S):')
DO 803 I=1,NEST
803 WRITE(IRP,805)I,(OPTS(IJ),IJ=(I-1)*N+1,(I-1)*N+N)
805 FORMAT(1X,I2,'***',(1X,I1,25(1X,I1)/))
813 WRITE (IRP,808) NAT
808 FORMAT (1X,'ACCELERATING TEST :',I4/)
11111 CALL RELEASE (INP)
RETURN
END