Google
 
Trailing-Edge - PDP-10 Archives - decus_20tap5_198111 - decus/20-0137/nonlpr/nonlpr.for
There are 2 other files named nonlpr.for in the archive. Click here to see a list.
C	WESTERN MICHIGAN UNIVERSITY
C	NONLPR.FOR (FILE NAME ON LIBRARY DECTAPE)
C	NONLPR, 2.11.1 (CALLING NAME, SUBLST. NO.)
C	NONLINEAR PROGRAMMING
C	THIS STARTER PROGRAM (NONLPR) WAS PROGRAMMED
C	 BY R.R. BARR
C	NONLPR.FOR GENERATES FILE NONLPX CONTAINING SUBR. IDENTF
C	 AND EQUATE TO BE CALLED BY NONLPS WHEN USERS SPECIFY
C	 EQUATION INPUT METHOD.
C	NONLPR GENERATES FILE NONLPX CONTAINING SUBR. IDENTF, PARAMS TO
C	 BE CALLED BY NONLPS WHEN USERS SPECIFY POLYNOMIAL COEFFICIENT
C	 METHOD OF INPUT.
C	LIBRARY DECTAPE PROGRAMS USED:  USAGE.MAC
C	FORWMU PROGRAMS USED:  TTYPTY, DEVCHG, EXISTS, PRINTS
C	APLB10 PROGS. USED:  IOB
C	INTERNAL SUBR. USED:  EQUA
C	ABOVE COMMENTS AND RIGHT ADJUSTED COMMENTS PUT IN BY WG
C
	COMMON/IOBLK/IDLG,IRSP,INP,IOUT,IDEVI,IDEVO,ICODE,IB,NAMI(2)
	DIMENSION ID(12),DAT(2)
	IDLG=-1
	INP=4
	IRSP=-4
	IEQ=1
C---------------TTYPTY RETURNS ZERO - TTY JOB, MINUS ONE - BATCH JOB
	CALL TTYPTY(ICODE)
	CALL DEFINE FILE(IEQ,0,NV,'NONLPX.',0,0)
	WRITE(IDLG,100)
100	FORMAT(//,'    NON-LINEAR PROGRAMMING',/,
     1	' WMU IMPLEMENTATION OF RAC VERSION: 2',/)
C	CALL USAGE('NONLPR')
112	CONTINUE
	WRITE(IDLG,101)
101	FORMAT(' ENTER IDENTIFICATION IF DESIRED, ELSE "RETURN"',/)
	READ(IRSP,103)ID
103	FORMAT(12A5)
	CALL DATE(DAT)
C---------------SUBR. IDENTF IS WRITTEN ON DISK INTO A FILE
C--------------- CALLED NONLPX.  SEE ST. 100-2.
	WRITE(IEQ,105)ID,DAT,ID
105	FORMAT('C	',12A5,/,'C	',2A5,//,
     1	'	SUBROUTINE IDENTF',/,
     B	'	COMMON/IOBLK/IDLG,IRSP,INP,IOUT,IDEVI,IDEVO,',
     C	'ICODE,IB,NAMI(2)',/,
     1	'	WRITE(IOUT,1)',/,
     1	'1	FORMAT(1H1,',/,
     1	'     1	',1H',12A5,2H'),/,'	END')
1103	WRITE(IDLG,102)
102	FORMAT(' HOW MANY UNKNOWNS? ',$)
	READ(IRSP,104)N
104	FORMAT(I)
	IF(N.NE.0.AND.N.LE.20)GO TO 1106
	WRITE(IDLG,119)
	GO TO 1103
1106	WRITE(IDLG,106)
106	FORMAT(' HOW MANY INEQUALITY CONSTRAINTS? ',$)
	READ(IRSP,104)M
	WRITE(IDLG,108)
108	FORMAT(' HOW MANY EQUALITY CONSTRAINTS? ',$)
	READ(IRSP,104)MZ
	IF(M+MZ.LE.20)GO TO 126
	WRITE(IDLG,1109)
1109	FORMAT(' ?TOTAL # OF CONSTRAINTS MUST BE <= 20')
	GO TO 1106
126	WRITE(IDLG,114)
114	FORMAT(' TYPE:',/,' 1 FOR POLYNOMIAL COEFFICIENT'
     1	' INPUT METHOD',/,' 2 FOR EQUATION INPUT METHOD',/)
	READ(IRSP,104)IMETH
	IF(IMETH.EQ.1.OR.IMETH.EQ.2)GO TO 117
	WRITE(IDLG,119)
119	FORMAT(' ?RESPONSE OUT OF BOUNDS',/)
	GO TO 126
