Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-05 - 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