Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-05 - decus/20-0137/csmp/csmp1.for
There is 1 other file named csmp1.for in the archive. Click here to see a list.
	SUBROUTINE CSM0
C	INITIALIZATION
	INTEGER TEST(9),KEYS(16)
	COMMON REALS(395),INTS(547)
	EQUIVALENCE (INTS(525),TEST(1))
	EQUIVALENCE (INTS(380),KEYS(1))
	WRITE(30,10)
10	FORMAT(1H1,10X,38HWMU CONTINUOUS SYSTEM MODELING PROGRAM//)
	IF(IONE.NE.0)GO TO 13
C	CALL USAGE('CSMP  ')
13	IONE=1
	DO 20 I=1,547
20	INTS(I)=0
	DO 30 I=1,395
30	REALS(I)=0.0
	DO 50 I=1,8
50	TEST(I)=1
	DO 60 I=1,16
60	KEYS(I)=2
	RETURN
	END
	SUBROUTINE CSM1
C	CONFIGURATION SPECIFICATIONS
	INTEGER TEST2,TEST9
	LOGICAL RSAC
	DIMENSION MTRX(75,5)
	COMMON REALS(395),INTS(547)
	COMMON/EXTRA2/TY(30)
	COMMON/NOPR/INPVAR
	EQUIVALENCE (INTS(1),MTRX(1,1))
	EQUIVALENCE (INTS(526),TEST2)
	EQUIVALENCE (INTS(533),TEST9)
C	GET INPUT UNIT TEST2
	IF(INPVAR.NE.-1)WRITE(30,10)
10	FORMAT(/10X,27HCONFIGURATION SPECIFICATION/)
	IF (TEST2.EQ.5) GO TO 40
C	NON-TTY INPUT
	IF(INPVAR.EQ.-1)GO TO 60
	WRITE(30,30)
30	FORMAT(40H BLOCK  TYPE   INPUT 1  INPUT 2  INPUT 3)
	GO TO 60
C	TTY INPUT
40	WRITE(30,50)
50	FORMAT(39H BLOCK, TYPE, INPUT 1, INPUT 2, INPUT 3/)
C	INPUT STATEMENTS
60	I=KINPUT(0,IERR)
	IF (IERR) 400,70,340
70	IF (I) 340,400,80
80	IF (I.GT.75) GO TO 340
	J=0
	K=0
	L=0
	ATYPE=FINPUT(1,IERR)
C	SEARCH THROUGH PROGRAM LIBRARY FOR BLOCK TYPE ATYPE
	DO 90 M=1,30
	IF (ATYPE.EQ.TY(M)) GO TO 120
90	CONTINUE
C	TYPE IS NOT IN THE LIBRARY
100	WRITE(30,110) I
110	FORMAT(28H ILLEGAL BLOCK TYPE IN BLOCK,I3/)
	GO TO 360
120	IF (IERR) 180,130,320
130	J=KINPUT(0,IERR)
	IF (IERR) 180,140,320
140	IF (IABS(J).GT.76) GO TO 320
	K=KINPUT(0,IERR)
	IF (IERR) 180,150,320
150	IF (IABS(K).GT.76) GO TO 320
	L=KINPUT(0,IERR)
	IF (IERR) 180,160,320
160	IF (IABS(L).GT.76) GO TO 320
	IF (FINPUT(-1,IERR).NE.0.0) GO TO 320
C	LEGAL BLOCK, TYPE, AND INPUTS
C	MODIFIED FOR BLOCKS A,C,E 25 APR 74.
180	IF (M.LE.10) GO TO (250,200,250,200,250,200,200,200,220,190),M
	N=M-10
	IF (N.LE.10) GO TO (190,200,200,200,200,200,210,220,210,200),N
	N=N-10
	GO TO (200,190,220,210,210,210,250,200,210,250),N
190	IF (J.GT.0) GO TO 320
200	IF (K.GT.0) GO TO 320
210	IF (L.GT.0) GO TO 320
220	IF (J.LT.0) GO TO 320
230	IF (K.LT.0) GO TO 320
240	IF (L.LT.0) GO TO 320
C	LEGAL STATEMENTS - STORE THE CONFIGURATION
250	MTRX(I,2)=J
	MTRX(I,3)=K
	MTRX(I,4)=L
	IF (TEST2.EQ.5.OR.RSAC(10)) GO TO 290
C	TELEPRINTER RECORD
	K=4
	DO 260 L=1,3
	IF (MTRX(I,K).NE.0) GO TO 270
260	K=K-1
	IF(INPVAR.NE.-1)WRITE(30,280) I,ATYPE
	GO TO 290
270	IF(INPVAR.NE.-1)WRITE(30,280) I,ATYPE,(MTRX(I,L),L=2,K)
280	FORMAT(3X,I2,5X,A1,3(6X,I3))
C	CHECK FOR BLOCK DELETION
290	IF (MTRX(I,1).NE.0) WRITE(30,300) I
300	FORMAT(15H PREVIOUS BLOCK,I3,8H DELETED/)
	MTRX(I,1)=M
	IF (M.NE.30) GO TO 60
	MTRX(I,1)=0
	MTRX(I,5)=0
	GO TO 60
C	ILLEGAL STATEMENT
320	WRITE(30,330) I
330	FORMAT(15H ERROR IN BLOCK,I3/)
	GO TO 360
C	ILLEGAL BLOCK NUMBER
340	WRITE(30,350) I
350	FORMAT(17H BLOCK NUMBER OF ,I7,11H IS ILLEGAL/)
360	TEST9=-1
	GO TO 60
C	END OF CONFINURATION SPECIFICATION
400	TEST9=0
	RETURN
	END
	SUBROUTINE CSM2
C	PREPARE FOR SORT
	INTEGER TEST(9),DELAY(25),ORDER(76)
	DIMENSION MTRX(75,5),INTG(25)
	COMMON REALS(395),INTS(547)
	EQUIVALENCE (INTS(1),MTRX(1,1))
	EQUIVALENCE (INTS(396),INTG(1))
	EQUIVALENCE (INTS(424),DELAY(1))
	EQUIVALENCE (INTS(449),ORDER(1))
	EQUIVALENCE (INTS(525),TEST(1))
	EQUIVALENCE (INTS(540),NCON)
	EQUIVALENCE (INTS(541),NOD)
	EQUIVALENCE (INTS(542),NEQ)
	EQUIVALENCE (INTS(543),NFG)
C	RESET ERROR INDICATOR AND COUNTERS
	IERR=2
	NOD=0
	NEQ=0
	IFG=0
	NCON=2
	ORDER(1)=76
C
C	TEST FOR SELECTED ELEMENTS
	DO 80 I=1,75
	ITYPE=IABS(MTRX(I,1))
	IF (ITYPE.EQ.0) GO TO 80
	MTRX(I,1)=ITYPE
	IF (ITYPE.NE.21) GO TO 10
C	UNIT DELAY
	NOD=NOD+1
	DELAY(NOD)=I
	GO TO 40
10	IF (ITYPE.NE.9) GO TO 20
C	INTEGRATOR
	NEQ=NEQ+1
	INTG(NEQ)=I
	MTRX(I,5)=NEQ
	GO TO 40
20	IF (ITYPE.NE.11) GO TO 30
C	CONSTANT
	ORDER(NCON)=I
	NCON=NCON+1
	GO TO 50
C	FUNCTION GENERATOR
30	IF (ITYPE.EQ.6) IFG=IFG+1
C	NEGATE ELEMENT IDENTIFIER UNTIL AFTER SORTING
40	MTRX(I,1)=-ITYPE
50	DO 70 J=2,4
	LTEST=IABS(MTRX(I,J))
	IF (LTEST.LE.0.OR.LTEST.GT.75.OR.MTRX(LTEST,1).NE.0) GO TO 70
	WRITE(30,60) LTEST,I
60	FORMAT(6H BLOCK,I3,16H, INPUT TO BLOCK,I3,9H, MISSING/)
	IERR=1
70	CONTINUE
80	CONTINUE
C
C	TEST ON PROPER NUMBER OF ELEMENTS
	IF (NEQ.GT.0) GO TO 100
	WRITE(30,90)
90	FORMAT(31H AT LEAST 1 INTEGRATOR REQUIRED/)
	IERR=1
	GO TO 120
100	IF (NEQ.LE.25) GO TO 120
	WRITE(30,110)
110	FORMAT(48H THE MAXIMUM OF 25 INTEGRATORS HAS BEEN EXCEEDED/)
	IERR=1
120	IF (NOD.LE.25) GO TO 140
	WRITE(30,130)
130	FORMAT(48H THE MAXIMUM OF 25 UNIT DELAYS HAS BEEN EXCEEDED/)
	IERR=1
140	IF (IFG.LE.3) GO TO 170
	WRITE(30,150)
150	FORMAT(55H THE MAXIMUM OF 3 FUNCTION GENERATORS HAS BEEN EXCEEDED
	1/)
C	UNSUCCESSFUL PRE-SORT
160	TEST(1)=1
	RETURN
170	IF (IERR.EQ.1) GO TO 160
	IF (IFG.GT.0) GO TO 180
C	NO FUNCTION GENERATORS
	TEST(4)=1
	NFG=0
	GO TO 190
C	SOME FUNCTION GENERATORS
180	TEST(4)=2
	IF (IFG.GT.NFG) TEST(3)=1
C	TEST3=1 TO SIGNAL ADDITION OF FUNCTION GENERATOR BLOCK(S)
	NFG=IFG
C	SUCCESSFUL PRE-SORT
190	TEST(1)=2
	RETURN
	END
	SUBROUTINE CSM3
C	SORT
	INTEGER TEST1,DELAY(25),ORDER(76)
	DIMENSION MTRX(75,5),INTG(25)
	COMMON REALS(395),INTS(547)
	EQUIVALENCE (INTS(1),MTRX(1,1)),(INTS(396),INTG(1))
	EQUIVALENCE (INTS(424),DELAY(1)),(INTS(449),ORDER(1))
	EQUIVALENCE (INTS(525),TEST1),(INTS(534),NLIST)
	EQUIVALENCE (INTS(540),NCON),(INTS(541),NOD),(INTS(542),NEQ)
C	RESET ERROR INDICATOR
	IERR=2
	DO 10 N=NCON,76
10	ORDER(N)=0
C
C	SORT OPERATION
	NLIST=NCON-1
20	DO 80 I=1,75
	IF (MTRX(I,1).GE.0) GO TO 80
	DO 70 J=2,4
	LTEST=IABS(MTRX(I,J))
	IF (LTEST.EQ.0) GO TO 70
	IF (NOD.EQ.0) GO TO 40
	DO 30 K=1,NOD
	IF (LTEST.EQ.DELAY(K)) GO TO 70
30	CONTINUE
40	DO 50 K=1,NEQ
	IF (LTEST.EQ.INTG(K)) GO TO 70
50	CONTINUE
	DO 60 K=1,NLIST
	IF (LTEST.EQ.ORDER(K)) GO TO 70
60	CONTINUE
	GO TO 80
70	CONTINUE
	GO TO 130
80	CONTINUE
C
C	SORT TEST
	DO 90 I=1,75
	IF (MTRX(I,1).LT.0) GO TO 110
90	CONTINUE
	IF (IERR.EQ.1) GO TO 100
C	SUCCESSFUL SORT
	TEST1=2
	RETURN
C	UNSUCCESSFUL SORT
100	TEST1=1
	RETURN
C	SORT FAILURE - SET ERROR INDICATOR, TYPE ERROR MESSAGE,
C	   AND PUT BLOCK IN THE SORT ORDER LIST TO DETERMINE
C	   WHETHER THE REST OF THE CONFIGURATION WOULD BE OK
110	IERR=1
	WRITE(30,120) I
120	FORMAT(22H SORT FAILURE AT BLOCK,I3/)
130	MTRX(I,1)=-MTRX(I,1)
	NLIST=NLIST+1
	ORDER (NLIST)=I
	GO TO 20
	END