C---------------IMETH=1 MEANS POLYNOM. COEFF. INPUT METHOD.
117	IF(IMETH.EQ.1)GO TO 300
C---------------1 MEANS OUTPUT? PRINTS. 0 - INPUT? PRINTS. IDLG,
C--------------- IRSP, INP, IOUT, IDEVI, IDEVO,  ICODE ARE
C--------------- INPUT AND IB, NAMI ARE RETURNED THRU COMMON /IOBLK/.
	CALL IOB(0)
C---------------SUBR. EQUATE WRITTEN ON DISK INTO A FILE CALLED
C--------------- NONLPX.  SEE ST. 100-2
	WRITE(IEQ,110)M,N,MZ
110	FORMAT('	SUBROUTINE EQUATE(ISW1,IN,VAL,IX)',/,
     A	'	COMMON/EQAL/MZ,H,H1,H3,NA,NC,IERR',/,
     B	'	COMMON/IOBLK/IDLG,IRSP,INP,IOUT,IDEVI,IDEVO,',
     C	'ICODE,IB,NAMI(2)',/,
     1	'	COMMON/SHARE/X(50),DEL(50),A(50,50),N,M,',/,
     2	'     1 MN,NP1,MN1',/,'	GO TO(99910,99920,99930,99940),'
     3	'ISW1',/,'C	READIN',//,'99910	M=',I2,/,
     4	'	N=',I2,/,'	MZ=',I2,/)
C---------------BETWEEN ST. 110 AND HERE WE HAVE PART OF 
C--------------- SUBR. EQUATE.  THE REST IS GEN. BELOW IN ST. 122,
C--------------- 132, 131, 133, 135, 136, 138, 142, 152, 153, 154,
C--------------- 155, 172, 173, 182
	IF(IDEVI.EQ.'TTY')WRITE(IDLG,120)
120	FORMAT(' ENTER "READ" STATEMENTS IF REQUIRED, ELSE "RETURN"',/)
	CALL EQUA(INP,IEQ,IDEVI,IERR)
	IF(IERR.EQ.1)GO TO 200
	WRITE(IEQ,122)
122	FORMAT('	CALL IOB(1)',/,
     A	'	RETURN',//,'C	RESTNT',/,
     1	'99920	IF(IN)99921,99921,99922',/,
     2	'99921	CONTINUE',/)
	IF(IDEVI.EQ.'TTY')WRITE(IDLG,130)
130	FORMAT(' ENTER OBJECTIVE FUNCTION',/)
	CALL EQUA(INP,IEQ,IDEVI,IERR)
	IF(IERR.EQ.1)GO TO 200
	WRITE(IEQ,132)
132	FORMAT(/,'	RETURN',/,'99922	CONTINUE')
	IF(M+MZ.EQ.0)GO TO 139
	WRITE(IEQ,131)
131	FORMAT('	GO TO(')
	WRITE(IEQ,133)(I,I=99101,99100+M+MZ)
133	FORMAT(('     *	',6(I5,',')))
	WRITE(IEQ,135)
135	FORMAT('     *	99121),IN')
	TAG='IN'
	DO 134 I=1,M+MZ
	IF(I.GT.M)TAG=0
	IZ=99100+I
	WRITE(IEQ,136)IZ
136	FORMAT(I5,' CONTINUE',/)
	IF(IDEVI.EQ.'TTY')WRITE(IDLG,140)I,TAG
140	FORMAT(' ENTER CONSTRAINT # ',I2,' (',A2,'EQUALITY)',/)
	CALL EQUA(INP,IEQ,IDEVI,IERR)
	IF(IERR.EQ.1)GO TO 200
134	WRITE(IEQ,138)
138	FORMAT(/,'	RETURN')
139	WRITE(IEQ,142)
142	FORMAT('99121	RETURN',/,'C	GRAD1',/,
     1	'99930	IF(IN)99931,99931,99932',/,
     A	'99931	CONTINUE',/)
	IF(IDEVI.EQ.'TTY')WRITE(IDLG,150)
150	FORMAT(' ENTER GRADIENT VECTOR FOR THE OBJECTIVE FUNCTION',/)
	CALL EQUA(INP,IEQ,IDEVI,IERR)
	IF(IERR.EQ.1)GO TO 200
	WRITE(IEQ,152)
152	FORMAT(/,'	RETURN',/,'99932	CONTINUE')
	IF(M+MZ.EQ.0)GO TO 155
	WRITE(IEQ,131)
	WRITE(IEQ,133)(I,I=99201,99200+M+MZ)
	WRITE(IEQ,153)
153	FORMAT('     *	99221),IN')
	TAG='IN'
	DO 154 I=1,M+MZ
	IF(I.GT.M)TAG=0
	IZ=99200+I
	WRITE(IEQ,136)IZ
	IF(IDEVI.EQ.'TTY')WRITE(IDLG,160)I,TAG
