Trailing-Edge
-
PDP-10 Archives
-
decus_20tap5_198111
-
decus/20-0137/csmp/csmp5.for
There is 1 other file named csmp5.for in the archive. Click here to see a list.
SUBROUTINE GETNAM(FILS,DEV,FILNAM,NUM)
IMPLICIT INTEGER (A-Z)
DIMENSION FILS(15),IWORK(3),IBLANK(5)
DIMENSION SLOT(29)
DATA SLOT(1),SLOT(5),SLOT(20)/3*1/
COMMON /WHEW/DEVISE(29)
DATA BLANK/5H /,DEVISE/3HDSK,3HCDR,3HLPT,3HCTY,3HTTY,
13HPTR,3HPTP,3HTTY,4HDTA1,4HDTA2,4HDTA3,4HDTA4,4HDTA5,4HDTA6,
24HDTA7,4HMTA0,4HMTA1,4HMTA2,3HTTY,4HDSK0,4HDSK1,4HDSK2,
34HDSK3,4HDSK4,4HDEV1,4HDEV2,4HDEV3,4HDEV4,4HDEV5/
C
DATA HERE/0/,COLON/1H:/,PERIOD/1H./
C
IF(HERE.EQ.1)GO TO 1
HERE=1
CALL DEVCHG('TTY',8)
CALL DEVCHG('TTY',19)
IBLANK(1)=BLANK
IBLANK(2)=(BLANK).AND."3777777777
IBLANK(3)=(BLANK).AND."17777776
IBLANK(4)=BLANK.AND."77776
IBLANK(5)=BLANK.AND."376
1 IWORK(1)=BLANK
IWORK(2)=BLANK
D TYPE999,DEV,FILNAM,SLOT,(IJ,IJ=1,29)
999 FORMAT(1X,A4,A5,/,1X,29I2,/,1X,29I2)
K=1
L=0
J=1
DO 10 I=1,15
IF(FILS(I).EQ.BLANK)GO TO 20
IF (FILS(I).EQ.COLON) GO TO 30
GO TO (100,200,300,400,500)J
100 IWORK(K)=(FILS(I).AND."774000000000)
J=2
GO TO 10
200 IWORK(K)=IWORK(K).OR.((FILS(I)/128).AND."3760000000)
J=3
GO TO 10
300 IWORK(K)=IWORK(K).OR.((FILS(I)/16384).AND."17700000)
J=4
GO TO 10
400 IWORK(K)=IWORK(K).OR.(((FILS(I)/16384)/128).AND."77400)
J=5
GO TO 10
500 IWORK(K)=IWORK(K).OR.(((FILS(I)/16384)/16384).AND."376)
J=1
K=2
GO TO 10
20 IF(IWORK(1).EQ.BLANK)GO TO 11
IF (I.EQ.1) GO TO 11
IWORK(K)=IWORK(K).OR.IBLANK(J)
FILNAM=IWORK(1)
GO TO 11
30 IF (IWORK(1).EQ.BLANK) GO TO 10
IF(K.EQ.1) GO TO 31
IWORK(1)=IWORK(1).AND.(.NOT."376)
J=5
GO TO 31
31 IWORK(1)=IWORK(1).OR.IBLANK(J)
C CHECK DEV FOR LEGALITY +FIND OLD SLOT
DO 2 IX=1,29
IF(DEV.EQ.DEVISE(IX))GO TO 361
2 CONTINUE
GO TO 361
361 IF(SLOT(IX).EQ.0.AND.DEV.EQ.'TTY')GO TO 2
C CHECKNEW DEVICE FOR LEGALITY + FIND SLOT OF NEW DEVICE
3 DO 32 II=1,29
IF(IWORK(1).EQ.DEVISE(II)) GO TO 6
32 CONTINUE
36 WRITE (30,34)
34 FORMAT(' ?BAD DEVICE NAME',/)
GO TO 41
C SLOT FOR NEW OR SAME DEVICE
6 IF(SLOT(II).EQ.0.OR.IX.EQ.II)GO TO 5
IF(IWORK(1).EQ.'TTY'.AND.(II.EQ.5.OR.II.EQ.8))GO TO 32
GO TO 39
C SET UP NEW SLOT
5 SLOT(IX)=0
SLOT(II)=1
GO TO 33
39 WRITE(30,37)IWORK(1)
37 FORMAT(' ?',A4,': MAY BE USED FOR ONLY ONE I/O FUNCTION',/)
41 WRITE(30,40)DEV,FILNAM
40 FORMAT(' OLD WAS ',A4,':',A5,' REPLACE WITH ',$)
ACCEPT 38,FILS
38 FORMAT(15A1)
GO TO 1
33 DEV=IWORK(1)
NUM=II
IWORK(1)=BLANK
IWORK(2)=BLANK
K=1
J=1
GO TO 10
10 CONTINUE
11 CONTINUE
D TYPE 999,DEV,FILNAM,SLOT,(IJ,IJ=1,29)
RETURN
END
FUNCTION FINPUT(MODE,IERR)
C TEST9 (IN COMMON)=COLUMN POINTER=COL
C WHENEVER COL=-1, FINPUT WILL ECHO CURRENT RECORD TO THE TTY,
C AND READ A REPLACEMENT RECORD FROM THE TTY
C (THIS FACILITY IS FOR ERROR INDICATION TO THE USER)
C WHENEVER COL=0, FINPUT WILL READ A NEW RECORD FROM THE TTY
C AFTER COL HAS BEEN PROCESSED, THE MODE PARAMETER IS CHECKED-
C MODE=-1 TO CHECK IF THERE ARE ANY UNPROCESSED ELEMENTS
C REMAINING UN THE CURRENT RECORD.
C IF THERE ARE NO MORE ELEMENTS - FINPUT=0.0
C IF THERE ARE SOME ELEMENTS - FINPUT=1.0
C IN EITHER CASE - COL=0
C MODE=0 TO CHECK FOR A NUMERIC VALUE AS THE NEXT ELEMENT
C MODE=+1 TO CHECK FOR AN ALPHANUMERIC CHARACTER STRING AS THE
C NEXT ELEMENT (ONLY THE FIRST CHARACTER IS RETAINED)
C IN EITHER OF THE LATTER TWO CASES -
C IF THERE IS ANOTHER (OK) ELEMENT - IERR=0
C FINPUT=[VALUE]
C IF THERE ARE NO MORE ELEMENTS - IERR =-1
C COL=0
C FINPUT=0.0 (NUMERIC)
C OR BLANK (ALPHA)
C IF THERE IS ANOTHER ELEMENT OF
C THE WRONG TYPE - IERR=+1
C COL=0
C FINPUT=0.0 (NUMERIC)
C OR BLANK (ALPHA)
C NOTE THAT THE ABOVE SCHEME (WITH COL), IF PROPERLY UTILIZED,
C WILL RESULT IN COL=0 AND A NEW RECORD BEING READ AUTOMATICALLY,
C AT THE APPROPRIATE TIMES - IT IS ONLY NECESSARY TO INITIALIZE
C COL (TEST9) = 0.
C NUMERIC ELEMENTS ARE DELIMITED BY BLANKS,COMMAS,$,OR MODE CHANGE
C ALPHANUMERIC ELEMENTS ARE DELIMITED BY BLANKS, COMMAS, AND $
C $ IS THE RECORD TERMINATOR
C FINPUT OPERATES ON 72-CHARACTER INPUT RECORDS
C NUMERIC ELEMENTS MAY BE INTEGER, FIXED POINT, OR FLOATING POINT
C BE CAREFUL ABOUT E AND G (E FORMAT OR ALPHA CAN BE CONFUSING)
C
INTEGER COL, TEST2
LOGICAL DIGD,DIGE,ESW,NUMER,POINT
DIMENSION DATUM(72),DIGIT(10),DVAL(10)
COMMON REALS(395),INTS(547)
EQUIVALENCE (INTS(526),TEST2),(INTS(533),COL)
DATA BLANK/1H /
DATA COMMA/1H,/
DATA DMINUS/1H-/
DATA DOLLAR/1H$/
DATA DPLUS/1H+/
DATA DPOINT/1H./
DATA E/1HE/
DATA G/1HG/
DATA DIGIT(1)/1H0/
DATA DIGIT(2)/1H1/
DATA DIGIT(3)/1H2/
DATA DIGIT(4)/1H3/
DATA DIGIT(5)/1H4/
DATA DIGIT(6)/1H5/
DATA DIGIT(7)/1H6/
DATA DIGIT(8)/1H7/
DATA DIGIT(9)/1H8/
DATA DIGIT(10)/1H9/
DATA DVAL(1)/0.0/
DATA DVAL(2)/1.0/
DATA DVAL(3)/2.0/
DATA DVAL(4)/3.0/
DATA DVAL(5)/4.0/
DATA DVAL(6)/5.0/
DATA DVAL(7)/6.0/
DATA DVAL(8)/7.0/
DATA DVAL(9)/8.0/
DATA DVAL(10)/9.0/
C
C BEGIN COL CHECK
IF (COL) 10,30,60
C ECHO CURRENT RECORD TO, AND READ NEW RECORD FROM, THE TELETYPE
10 IF (TEST2.NE.5) WRITE(30,20) (DATUM(I),I=1,40)
20 FORMAT(1H ,40A1,4H****)
READ(5,40) DATUM
GO TO 50
C READ NEW RECORDS FROM TEST2
30 READ(TEST2,40,END=380) DATUM
40 FORMAT(72A1)
C INITIALIZE COLUMN POINTER
50 COL=1
C GENERAL INITIALIZATION
60 IF (MODE) 70,70,80
70 FINPUT=0.0
GO TO 90
80 FINPUT=BLANK
C CHECK IF ANY ELEMENTS
90 IF (COL.GT.72) GO TO 100
IF (DATUM(COL).NE.DOLLAR) GO TO 110
C NO ELEMENTS REMAINING
100 IERR=-1
GO TO 400
C THERE IS SOME ELEMENTS
110 IF (MODE) 120,130,130
C CALLER DOES NOT WANT ANY MORE
120 FINPUT=1.0
GO TO 400
C IT IS OK TO HAVE AN ELEMENT
C IGNORE LEADING BLANKS
130 DO 140 COL=COL,72
IF (DATUM(COL).NE.BLANK) GO TO 150
140 CONTINUE
C REACHED END-OF-RECORD - NULL ELEMENT
GO TO 380
C FOUND A NON-BLANK CHARACTER - CHECK IF NULL ELEMENT
150 CHAR=DATUM(COL)
IF (CHAR.EQ.COMMA) GO TO 370
IF (CHAR.EQ.DOLLAR) GO TO 380
C THE ELEMENT IS NOT NULL
IF (MODE) 230,200,160
C TREAT IT AS AN ALPHANUMERIC CHARACTER STRING
160 DO 170 I=1,10
IF (CHAR.EQ.DIGIT(I)) GO TO 230
170 CONTINUE
C IT IS NOT A DIGIT - SAVE FIRST CHARACTER
FINPUT=CHAR
C MOVE PAST REMAINDER OF THE ALPHANUMERIC STRING
180 COL=COL+1
IF (COL.GT.72) GO TO 380
CHAR=DATUM(COL)
IF (CHAR.EQ.DOLLAR) GO TO 380
IF (CHAR.EQ.COMMA) GO TO 370
IF (CHAR.EQ.BLANK) GO TO 360
GO TO 180
C TREAT IT AS NUMERIC
C GENERAL NUMERIC INITIALIZATION
200 NUMER=.FALSE.
ISIGND=0
DIGD=.FALSE.
POINT=.FALSE.
DECIM=0.0
ESW=.FALSE.
IEXPO=0
C CHARACTER SEARCH
210 DO 220 I=1,10
IF (CHAR.EQ.DIGIT(I)) GO TO 240
220 CONTINUE
IF (CHAR.EQ.DPLUS) GO TO 280
IF (CHAR.EQ.DMINUS) GO TO 290
IF (CHAR.EQ.DPOINT) GO TO 320
IF (CHAR.EQ.E.OR.CHAR.EQ.G) GO TO 330
C NON-NUMERIC TYPE CHARACTER
IF (NUMER) GO TO 390
C THIS ELEMENT IS OF THE WRONG TYPE - INDICATE ERROR
230 IERR=1
GO TO 400
C DIGIT
240 IF (ESW) GO TO 250
C UPDATE FIXED POINT PART
IF (POINT) IEXPO=IEXPO-1
DIGD=.TRUE.
R=DVAL(I)
IF (ISIGND.EQ.(-1)) R=-R
DECIM=10.0*DECIM+R
GO TO 350
C UPDATE EXPONENT PART
250 I=I-1
IF (ISIGNE.EQ.(-1)) I=-I
IEXPO=10*IEXPO+I
IF (DIGD) GO TO 350
C FIXED POINT PART WAS AT MOST A SIGN - CAN TAKE CARE OF THAT NOW
IF (ISIGND) 260,350,270
260 DECIM=-1.0
GO TO 350
270 DECIM=1.0
GO TO 350
C PLUS SIGN
280 I=1
GO TO 300
C MINUS SIGN
290 I=-1
300 IF (ESW) GO TO 310
C NUMERIC SIGN
IF (ISIGND.NE.0) GO TO 390
ISIGND=I
GO TO 350
C EXPONENT SIGN
310 IF (ISIGNE.NE.0) GO TO 390
ISIGNE=I
GO TO 350
C DECIMAL POINT
320 IF (POINT.OR.ESW) GO TO 390
POINT=.TRUE.
GO TO 350
C E
330 IF (ESW) GO TO 390
C EXPONENT PART INITIALIZATION
ESW=.TRUE.
ISIGNE=0
DECIM=DECIM*10.0**IEXPO
IEXPO=0
C GET NEXT CHARACTER
350 NUMER=.TRUE.
COL=COL+1
IF (COL.GT.72) GO TO 390
CHAR=DATUM(COL)
IF (CHAR.EQ.COMMA) GO TO 390
IF (CHAR.EQ.DOLLAR) GO TO 390
IF (CHAR.NE.BLANK) GO TO 210
C BLANK IS THE DELIMITER
FINPUT=DECIM*10.0**IEXPO
C IGNORE TRAILING BLANKS
360 COL=COL+1
IF (COL.GT.72) GO TO 380
CHAR=DATUM(COL)
IF (CHAR.EQ.BLANK) GO TO 360
C MOVE TO COLUMN AFTER A COMMA
370 IF (CHAR.EQ.COMMA) COL=COL+1
C END OF SCAN - INDICATE NO ERROR
380 IERR=0
RETURN
C DELIMITER - FINISH UP
390 FINPUT=DECIM*10.0**IEXPO
GO TO 370
C ERROR OR END OF RECORD - RESET COLUMN POINTER TO ZERO
400 COL=0
RETURN
END
FUNCTION KINPUT(MODE,IERR)
C KINPUT EQUALS FINPUT ROUNDED TO INTEGER
R=FINPUT(MODE,IERR)
IF (R) 10,20,30
10 K=R-0.5
GO TO 40
20 K=0
GO TO 40
30 K=R+0.5
40 KINPUT=K
RETURN
END
BLOCK DATA
COMMON/EXTRA2/TY(30)
C MODIFIED FOR BLOCKS A,C,E 25 APR 74.
DATA TY(1)/1HA/
DATA TY(3)/1HC/
DATA TY(5)/1HE/
C
DATA TY(2)/1HB/
DATA TY(4)/1HD/
DATA TY(6)/1HF/
DATA TY(7)/1HG/
DATA TY(8)/1HH/
DATA TY(9)/1HI/
DATA TY(10)/1HJ/
DATA TY(11)/1HK/
DATA TY(12)/1HL/
DATA TY(13)/1HM/
DATA TY(14)/1HN/
DATA TY(15)/1HO/
DATA TY(16)/1HP/
DATA TY(17)/1HQ/
DATA TY(18)/1HR/
DATA TY(19)/1HS/
DATA TY(20)/1HT/
DATA TY(21)/1HU/
DATA TY(22)/1HV/
DATA TY(23)/1HW/
DATA TY(24)/1HX/
DATA TY(25)/1HY/
DATA TY(26)/1HZ/
DATA TY(27)/1H+/
DATA TY(28)/1H-/
DATA TY(29)/1H//
DATA TY(30)/1H /
END