Trailing-Edge
-
PDP-10 Archives
-
decus_20tap5_198111
-
decus/20-0137/lpr/lpr.for
There is 1 other file named lpr.for in the archive. Click here to see a list.
C WESTERN MICHIGAN UNIVERSITY
C LPR.F4 (FILE NAME ON LIBRARY DECTAPE)
C LPR, 2.2.1 (CALLING NAME, SUBLST #)
C LINEAR PROGRAMMING
C THIS PROGRAM IS A COMBINATION OF ONE GIVEN BY WAYNE
C STATE UNIVERSITY (ORIGINALLY PROGRAMMED BY MR. HOOVER (IBM)
C WITH REVISIONAL AND ADDITIONAL PROGRAMMING BY B. GRANET AND
C R.R. BARR.
C FORWMU PROGS. USED: TTYPTY, ALLCOR, DEVCHG, EXISTS,
C DEVICE, TYPEON, PRINTS
C LIBRARY DECTAPE PROGS. USED: USAGE.MAC
C APLIB PROGS. USED: IOB
C INTERNAL SUBR. USED: MAIN
C ABOVE COMMENTS AND RIGHT ADJUSTED COMMENTS PUT IN BY WG
C
C THE FOLLOWING SUBROUTINES(MACRO) WERE WRITTEN BY MR. NORM GRANT.
C SUBROUTINES USED DEVICE RETURNS CONTROL TO INSTRUCTION FOLLOWING
C CALL IF JOB ON TELETYPE. CALLS EXIT IF
C JOB IS ON BATCH.
C TTYPTY RETURNS -1 IF JOB IS ON BATCH AND 0 IF
C JOB IS ON TELETYPE. HOWEVER THE RETURN
C ARGUMENT IS NOT USED.
C PRINTS PRINTING SUBROUTINE
C DEVCHG ASSOCIATES DSK,CDR,ETC. WITH LOGICAL
C DEVICE NO.
C EXISTS CHECKS FOR EXISTENCE OF FILE.
C CLRUWP,ALLCOR,CALMYN--(DYNAMIC ALLOCATION OF
C MEMORY.
C ALSO USED IS APPLICATIONS ROUTINE - USAGE(IN NGLIB)
C WHICH WAS WRITTEN BY MR. RUSS BARR.
C ***** SEGMENT ONE --- LOADER *****
C
C****AM,2.2.1,#2,WG,13-DEC-77
COMMON /IOBLK/IDLG,INT, INP,IRP,IDEV,IDEVA,IC,IB,NAMI(2)
C****END,MAIN PROG.,ST. 5001-10
COMMON /IOBLKA/NAMO(2),IPJ,IPG,NCOPYS,IAUX
COMMON ILONG,INBVS,KFUNC,IFRST,INVAL,INDEX,
1IWIDE,ILAST,IDL,IDR,IEQNS,ISLOT,MAX,ITYPE,ITYCH
DIMENSION Z(1)
ITYCH=1
INT=5
IDLG=-1
C---------------TTYPTY RETURNS ZERO - TTY JOB, MINUS ONE - BATCH JOB
C---------------IC PASSED TO IOB THRU COMMON /IOBLK/.
CALL TTYPTY(IC)
IRP=2
WRITE(IDLG,5001)
5001 FORMAT(1X,'WMU LINEAR PROGRAMMING',/)
C CALL USAGE('LPR')
IDEV='DSK'
C---------------ASSOCIATE TEMPORARY FILE NAME 'LPRTMP' WITH ITYCH
C--------------- SEE ST. 9901-1 IN SUBR. MAIN.
CALL DEFINE FILE(ITYCH,0,NV,'LPRTMP',0,0)
5006 INP=3
C---------------1 MEANS OUTPUT? PRINTS. 0 - INPUT? PRINTS.
C---------------THRU COMMON /IOBLK/IDLG, INT, IRP, IDEV, IC, INP,
C--------------- IDEVA, ARE INPUT. IB, NAMI, ARE RETURNED.
CALL IOB(1)
13 CALL DEVCHG(IDEV,INP)
CALL TYPEON
CALL IOB(0)
REWIND(ITYCH)
99 WRITE(IDLG,5000)
5000 FORMAT (' ','TYPE 1ST CONTROL LINE'/)
C---------------PROB-, 10 CHAR. ID ONLY IF USER FOLLOWS CURRENT
C--------------- WRITE UP. ALSO ENTER NO. OF INEQ., NO. OF VAR. IF
C--------------- USER FOLLOWS OLD WRITE UP.
READ(INT,9901,END=7999)ITYPE,IDL,IDR,IEQNS,INBVS
IF(ITYPE.EQ.'ALTER')GO TO 5013
IF(ITYPE.EQ.'PROB-')GO TO 4
CALL DEVICE(INT)
GO TO 99
C---------------CHECK WHETHER USER FOLLOWS NEW WRITE UP. THIS
C--------------- ASSUMES <CR> AFTER IDR CAUSES IEQNS=0.
4 IF(IEQNS.NE.0)GO TO 117
1 WRITE(IDLG,2)
2 FORMAT(1X,'ENTER NO. OF INEQUALITIES AND UNKNOWNS',
1' SEPARATED BY A COMMA.'/)
READ(INT,3)IEQNS,INBVS
GO TO 117
3 FORMAT(2I)
9901 FORMAT(3A5,2I,A5)
5013 READ(ITYCH,9901,END=7999)DUMMY,DUM1,DUM2,IEQNS,INBVS
117 ILONG = IEQNS + 4
KFUNC = 4 * ILONG + 4
IWIDE = ILONG * INBVS
ILAST = KFUNC + IWIDE
MAX=ILONG*(INBVS+5)
CALL ALLCOR(MAX,IERR,I1,Z)
IF(IERR.EQ.0) GO TO 126
WRITE(IDLG,5)
5 FORMAT(1X,'NOT ABLE TO ALLOCATE CORE'/)
GO TO 99
126 IFRST = KFUNC + ILONG
ISLOT = KFUNC - ILONG
CALL MAIN(Z(I1),Z(I1),Z(I1+1),Z(I1+2))
GO TO 13
7999 CALL EXIT
END
C---------------ALL ARGS. ARE SPACES RESERVED BY DYN. ALLOC.
SUBROUTINE MAIN(ARRAY,BMIN,RMAX,PIVOT)
DIMENSION ARRAY(1),TEMP(3),KKK(10)
COMMON /IOBLK/IDLG,INT, INP,IRP,IDEV,IDEVA,IB,IC,NAMI(2)
COMMON/IOBLKA/NAMO(2),IPJ,IPG,NCOPYS,IAUX
COMMON ILONG,INBVS,KFUNC,IFRST,INVAL,INDEX,
1IWIDE,ILAST,IDL,IDR,IEQNS,ISLOT,MAX,ITYPE,ITYCH
INTEGER EL
9902 FORMAT(28H1WESTERN MICHIGAN UNIVERSITY,19H LIN PROG RESULTS,
1///2X,'PROB. ID. =',2A5,5X,I3,'EQS. AND',I3, 'NON-BASIS VARS.'/)
104 DO 106 K = 1, MAX
106 ARRAY (K) = 0.0
20 EZERO = 1.0 E-8
INVAL = 0
INDEX = 0
IF(IDEV.EQ.'TTY'.AND.ITYPE.NE.'ALTER')GO TO 2
IF(ITYPE.EQ.'ALTER')GO TO 5016
1 WRITE(IDLG,3)
3 FORMAT(1X,'DATA BEING PROCESSED'/)
GO TO 5002
2 WRITE(IDLG,5001)
5001 FORMAT (' ','TYPE DATA LINES'/)
5002 DECODE(10,5003,NAMI)(KKK(I),I=1,10)
5003 FORMAT(10A1)
DO 5004 I=1,7
5004 IF(KKK(I).EQ.'.')GO TO 5005
GO TO 1300
C---------------CHECK WHETHER USER HAS EXTENSION = 'LPR'. IF
C--------------- SO USER WANTS MATRIX INPUT. SEE LAST 3 PAGES OF
C--------------- WRITE UP.
5005 IF(KKK(I+1).NE.'L'.OR.KKK(I+2).NE.'P'.OR.KKK(I+3).NE.'R')
1GO TO 1300
LK=KFUNC-3
LK1=LK+1
READ(INP,5007,END=5008)(ARRAY(J*ILONG+LK),ARRAY(J*ILONG+LK1)
2,J=1,INBVS)
EL=INBVS+IEQNS
LK=ISLOT-INBVS-2*ILONG
READ(INP,5007,END=5008)
1(ARRAY(J+LK),ARRAY(J+LK+ILONG),J=INBVS+1,EL)
LK=LK1+1
READ(INP,5009,END=5008)(ARRAY(J*ILONG+LK),J=1,INBVS)
LK=ISLOT-INBVS
READ(INP,5009,END=5008)(ARRAY(J+LK),J=INBVS+1,EL)
5007 FORMAT(5(2A5,1X))
READ(INP,5009)(ARRAY(KFUNC+I),I=1,IEQNS)
5009 FORMAT(5F)
DO 5010 I=1,IEQNS
LK=KFUNC+I
5010 READ(INP,5009)(ARRAY(J*ILONG+LK),J=1,INBVS)
5016 IF(IDEV.EQ.'TTY'.OR.ITYPE.EQ.'ALTER')WRITE(IDLG,5011)
5011 FORMAT(1X,'EITHER ENTER START OR MAKE ALTERATIONS.'/)
1300 IF(ITYPE.NE.'ALTER')GO TO 130
LK=KFUNC-3
LK1=LK+1
READ(ITYCH,5007,END=5008)(ARRAY(J*ILONG+LK),ARRAY(J*ILONG+LK1)
2,J=1,INBVS)
EL=INBVS+IEQNS
LK=ISLOT-INBVS-2*ILONG
READ(ITYCH,5007,END=5008)
1(ARRAY(J+LK),ARRAY(J+LK+ILONG),J=INBVS+1,EL)
LK=LK1+1
READ(ITYCH,5020,END=5008)(ARRAY(J*ILONG+LK),J=1,INBVS)
LK=ISLOT-INBVS
READ(ITYCH,5020,END=5008)(ARRAY(J+LK),J=INBVS+1,EL)
READ(ITYCH,5020,END=5008)(ARRAY(KFUNC+I),I=1,IEQNS)
DO 5015 I=1,IEQNS
LK=KFUNC+I
5015 READ(ITYCH,5020,END=5008)(ARRAY(J*ILONG+LK),J=1,INBVS)
CALL RELEAS(INP)
130 IF(ITYPE.EQ.'ALTER')CALL DEVCHG('TTY',INP)
C---------------IF USER CHOSE ALTER, USER NOW CHANGES ONE OR
C--------------- MORE VALUES OF TABLEAUX BEFORE RERUNNING.
READ(INP,9904,END=502,ERR=142)ITYPE,I,J,VALUE,VNAM1,VNAM2
5020 FORMAT(5E16.10)
9904 FORMAT(A5,2I,F,2A5)
IF(ITYPE.EQ.'START') GO TO 502
134 IF(ITYPE.EQ.'COST ') GO TO 202
138 IF(ITYPE.EQ.'ARRAY') GO TO 302
140 IF(ITYPE.EQ.'REQMT') GO TO 402
142 WRITE(IDLG ,9905)
9905 FORMAT(1H0,'ABOVE CARD INVALID - NOT LOADED'//)
CALL DEVICE(INT)
GO TO 130
5012 ITYCH=3
GO TO 130
6000 INVAL = INVAL + 1
6001 GO TO 130
202 IF (INBVS - J) 222, 204, 204
204 J4 = KFUNC + J * ILONG
ARRAY (J4 - 3) = VNAM1
ARRAY (J4 - 2) = VNAM2
ARRAY (J4 - 1) = VALUE
IF (VNAM1) 130, 214, 130
214 INDEX = INDEX + 1
GO TO 130
222 IF (INBVS + IEQNS - J) 142, 224, 224
224 J4 = ISLOT + J - INBVS
ARRAY (J4) = VALUE
J4 = J4 - ILONG
ARRAY (J4) = VNAM2
J4 =J4 - ILONG
ARRAY (J4) = VNAM1
IF (VNAM1) 130, 238, 130
238 INDEX = INDEX + 1
GO TO 130
302 IF ( IEQNS - I) 142, 304, 304
304 IF ( INBVS - J) 142, 306, 306
306 J1 = KFUNC + J * ILONG
J4 = J1 + I
ARRAY (J4) = VALUE
GO TO 130
402 IF (IEQNS - I) 142, 404, 404
404 J4 = KFUNC + I
ARRAY (J4) = VALUE
GO TO 130
C---------------HERE FROM ST. 9904+1
502 LK=KFUNC-3
LK1=LK+1
REWIND(ITYCH)
C---------------ALWAYS WRITE USERS INPUT TABLEAUX INTO TEMPORARY
C--------------- FILE CALLED 'LPRTMP' IN CASE USER WISHES TO USE
C--------------- ALTER FEATURE I.E. CHANGE ONE OR MORE ELS. OF
C--------------- TABLEAUX AND RERUN.
WRITE(ITYCH,9901)ITYPE,IDL,IDR,IEQNS,INBVS
9901 FORMAT(3A5,2I,A5)
WRITE(ITYCH,5007)(ARRAY(J*ILONG+LK),ARRAY(J*ILONG+LK1)
2,J=1,INBVS)
EL=INBVS+IEQNS
LK=ISLOT-INBVS-2*ILONG
WRITE(ITYCH,5007)
1(ARRAY(J+LK),ARRAY(J+LK+ILONG),J=INBVS+1,EL)
LK=LK1+1
WRITE(ITYCH,5020)(ARRAY(J*ILONG+LK),J=1,INBVS)
LK=ISLOT-INBVS
WRITE(ITYCH,5020)(ARRAY(J+LK),J=INBVS+1,EL)
WRITE(ITYCH,5020)(ARRAY(KFUNC+I),I=1,IEQNS)
DO 5014 I=1,IEQNS
LK=KFUNC+I
5014 WRITE(ITYCH,5020)(ARRAY(J*ILONG+LK),J=1,INBVS)
GO TO 1002
5008 CALL EXIT
9001 WRITE(IDLG ,9910)ITYPE,IDL,IDR,IEQNS,INBVS
RETURN
9910 FORMAT (1H 3A5,2(2X,I3),32H FOUND WHILE SEARCHING FOR PROB-
1 6H CARD )
9010 WRITE(IDLG ,9911)IEQNS,INBVS
9911 FORMAT (1H2 10X,I5,7H EQNS + I5,24H NBVS REQUIRES MORE STOR
13HAGE )
RETURN
C
C ***** SEGMENT TWO --- SHADOW PRICE CALCULATOR *****
C
1002 DO 1016 J4 = IFRST, ILAST, ILONG
IF (ARRAY (J4 - 1)) 1010, 1016, 1014
1010 ARRAY (J4) = ABS (ARRAY (J4 -1))
GO TO 1016
1014 ARRAY (J4) = - ARRAY (J4 - 1)
1016 CONTINUE
ARRAY (KFUNC) = 0.0
I1 = ISLOT + 1
I2 = ISLOT + IEQNS
I = 1
DO 1034 I4 = I1, I2
IF ( ARRAY (I4)) 1028, 1034, 1028
1028 DO 1032 J4 = KFUNC, ILAST, ILONG
J3 = J4 + I
1032 ARRAY (J4) = ARRAY (J4) + ARRAY (I4) * ARRAY (J3)
1034 I = I + 1
WRITE(IRP ,9902)IDL,IDR,IEQNS,INBVS
WRITE(IRP ,9912)
9912 FORMAT(1H0,10X,50(1H-)/19X,1HI,18X,1HI,14X,1HI/ 9X,10HITER. NO. ,
11HI,18H VALUE OF FUNCTION ,1HI,14H VARIABLE OUT ,1HI,' VAR. IN',
2 /19X,1HI,18X,1HI,14X,1HI/10X,9(1H-),1H+,18(1H-),1H+,14(1H-),1H+,
312(1H-)/19X,1HI,18X,1HI,14X,1HI)
ITER = 0
C
C ***** SEGMENT THREE --- DUAL ALGORITHM *****
C
1502 BMIN = 0.0
I1 = KFUNC +1
I2 = KFUNC + IEQNS
DO 1516 I4 = I1, I2
IF ( BMIN - ARRAY (I4)) 1516, 1516, 1512
1512 BMIN = ARRAY(I4)
KEYI = I4 - KFUNC
1516 CONTINUE
IF (BMIN) 1520, 2002, 2002
1520 RMAX = -1.0 E+30
KEYJ = 0
DO 1540 J4 = IFRST, ILAST, ILONG
K = J4 + KEYI
IF (ARRAY(K)) 1532, 1540, 1540
1532 RATIO = ARRAY (J4) / ARRAY (K)
IF (RMAX - RATIO) 1536, 1536, 1540
1536 RMAX = RATIO
KEYJ = J4
1540 CONTINUE
IF (KEYJ) 9022, 9022, 1544
1544 KEYC = KEYJ + KEYI
PIVOT = 1.0 / ARRAY (KEYC)
ARRAY (KEYC) = 0.0
I = 4
J2 = KEYJ + IEQNS
DO 1560 I4 = KEYJ, J2
ARRAY (I) = ARRAY (I4)
I = I + 1
1560 ARRAY (I4) = 0.0
ARRAY (KEYC) = 1.0
DO 1568 J4 = KFUNC, ILAST, ILONG
K = J4 + KEYI
1568 ARRAY (K) = ARRAY (K) * PIVOT
DO 1586 I4 = 4, ILONG
IF (ARRAY (I4)) 1576, 1586, 1576
1576 DO 1587 J4 = KFUNC, ILAST, ILONG
K = J4 + I4 - 4
KCORN = J4 + KEYI
ARRAY (K) = ARRAY (K) - ARRAY (KCORN) * ARRAY (I4)
IF (ABS (ARRAY (K))- EZERO) 1584, 1584, 1587
1584 ARRAY (K) = 0.0
1587 CONTINUE
1586 CONTINUE
ITER = ITER + 1
I3 = KEYJ-4
I4 = KEYI+4
DO 1600 I = 1, 3
N1 = I3 + I
TEMP(I) = ARRAY(N1)
N2 = I * ILONG + I4
ARRAY(N1) = ARRAY(N2)
1600 ARRAY(N2) = TEMP (I)
1612 WRITE(IRP ,9918)ITER,ARRAY (KFUNC),ARRAY
1 (KEYJ-3), ARRAY(KEYJ-2), TEMP (1), TEMP (2)
9918 FORMAT(13X,I3,3X,1HI,1X,G15.9,2X,1HI,2X,2A5,2X,1HI,2X,2A5)
GO TO 1502
9022 IF(IDEVA.NE.'TTY')WRITE(IRP,9913)
WRITE(IDLG ,9913)
9913 FORMAT (1H0,40HDUAL ALGOR. DETECTED INCONSISTENT MATRIX,
123HCHECK DATA AND RESUBMIT)
IFLG=1
GO TO 7006
C
C ***** SECTION FOUR --- SIMPLEX ALGORITHM *****
C
2002 DMIN = 0.0
DO 2014 J4 = IFRST, ILAST, ILONG
IF (ARRAY (J4) - DMIN) 2010,2014, 2014
2010 DMIN = ARRAY (J4)
KEYJ = J4
2014 CONTINUE
IF (DMIN) 2018, 3002, 3002
2018 RMIN = 1.0 E+30
I1 = KEYJ + 1
I2 = KEYJ + IEQNS
I = 1 + KFUNC
AKMAX = 0.0
DO 2044 I4 = I1, I2
IF (ARRAY (I4)) 2044,2044,2032
2032 RATIO = ARRAY (I) / ARRAY (I4)
IF (RATIO - RMIN) 2038,2036, 2044
2036 IF (ARRAY (I4) - AKMAX) 2044, 2044, 2038
2038 AKMAX = ARRAY (I4)
RMIN = RATIO
KEYI = I - KFUNC
2044 I = I + 1
IF (AKMAX) 2048, 9024, 2048
2048 KEYC = KEYJ + KEYI
PIVOT = 1.0 / ARRAY (KEYC)
ARRAY (KEYC) = 0.0
I = 4
J2 = KEYJ + IEQNS
DO 2064 I4 = KEYJ, J2
ARRAY (I) = ARRAY (I4)
I = I + 1
2064 ARRAY (I4) = 0.0
ARRAY (KEYC) = 1.0
DO 2070 J4 = KFUNC, ILAST, ILONG
K = J4 + KEYI
2070 ARRAY (K) = ARRAY (K) * PIVOT
DO 2092 I4 = 4, ILONG
IF (ARRAY(I4)) 2080,2092,2080
2080 DO 2093 J4 = KFUNC, ILAST, ILONG
K = J4 + I4 - 4
KCORN = J4 + KEYI
ARRAY (K) = ARRAY (K) - ARRAY (KCORN) * ARRAY (I4)
IF (ABS (ARRAY(K))- EZERO) 2090, 2090, 2093
2090 ARRAY (K) = 0.0
2093 CONTINUE
2092 CONTINUE
ITER = ITER + 1
I3 = KEYJ-4
I4 = KEYI+4
DO 2106 I = 1, 3
N1 = I3 + I
TEMP(I) = ARRAY(N1)
N2 = I * ILONG + I4
ARRAY(N1) = ARRAY(N2)
2106 ARRAY(N2) = TEMP(I)
2120 WRITE(IRP ,9918)ITER,ARRAY(KFUNC),ARRAY
1 (KEYJ-3), ARRAY(KEYJ-2), TEMP(1), TEMP (2)
GO TO 2002
9024 IF(IDEVA.NE.'TTY')WRITE(IRP,9916)
WRITE(IDLG ,9916)
9916 FORMAT(1H0,33HSIMPLEX ALGOR. DETECTED UNBOUNDED,
130HMATRIX CHECK DATA AND RESUBMIT)
IFLG=1
GO TO 7006
C
C ***** SECTION FIVE --- OUTPUT OF BASIS SOLUTION *****
C
3002 WRITE(IRP ,9922)
9922 FORMAT(19X,1HI,18X,1HI,14X,1HI/1X,71(1H-)///)
WRITE(IRP ,9923)ARRAY(KFUNC)
9923 FORMAT(34H0 MAXIMIZED VALUE OF FUNCTIONAL= G16.9//20X,22H**MAXIMI
1ZED SOLUTION**//1X,70(1H-)/11X,1HI,8X,1HI,8X,1HI,10X,1HI,8X,1HI,10
2X,1HI/' VAR. NAM. ',1HI,8HUNIT CST,1HI,8HNO UNITS,1HI,10HL.L. VAR.
3 ,1HI,8H LOW LIM,1HI,10HTOP L. VAR,1HI,10HTOP LIMIT /11X,1HI,
48X,1HI,8X,1HI,10X,1HI,8X,1HI,10X,1HI/1X,70(1H-))
DO 3052 I4 = 1, IEQNS
UPPER =-0.99999999 E+10
UNDER = 0.99999999 E+10
J1 = IFRST + 1
J2 = ILAST + 1
KEYJ1 = J1
KEYJ2 = J1
DO 3040 J4 = J1, J2, ILONG
K = I4 + J4 - 1
IF ( ARRAY(K)) 3022, 3040, 3022
3022 RATIO = ARRAY(J4-1) / ARRAY(K)
IF ( ARRAY(K)) 3034, 3040, 3026
3026 IF (RATIO - UNDER) 3028, 3028, 3040
3028 UNDER = RATIO
KEYJ1 = J4
GO TO 3040
3034 IF (RATIO - UPPER) 3040, 3036, 3036
3036 UPPER = RATIO
3038 KEYJ2= J4
3040 CONTINUE
ICOST = ISLOT + I4
UNLIM = ARRAY(ICOST) - UNDER
UPLIM = ARRAY(ICOST) - UPPER
INAM1 = I4 + ILONG + 4
IEND = ICOST + ILONG
3052 WRITE(IRP,9924)ARRAY(INAM1),ARRAY(INAM1+ILONG),
1ARRAY(KEYJ1-4),ARRAY(KEYJ1-3),ARRAY(KEYJ2-4),ARRAY(KEYJ2-3),
2ARRAY(INAM1+2*ILONG),ARRAY(IEND),UNLIM,UPLIM
9924 FORMAT(1X,2A5,19X,2A5,10X,2A5,/,
19X,G13.7,G12.7,6X,G13.7,5X,G13.7)
WRITE(IRP ,9925)
9925 FORMAT(1X,71(1H-))
C
C ***** SECTION SIX --- OUTPUT OF NON-BASIS SOLUTION *****
C
WRITE(IRP ,9926)
9926 FORMAT(1H0,5X,40H**DATA ON VARIABLES NOT APPEARING IN FIN,13HAL SO
1LUTION**//1X,70(1H-)/11X,1HI,8X,1HI,8X,1HI,10X,1HI,8X,1HI,10X,1HI/
21X,10H VAR. NAM.,1HI,8HUNIT CST,1HI,8HM UN CST,1HI,10HL.L. VAR. ,1
3HI,8H LOW LIM,1HI,10HTOP L. VAR,1HI, 9HTOP LIMIT/11X,1HI,8X,1HI,8X
4,1HI,10X,1HI,8X,1HI,10X,1HI/1X,70(1H-))
J1 = IFRST + 1
J2 = ILAST + 1
DO 4054 J4 = J1, J2, ILONG
UPPER = 0.99999999 E+10
UNDER =-0.99999999 E+10
KEYJ1 = 1
KEYJ2 = 1
I = KFUNC+1
DO 4036 I4 = 1, IEQNS
K = J4 + I4 - 1
IF (ARRAY(K)) 4018, 4036, 4018
4018 RATIO = ARRAY (I) / ARRAY(K)
IF (ARRAY(K))4022, 4036, 4030
4022 IF (RATIO - UNDER) 4036, 4024, 4024
4024 UNDER = RATIO
KEYJ1 = I4
GO TO 4036
4030 IF (RATIO - UPPER) 4032, 4032, 4036
4032 UPPER = RATIO
KEYJ2 = I4
4036 I = I + 1
INAM1 = KEYJ1 + ILONG + 4
INAM2 = INAM1 + ILONG
INAM3 = KEYJ2 + ILONG + 4
INAM4 = INAM3 + ILONG
4054 WRITE(IRP,9924)ARRAY(J4-4),ARRAY(J4-3),
1ARRAY(INAM1),ARRAY(INAM2),ARRAY(INAM3),ARRAY(INAM4),
2ARRAY(J4-2),ARRAY(J4-1),UNDER,UPPER
IFLG=0
WRITE(IRP ,9925)
C---------------END OF PRINTING OF ANSWERS.
7006 WRITE(IDLG,7000)
7000 FORMAT(1X,'ENTER 1 TO PRINT TABLEAUX,'/
11X,6X,'2 TO PRINT TABLEAUX ONLY IF FAILURE OCCURS',/
21X,'OTHERWISE ENTER ONLY RETURN.'/)
READ(INT,7001) ITABLO
7001 FORMAT(I)
C---------------ST. 7002 BELOW=RETURN. SINCE USER ENTERED 1
C--------------- AND IFLG=1 MEANS FAILURE OCCURRED, TABLEAUX
C--------------- WILL NOT PRINT AND NEXT PROMPTING IS INPUT? SEE
C--------------- ST. 9913+2 IN SEGMENT 3 AND 9916+2 IN SECTION 4.
IF(ITABLO.EQ.0) GO TO 7002
IF(ITABLO.EQ.1.AND.IFLG.EQ.1) GO TO 7002
C---------------IFLG=0 MEANS NO FAILURE OCCURRED. SEE ST. 4054+3.
IF(ITABLO.EQ.1.AND.IFLG.EQ.0)GO TO 7003
C**** WMU-AM: #2.2.1, MOD=1, MTO, 21-SEP-77 ****
IF(ITABLO.EQ.2.AND.IFLG.EQ.0)GO TO 7002
C**** END = MAIN (SECTION 6), #7001+4
IF(ITABLO.EQ.2)GO TO 7009
CALL DEVICE (INT)
GO TO 7006
C---------------HERE IF THERE IS NO FAILURE AND USER ENTERED 1 OR 2.
7003 J6=INBVS+5
DO 7004 J5=6,J6
K=(J5-1)*ILONG
WRITE(IRP,7012)ARRAY(K+1),ARRAY(K+2)
IF(IDEV.EQ.'TTY')GO TO 7005
WRITE(IRP,7008)(ARRAY(I+K),I=5,ILONG)
GO TO 7004
7005 WRITE(IRP,7007)(ARRAY(I+K),I=5,ILONG)
7004 CONTINUE
7007 FORMAT(1X,5(G12.6,2X))
7008 FORMAT(1X,9(G12.6,2X))
7012 FORMAT(1X,2A5)
9930 FORMAT(1X,'COLUMN= ',I3/)
GO TO 7002
C---------------HERE IF FAILURE OCCURS AND USER ENTERED 2.
7009 IF(IDEV.EQ.'TTY')GO TO 7015
WRITE(IRP,7014)
7016 J6=INBVS+5
DO 7010 J5=5,J6
K=(J5-1)*ILONG
IF(J5.EQ.5)GO TO 7017
WRITE(IRP,7012)ARRAY(K+1),ARRAY(K+2)
7017 IF(IDEV.EQ.'TTY')GO TO 7011
WRITE(IRP,7008)(ARRAY(I+K),I=4,ILONG)
GO TO 7010
7011 WRITE(IRP,7007)(ARRAY(I+K),I=4,ILONG)
7010 CONTINUE
K=ILONG
KK=2*ILONG
IF(IDEV.EQ.'TTY')GO TO 7018
WRITE(IRP,7019)(ARRAY(K+I),ARRAY(KK+I),I=5,ILONG)
GO TO 7002
7018 WRITE(IRP,7020)(ARRAY(K+I),ARRAY(KK+I),I=5,ILONG)
7019 FORMAT(1X,6(2A5,','))
7020 FORMAT(1X,11(2A5,','))
7002 RETURN
7013 FORMAT(1X,'THE FOLLOWING ARE THE NONBASIC COLUMNS OF THE TRANS'
1,'FORMED TABLEAU IN'/1X,'THE FORM GIVEN IN TABLE 1 ON PAGE 2'
2,' OF THE WRITE UP. THE FIRST '/1X,'ITEM IN THE B COLUMN IS '
3,'THE FUNCTIONAL VALUE.'//1X,'B COLUMN')
7015 WRITE(IRP,7013)
GO TO 7016
7014 FORMAT(1X,'THE FOLLOWING ARE THE NONBASIC COLUMNS OF THE TRANS'
1,'FORMED TABLEAU IN THE FORM GIVEN IN TABLE 1 ON PAGE 2',
2' OF THE WRITE UP.THE'/1X,'FIRST ITEM IN THE B COLUMN IS '
3,'THE FUNCTIONAL VALUE.'//1X,'B COLUMN')
END