160	FORMAT(' ENTER GRADIENT VECTOR FOR CONSTRAINT # ',I2,
     1	' (',A2,'EQUALITY)',/)
	CALL EQUA(INP,IEQ,IDEVI,IERR)
	IF(IERR.EQ.1)GO TO 200
154	WRITE(IEQ,138)
155	WRITE(IEQ,162)
162	FORMAT(/,'99221	RETURN',/,'C	MATRIX',/,
     1	'99940	IF(IN)99941,99941,99942',/,'99941	CONTINUE',/)
	IF(IDEVI.EQ.'TTY')WRITE(IDLG,170)
170	FORMAT(' ENTER MATRIX OF 2ND PARTIALS FOR OBJ FUNCTION',/)
	CALL EQUA(INP,IEQ,IDEVI,IERR)
	IF(IERR.EQ.1)GO TO 200
	WRITE(IEQ,172)
172	FORMAT(/,'	RETURN',/,'99942	CONTINUE')
	IF(M+MZ.EQ.0)GO TO 175
	WRITE(IEQ,131)
	WRITE(IEQ,133)(I,I=99301,99300+M+MZ)
	WRITE(IEQ,173)
173	FORMAT('     *	99321),IN')
	TAG='IN'
	DO 174 I=1,M+MZ
	IF(I.GT.M)TAG=0
	IZ=99300+I
	WRITE(IEQ,136)IZ
	IF(IDEVI.EQ.'TTY')WRITE(IDLG,180)I,TAG
180	FORMAT(' ENTER MATRIX OF 2ND PARTIALS FOR CONSTRAINT # ',I2,
     1	' (',A2,'EQUALITY)',/)
	IF(M+MZ.NE.0)CALL EQUA(INP,IEQ,IDEVI,IERR)
	IF(IERR.EQ.1)GO TO 200
174	WRITE(IEQ,138)
175	WRITE(IEQ,182)
182	FORMAT('99321	RETURN',/,'	END')
	CALL RELEAS(IEQ)
	WRITE(IDLG,186)
