Google
 

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