Google
 

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