Trailing-Edge
-
PDP-10 Archives
-
decus_20tap5_198111
-
decus/20-0137/nonlpr/nonlpp.for
There are 2 other files named nonlpp.for in the archive. Click here to see a list.
C WESTERN MICHIGAN UNIVERSITY
C NONLPP.FOR (FILE NAME ON LIBRARY DECTAPE)
C THIS PROG. WAS PROGRAMMED AT WAYNE STATE UNIVERSITY
C MODIFIED AT WMU BY R.R. BARR
C FORWMU PROGS. USED: TTYPTY, DEVCHG, EXISTS, PRINTS
C APLB10 PROGS. USED: IOB
C INTERNAL SUBR. USED: READIN, RESTNT, GRAD1, MATRIX, EQUATE
C NONLPS CALLS THIS SUBROUTINE WHEN USER SPECIFIES THE
C POLYNOMIAL COEFF. METHOD OF INPUT. SEE LISTING OF
C NONLPR.FOR ST. 302=5,6
C EXTERNAL SUBR. USED: IDENTF, PARAMS
C ABOVE COMMENTS AND RIGHT ADJUSTED COMMENTS PUT IN BY WG
C
C---------------IN, ISW1, ARE INPUT; VAL, IX ARE OUTPUT.
C--------------- THIS SUBR. WILL BE CALLED FROM NONLPS.FOR
C--------------- WHEN USER CHOOSES POLYNOM. COEFF. METHOD OF INPUT
C--------------- SEE NONLPR.FOR ST. 302+5. NOTE THAT AT THIS POINT
C--------------- NONLPX CONTAINS SUBR. IDENTF, PARAMS.
SUBROUTINE EQUATE(ISW1,IN,VAL,IX)
GO TO(1,2,3,4),ISW1
1 CALL TTYPTY(ICODE)
CALL IOB(0)
CALL READIN
CALL IOB(1)
RETURN
2 CALL RESTNT(IN,VAL)
RETURN
3 CALL GRAD1(IN)
RETURN
4 CALL MATRIX(IN,IX)
RETURN
END
C---------------IDEVI, INP, IDLG ARE INPUT THRU COMMON /IOBLK/
C--------------- OF READIN AND IOB OF APLB10.FOR. N, M ARE
C--------------- RETURNED THRU COMMON /SHARE/. MZ, NA ARE RETURNED
C--------------- THRU COMMON /EQAL/. FUNCT, C ARE RETURNED THRU
C--------------- COMMON.
SUBROUTINE READIN
COMMON/SHARE/ X(50), DEL(50), A(50,50),N,M, MN,NP1,NM1
COMMON/EQAL/ MZ, H, H1, H3, NA, NC,IERR
COMMON FUNCT(1050),C(20,300)
COMMON/IOBLK/IDLG,IRSP,INP,IOUT,IDEVI,IDEVO,ICODE,IB,NAMI(2)
DIMENSION B(50)
10 K=1
L=21
MI=1
C
C GET PARAMETERS FROM NONLPX
C
C---------------ALL ARGS. ARE OUTPUT.
CALL PARAMS(M,N,MZ,NA)
C
C READ IN FUNCTION
C
IF(IDEVI.EQ.'TTY')WRITE(IDLG,200)
200 FORMAT(' ENTER TERMS FOR OBJECTIVE FUNCTION',/)
READ(INP,90)(FUNCT(I),I=K,L)
90 FORMAT(21F)
GO TO 111
11 READ(INP,91) (FUNCT(I),I=K,L)
111 IF(FUNCT(K))25,21,25
25 DO 35 KI=K,L
IF(FUNCT(KI))34,35,34
34 B(MI)=KI-K
35 CONTINUE
MI=MI+1
K=K+21
L=L+21
GO TO 11
21 MI=MI-1
C
C TEST TO SEE IF PARM CARD AGREES WITH INPUT
C
IF(NA-MI)23,22,23
23 WRITE(IDLG,99) NA,MI,MI
99 FORMAT(/,' INPUT ERROR, YOU SPECIFIED ',I3,' TERMS'/
1' BUT ONLY',I3,' TERMS WERE SUPPLIED,',/,
2 ' PROCESSING CONTINUED USING THE ',I2,' TERMS SUPPLIED',/)
C
C PLACE THE NO. OF VARIABLES ACTUALLY FOUND INTO IX(1)
C
NA=MI
22 DO 40 IK=1,NA
DO 40 I=2,NA
IF(B(I)-B(I-1))40,36,36
36 Y=B(I)
B(I)=B(I-1)
B(I-1)=Y
40 CONTINUE
C
C TEST TO SEE IF PARM CARD AGREES WITH INPUT
C
IF(B(1)-N)41,42,41
41 WRITE(IDLG,98) N,B(1),B(1)
98 FORMAT (/,' INPUT ERROR, YOU SPECIFIED ',I2,' VARIABLES',/
1' BUT ONLY ',F3.0,' VARIABLES WERE SUPPLIED',/
2' PROCESSING CONTINUED USING THE ',F3.0,' VARIABLES SUPPLIED',/)
N=B(1)
42 IDO=1
TAG='IN'
125 K=1
L=21
C
C READ IN THE CONSTRAINTS
C
IF(IDO.GT.M)TAG=0
IF(M+MZ.EQ.0)RETURN
IF(IDEVI.EQ.'TTY')WRITE(IDLG,220)IDO,TAG
220 FORMAT(' ENTER TERMS FOR CONSTRAINT #',I2,' (',A2,'EQUALITY)'/)
READ(INP,90)(C(IDO,J),J=K,L)
GO TO 431
43 READ(INP,91) (C(IDO,J),J=K,L)
431 IF(C(IDO,K))51,52,51
91 FORMAT(21F)
52 IF(IDO-M-MZ)121,30,30
121 IDO=IDO+1
GO TO 125
51 K=K+21
L=L+21
GO TO 43
30 RETURN
END
C---------------IN IS INPUT, VAL IS RETURNED.
SUBROUTINE RESTNT(IN,VAL)
C---------------N, X ARE INPUT THRU COMMON /SHARE/. NA, NC
C--------------- ARE RETURNED THRU COMMON /EQUAL/. NC IS MODIFIED.
C--------------- FUNCT IS INPUT THRU COMMON. IDLG IS
C--------------- INPUT THRU COMMON /IOBLK/. POWRS IS RETURNED THRU
C--------------- COMMON /P/.
COMMON/SHARE/ X(50), DEL(50), A(50,50),N,M, MN,NP1,NM1
COMMON/EQAL/ MZ, H, H1, H3, NA, NC,IERR
COMMON FUNCT(1050),C(20,300)
COMMON/IOBLK/IDLG,IRSP,INP,IOUT,IDEVI,IDEVO,ICODE,IB,NAMI(2)
COMMON/P/POWRS(1050)
REAL NEW
IF(IN)5,5,20
20 NC=1
K=1
L=21
32 DO 33 I=K,L
33 POWRS(I)=C(IN,I)
IF(POWRS(K))34,35,34
34 NC=NC+1
K=K+21
L=L+21
GO TO 32
35 NC=NC-1
GO TO 100
5 NKC=21*NA
NC=NA
DO 44 J=1,NKC
44 POWRS(J)=FUNCT(J)
100 KL=1
VAL=0.0
DO 349 JI=1,NC
T=1
DO 348 JK=1,N
JKKL=JK+KL
NEW=POWRS(JKKL)
IF(X(JK))106,107,106
107 IF(POWRS(JKKL))110,348,106
106 T=X(JK)**NEW*T
348 CONTINUE
VAL=VAL+T*POWRS(KL)
349 KL=KL+21
GO TO 365
110 WRITE(IDLG,9)JI,JK,X(JK),POWRS(JKKL)
9 FORMAT (' INPUT ERROR IN TERM NO.',I3,/' WHEN INDEP. VAR. ',I2,
1'=',F5.2,'WAS RAISED TO THE FOLLOWING POWER',F6.0)
IERR=-1
365 RETURN
END
C---------------IN IS INPUT.
SUBROUTINE GRAD1(IN)
C---------------X INPUT THRU COMMON /SHARE/. DEL RETURNED
C--------------- THRU COMMON /SHARE/. NA, NC INPUT THRU COMMON
C--------------- /EQAL/. NC IS MODIFIED. FUNCT, C ARE INPUT THRU
C--------------- COMMON. POWRS RETURNED THRU COMMON /P/.
COMMON/SHARE/ X(50), DEL(50), A(50,50),N,M, MN,NP1,NM1
COMMON/EQAL/ MZ, H, H1, H3, NA, NC,IERR
COMMON FUNCT(1050),C(20,300)
COMMON/P/POWRS(1050)
REAL NEW
IF(IN)5,5,20
20 NC=1
K=1
L=21
32 DO 33 I=K,L
33 POWRS(I)=C(IN,I)
IF(POWRS(K))34,35,34
34 NC=NC+1
K=K+21
L=L+21
GO TO 32
35 NC=NC-1
GO TO 100
5 NKC=21*NA
NC=NA
DO 44 J=1,NKC
44 POWRS(J)=FUNCT(J)
100 DO 350 I=1,N
KL=1
VAL=0.0
DO 349 JI=1,NC
T=1
KLI=KL+I
TX=POWRS(KLI)
POWRS(KLI)=POWRS(KLI)-1.
DO 348 JK=1,N
JKKL=JK+KL
NEW=POWRS(JKKL)
IF(X(JK))106,107,106
107 IF(POWRS(JKKL))348,348,106
106 T=X(JK)**NEW*T
348 CONTINUE
POWRS(KLI)=POWRS(KLI)+1.
VAL=VAL+T*POWRS(KL)*TX
349 KL=KL+21
DEL(I)=VAL
350 CONTINUE
RETURN
END
C---------------IN IS INPUT. IK RETURNED.
SUBROUTINE MATRIX(IN,IK)
C---------------X IS INPUT THRU COMMON /SHARE/. A RETURNED THRU
C--------------- COMMON /SHARE/. NA, NC ARE INPUT THRU COMMON /EQAL/. NC
C--------------- IS MODIFIED. FUNCT, C ARE INPUT THRU COMMON. POWRS
C--------------- RETURNED THRU COMMON /P/.
COMMON/SHARE/ X(50), DEL(50), A(50,50),N,M, MN,NP1,NM1
COMMON/EQAL/ MZ, H, H1, H3, NA, NC,IERR
COMMON FUNCT(1050),C(20,300)
COMMON/P/POWRS(1050)
REAL NEW
IF(IN)5,5,20
20 NC=1
K=1
L=21
32 DO 33 I=K,L
33 POWRS(I)=C(IN,I)
IF(POWRS(K))34,35,34
34 NC=NC+1
K=K+21
L=L+21
GO TO 32
35 NC=NC-1
GO TO 100
5 NKC=21*NA
NC=NA
DO 44 J=1,NKC
44 POWRS(J)=FUNCT(J)
100 DO 350 I=1,N
DO 349 IL=1,N
IF(IL-I)349,200,200
200 KL=1
VAL=0.0
DO 348 JI=1,NC
T=1
KLI=KL+I
TX=POWRS(KLI)
POWRS(KLI)=POWRS(KLI)-1.
KLL=KL+IL
TX=TX*POWRS(KLL)
POWRS(KLL)=POWRS(KLL)-1.
DO 347 JK=1,N
JKKL=JK+KL
NEW=POWRS(JKKL)
IF(X(JK))206,207,206
207 IF(POWRS(JKKL))347,347,206
206 T=X(JK)**NEW*T
347 CONTINUE
VAL=VAL+T*POWRS(KL)*TX
POWRS(KLL)=POWRS(KLL)+1.
POWRS(KLI)=POWRS(KLI)+1.
348 KL=KL+21
A(I,IL)=VAL
349 CONTINUE
350 CONTINUE
DO 10 I=1,N
DO 10 IL=1,N
IF(IL-I)10,40,40
40 IF(A(I,IL))30,10,30
10 CONTINUE
IK=1
30 RETURN
END