Trailing-Edge
-
PDP-10 Archives
-
decuslib10-09
-
43,50466/csmp1.f4
There are no other files named csmp1.f4 in the archive.
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