186	FORMAT(//)
C---------------/FOROTS IS NOT LONGER NECESSARY.  NONLPS IS MAIN
C--------------- PROG. IN THE COMPILED RESULT.  SUBR. IDENTF,
C--------------- EQUATE ARE IN NONLPX.  USER INDICATES NO USE WILL BE
C--------------- MADE OF NONLPP WHICH EVALUATES POLYNOMIALS.  INSTEAD
C--------------- SUBR. EQUATE IN NONLPX WILL EVALUATE USER FUNCTIONS
C--------------- NONLPS CALLS SUBR. EQUATE WHICH IS IN NONLPX.
	CALL RUNUUO('EX/FOROTS/F10 REL:NONLPS,DSK:NONLPX,
     1  REL:APLB10/LIB')
	CALL EXIT
200	WRITE(IDLG,202)
202	FORMAT(' ?ERROR READING EQUATION INPUT FILE',/)
	GO TO 112
C---------------HERE FROM ST. 117.
300	WRITE(IDLG,124)
124	FORMAT(' HOW MANY TERMS IN THE OBJECTIVE FUNCTION? ',$)
	READ(IRSP,104)NA
	IF(NA.GE.1.AND.NA.LE.50)GO TO 306
	WRITE(IDLG,119)
	GO TO 300
C---------------SUBR. PARAMS WRITTEN IN DISK INTO A FILE CALLED NONLPX.
C--------------- SEE ST. 100-2.
306	WRITE(IEQ,302)M,N,MZ,NA
302	FORMAT('	SUBROUTINE PARAMS(M,N,MZ,NA)',/,
     1	'	M=',I2,/,'	N=',I2,/,'	MZ=',I2,/,
     2	'	NA=',I2,/,'	END')
	CALL RELEAS(IEQ)
	WRITE(IDLG,186)
C---------------NONLPS IN MAIN PROG. IN THE COMPILED RESULT.
C--------------- NONLPP EVALUATES POLYNOMIALS.  SUBR. IDENTF, PARAMS
C--------------- ARE IN NONLPX.  NONLPS CALLS SUBR.  EQUATE WHICH IS
C--------------- IN NONLPP.
	CALL RUNUUO('EX/FOROTS/F10 REL:NONLPS,REL:NONLPP,
     1  DSK:NONLPX,REL:APLB10/LIB')
	CALL EXIT
	END
C
C	EQUATION INPUT SUBROUTINE - EQUA
C
C	WRITTEN BY RUSSELL R. BARR - WMU COMPUTER CENTER
C	DATE: JANUARY 1973
C
C	ACCEPTS STATEMENTS IN FORTRAN EQUATION FORM
C	FROM DEVICE 'IRSP' AND WRITES THEM WITH THE CORRECT
C	NUMBER OF SPACES OR A TAB TO DEVICE 'IOUT'
C	IDEVI IS THE INPUT DEVICE NAME IN ASCII
C	IERR IS RETURNED ZERO NORMALLY
C	AND -1 IF IDEVI IS NOT 'TTY' AND THE USER HAS
C	TYPED AN IMPROPER STATEMENT
C
C---------------SUBR. EQUA ALLOWS MODIFICATION OF USER'S EQUATIONS.
C--------------- IERR IS RETURNED, OTHER ARGS. ARE INPUT.
	SUBROUTINE EQUA(IRSP,IOUT,IDEVI,IERR)
	DIMENSION IN(15,201),INA(15)
	DATA IDLG,ITAB/-1,'	'/
	IL=0
400	READ(IRSP,402,END=408)(IN(I,IL+1),I=1,15)
402	FORMAT(A1,14A5)
	IF(IL.GE.200)GO TO 404
	IF(IN(1,IL+1).EQ.' '.AND.IN(2,IL+1).EQ.'     '.AND.IN(3,IL+1)
     1	.EQ.'     ')GO TO 408
	IL=IL+1
	GO TO 400
C---------------IDLG DEFINED IN DATA STATEMENT ABOVE.
404	WRITE(IDLG,406)
406	FORMAT(' ?TOO MANY LINES')
	IF(IDEVI.NE.'TTY')GO TO 824
	WRITE(IDLG,822)
408	IF(IL.EQ.0)GO TO 712
	DO 708 IX=1,IL
	DO 410 J=15,1,-1
410	IF(IN(J,IX).NE.' ')GO TO 707
707	IF(IDEVI.EQ.'TTY')WRITE(IDLG,704)IX,(IN(I,IX),I=1,J)
704	FORMAT(1X,I2,':',A1,14A5)
708	CONTINUE
712	IF(IDEVI.EQ.'TTY')WRITE(IDLG,714)
714	FORMAT(/,' OK?(YES OR NO) ',$)
	READ(IRSP,716)ANS
716	FORMAT(A3)
	IF(ANS.EQ.'YES')GO TO 800
719	WRITE(IDLG,718)
718	FORMAT(' ENTER LINE NUMBER,LINE(E.G. 3,IX=1)',/)
721	READ(IRSP,720)IX,(INA(I),I=1,15)
720	FORMAT(I,A1,14A5)
	IF(IX.LE.0)GO TO 408
	IF(IX.GT.IL+1)GO TO 818
	IF(IX.GT.200)GO TO 816
	IF(IX.GT.IL)IL=IL+1
	DO 722 J=15,1,-1
	IF(INA(J).NE.' ')GO TO 724
722	CONTINUE
724	DO 723 I=1,15
723	IN(I,IX)=INA(I)
	WRITE(IDLG,704)IX,(IN(I,IX),I=1,J)
	WRITE(IDLG,702)
702	FORMAT(/)
	GO TO 721
800	DO 810 IZ=1,IL
	DO 802 J=15,1,-1
802	IF(IN(J,IZ).NE.'     ')GO TO 906
906	IF(IN(1,IZ).EQ.' ')GO TO 910
	IF(IN(1,IZ).GE.'1'.AND.IN(1,IZ).LE.'9')GO TO 910
	IF(IN(1,IZ).EQ.ITAB)GO TO 910
	WRITE(IOUT,908)(IN(I,IZ),I=1,J)
908	FORMAT(6X,A1,14A5)
	GO TO 810
910	WRITE(IOUT,912)(IN(I,IZ),I=1,J)
912	FORMAT(A1,14A5)
810	CONTINUE
	RETURN
812	WRITE(IDLG,814)
814	FORMAT(' ?ERROR IN LINE')
	IF(IDEVI.NE.'TTY')GO TO 824
	WRITE(IDLG,822)
	GO TO 719
816	WRITE(IDLG,406)
	IF(IDEVI.NE.'TTY')GO TO 824
	WRITE(IDLG,822)
	GO TO 719
818	IF(IDEVI.NE.'TTY')GO TO 824
	IQ=IX-1
	WRITE(IDLG,820)IQ
820	FORMAT(' LINE #',I2,' NEVER ENTERED-LAST LINE IGNORED')
	IF(IDEVI.NE.'TTY')GO TO 824
	WRITE(IDLG,822)
822	FORMAT(' ?LAST LINE IGNORED')
	GO TO 719
824	IERR=1
	RETURN
	END