Trailing-Edge
-
PDP-10 Archives
-
decuslib10-09
-
43,50466/srt.f4
There are no other files named srt.f4 in the archive.
C WESTERN MICHIGAN UNIVERSITY
C SRT.F4 (FILENAME ON LIBRARY DECTAPE)
C SRT, 3.10.1 (CALLING NAME, SUBLST. NO.)
C DATA FILE BREAKDOWN PROGRAM
C PROGRAMMED BY SAM ANEMA AT WMU--LATER MODIFIED BY R.R. BARR
C LIBRARY DECTAPE PROGS USED: USAGE.MAC
C APLIB PROGS. USED: IO
C FORWMU PROGS. USED: DEVCHG, EXISTS, PRINTS, DEVICE
C INTERNAL SUBR. USED: OPEN
C FUNCTIONS USED: ECODE
C ABOVE COMMENTS AND RIGHT ADJUSTED COMMENTS PUT IN BY WG
C
C---------------INT IS USER'S INPUT, IN IS USER'S INPUT WITHOUT
C--------------- SPACES. NBR(20) GIVES THE BREAKDOWN RANGES,
C--------------- B(16) IS USED IN FUNCTION ECODE FOR TEMPORARY STORAGE
C
DIMENSION INT(80),IN(80),NBR(20),B(16),IFMT(16),ISH(20),KNAME(20)
DIMENSION KNT(20),INA(160)
TYPE 8
8 FORMAT('0WMU - CSR--DATA FILE BREAKDOWN PROGRAM',//)
C CALL USAGE('SRT ')
C---------------FORTRAN DEV.NO=1, MNEMONIC FOR FORTRAN DEV.NO.,
C--------------- DIALOGUE OUTPUT DEV.NO.=-1, DIALOGUE INPUT DEVICE
C--------------- NO.=-4, FIRST 0 MEANS SUPPRESS PRINTING INPUT?
C--------------- SECOND 0 MEANS JOB IS TTY.
9 CALL IO(1,IDV,-1,-4,0,0)
DO 10 I=6,30
10 CALL DEVCHG('DSK',I)
101 K=0
102 TYPE 100
100 FORMAT(' *',$)
ACCEPT 11,INT
11 FORMAT(80A1)
IF=0
IL=0
ISW=0
NC=1
NREC=1
J=0
DO 12 I=1,80
IN(I)=' '
IF(INT(I).EQ.' ')GO TO 12
K=K+1
IN(K)=INT(I)
12 CONTINUE
IF(IN(1).NE.'B')GO TO 201
I=0
200 I=I+1
IF(I.GT.80)GO TO 201
IF(IN(I).EQ.'(')GO TO 202
IF(IN(I).EQ.',')GO TO 203
IF(IN(I).EQ.'-')GO TO 303
IF(IN(I).EQ.':')GO TO 205
IF(IN(I).EQ.')')GO TO 206
IF(IN(I).EQ.'C')GO TO 701
IF(IN(I).EQ.'/')GO TO 702
GO TO 200
201 TYPE 301
C---------------CALL EXIT IF FORTRAN UNIT 5 IS NOT TELETYPE.
CALL DEVICE(5)
301 FORMAT(' ?ILLEGAL COMMAND'/)
GO TO 101
202 CALL ECODE(5,IN,I+1,B)
C---------------PUT INFO. BETWEEN '(' AND '-' INTO IF (SEE
C--------------- WRITE UP BOTTOM OF PAGE 2)
DECODE(5,302,B)IF
302 FORMAT(I)
IF(IF.GT.80.OR.IF.LT.1)GO TO 201
GO TO 200
203 IF(ISW.EQ.0)GO TO 303
J=J+1
CALL ECODE(10,IN,I+1,B)
C---------------PUT INFO. BETWEEN: AND / INTO NBR(J)
DECODE(10,302,B)NBR(J)
GO TO 200
303 IF(ISW.EQ.1)GO TO 200
CALL ECODE(5,IN,I+1,B)
C---------------PUT INFO BETWEEN '-' AND 'C' INTO IL
DECODE(5,302,B)IL
IF(IL.GT.80.OR.IL.LT.1)GO TO 201
GO TO 200
205 ISW=1
GO TO 203
701 CALL ECODE(5,IN,I+1,B)
C---------------PUT INFO BETWEEN C AND : INTO NC
DECODE(5,302,B)NC
GO TO 200
702 CALL ECODE(5,IN,I+1,B)
C---------------PUT INFO BETWEEN / AND ) INTO NREC
DECODE(5,302,B)NREC
GO TO 200
C---------------HERE WHEN THE USER'S B COMMAND HAS BEEN STORED
206 IF(NC.GT.NREC.OR.NC.LT.1)GO TO 201
C---------------WHEN NO OF RECORDS PER CASE >11, IT IS ILLEGAL COMMAND
IF(NREC.GT.11.OR.NREC.LT.1)GO TO 201
C---------------ICB, ICA, ICUT, ILAST ARE USED
C--------------- IN ST. 50, 50+1, 71+1, 72-1
ICB=NC-1
ICA=NREC-ICB-1
ICUT=16*ICB
ILAST=(ICB+ICA)*16
I1=0
I2=0
I3=0
I4=0
I5=0
I6=0
K=IF-1
IF(K.GT.5)GO TO 403
I2=K
GO TO 405
403 I1=K/5
I2=K-I1*5
405 IF(IL.EQ.0)IL=IF
C---------------CALCULATE WIDTH OF KEY FIELD
I3=IL-IF+1
K=80-IL
IF(K.GT.5)GO TO 410
I5=K
GO TO 420
410 I4=K/5
I5=K-I4*5
C---------------BETWEEN HERE AND ST. 425 WE PUT TOGETHER A FORTRAN
C--------------- FORMAT MAKING USE OF I1, I2, I3, I4, I5
420 DO 421 I=2,6
421 IFMT(I)=' '
KN=0
IFMT(1)='('
IF(I1.EQ.0)GO TO 422
KN=KN+I1
ENCODE(5,429,IFMT(2))I1
429 FORMAT(I2,'A5,')
422 IF(I2.EQ.0)GO TO 423
KN=KN+1
ENCODE(5,430,IFMT(3))I2
430 FORMAT('A',I3,',')
423 KN=KN+1
KS=KN
ENCODE(5,431,IFMT(4))I3
431 FORMAT('I',I3,',')
IF(I4.EQ.0)GO TO 424
KN=KN+I4
ENCODE(5,432,IFMT(5))I4
432 FORMAT(I2,'A5,')
424 IF(I5.EQ.0)GO TO 425
KN=KN+1
ENCODE(5,433,IFMT(6))I5
433 FORMAT('A',I3,')')
GO TO 426
425 IFMT(6)=')'
426 DO 427 I=1,20
ISH(I)=0
KNT(I)=0
427 CONTINUE
TYPE 428
428 FORMAT(' FILES?(4 CHARACTERS) ',$)
ACCEPT 449,IFN
449 FORMAT(A4)
C---------------THIS CAUSES AN A TO BE ATTACHED TO USER SPECIFIED
C--------------- 4 CH. FOR A SUBFILE.
IFN=IFN+66
L=1
C---------------J=NO. OF SUBFILES (SEE ST. 203+1)
IF(J.EQ.0)L=0
C---------------ICB=RECORD NO. OF KEY FIELD MINUS 1 (ST. 206+2)
50 IF(ICB.EQ.0)GO TO 71
C---------------ICUT (ST. 206+4), READ NREC RECORDS
READ(1,79,END=500)(INA(I),I=1,ICUT)
79 FORMAT(16A5)
C---------------KN=NO. OF WORDS TO BE READ AS SPEC. BY IFTMT(16)
71 READ(1,IFMT,END=500)(IN(I),I=1,KN)
IF(ICA.EQ.0)GO TO 72
READ(1,79,END=500)(INA(I),I=ICUT+1,ILAST)
C---------------L=0 WHEN J=0. THIS IS CASE WHERE USER OMITS RANGE
C--------------- LIMITS FOR SUBFILES. THEN PROGRAM CREATES AN OUTPUT
C--------------- FILE FOR EACH VALUE OF KEY. (SEE SECTION 2.2
C--------------- OF WRITE UP)
72 IF(L.EQ.0)GO TO 51
DO 52 JJ=1,J
C---------------COMPARE KEYFIELD WITH RANGE CRITERION FOR A
C--------------- SUBFILE. KEYFIELD IS DETERMINED IN ST. 423+1.
IF(IN(KS).LE.NBR(JJ))GO TO 53
52 CONTINUE
GO TO 50
53 IF(ISH(JJ).EQ.0)CALL OPEN(JJ,IFN,KNAME,ISH)
IDN=JJ+5
IF(ICB.EQ.0)GO TO 81
WRITE(IDN,79)(INA(I),I=1,ICUT)
81 WRITE(IDN,IFMT)(IN(I),I=1,KN)
IF(ICA.EQ.0)GO TO 82
WRITE(IDN,79)(INA(I),I=ICUT+1,ILAST)
82 KNT(JJ)=KNT(JJ)+1
GO TO 50
500 TYPE 501
501 FORMAT(10X,'NO OF'/2X,'FILE',3X,'RECORDS',3X,'KEY'/)
C---------------KNAME(I)=FILENAME GEN. BY USER AND PROG.,
C--------------- KNT(I)=NO. OF RECORDS IN KNAME(I),
C--------------- NBR(I)=BOUNDARIES FOR GENERATED FILES
TYPE 502,(KNAME(I),KNT(I),NBR(I),I=1,J)
502 FORMAT(1X,A5,2I8)
TYPE 503
503 FORMAT(////)
C---------------GO TO INPUT?
GO TO 9
51 IF(J.EQ.0)GO TO 58
DO 59 I=1,J
IF(IN(KS).EQ.NBR(I))GO TO 60
59 CONTINUE
58 J=J+1
NBR(J)=IN(KS)
JJ=J
GO TO 53
60 JJ=I
GO TO 53
END
C---------------J, IFN, ISH INPUT, KNAME RETURNED, ISH MODIFIED
C--------------- SUBR. OPEN THE PROG. AND USER SPEC. FILENAME TO
C--------------- BE ASSOC. WITH IDN
SUBROUTINE OPEN(J,IFN,KNAME,ISH)
DIMENSION KNAME(20),ISH(20)
IDN=J+5
CALL OFILE(IDN,IFN)
KNAME(J)=IFN
C---------------THIS CAUSES B,C, ETC. TO BE ATTACHED TO USER SPEC.
C--------------- 4 CH. FOR SUBFILES.
IFN=IFN+2
ISH(J)=1
RETURN
END
C---------------N, I, IN ARE INPUT. B IS MODIFIED. USER SPEC.
C--------------- INFO. IS PUT INTO B.
FUNCTION ECODE(N,IN,I,B)
DIMENSION IN(1),IX(10),IC(6),B(1)
DATA IC/',','-',':',')','C','/'/
K=0
NC=6
DO 802 L=I,80
IF(K.GE.N)GO TO 808
DO 800 M=1,NC
800 IF(IN(L).EQ.IC(M))GO TO 804
K=K+1
802 IX(K)=IN(L)
804 IF(K.GE.N)GO TO 808
DO 806 L=K+1,N
806 IX(L)=' '
808 ENCODE(N,810,B)(IX(L),L=1,N)
810 FORMAT(10A1)
812 RETURN
END