Trailing-Edge
-
PDP-10 Archives
-
decuslib10-13
-
reh2c.for
There are 3 other files named reh2c.for in the archive. Click here to see a list.
C RENBR(REH2C/CONVERT HOLLERITH RENBR TO CHARACTER TYPE)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
CHARACTER*1 LTRBFR(80),LTRCPY(80),LTRDGT(10),
1LTROPR(51),LTREND(9)
CHARACTER*1 LTRSIX(16),LTRPR1(16),LWRPR1(16),LTR072(16)
CHARACTER*1 LTRNOW
DIMENSION MCHOPR(51),NOTOPR(51)
CHARACTER FILINP*10,FILOUT*10
DATA LTRDGT/'0','1','2','3','4','5','6','7','8','9'/
C
C FORTRAN OPERATORS
DATA LTROPR/'.','A','a','N','n','D','d','E','e','Q',
1 'q','V','v','G','g','L','l','E','e','N',
2 'n','E','e','Q','q','V','v','O','o','T',
3 't','X','x','O','o','R','r','.','(',')',
4 '=','+','-','*','/',',','<','>','#',':',
5 '^'/
DATA MCHOPR/ 2, 4, 4, 6, 6, 38, 38, 10, 10, 12,
1 12, 38, 38, 18, 18, 18, 18, 38, 38, 22,
2 22, 24, 24, 26, 26, 38, 38, 30, 30, 38,
3 38, 34, 34, 36, 36, 38, 38, 0, 0, 0,
4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
5 0/
DATA NOTOPR/ 39, 3, 8, 5, 0, 7, 0, 9, 14, 11,
1 0, 13, 38, 15, 16, 17, 20, 19, 30, 21,
2 32, 23, 28, 25, 38, 27, 0, 29, 0, 31,
3 0, 33, 34, 35, 0, 37, 0, 0, 40, 41,
4 42, 43, 44, 45, 46, 47, 48, 49, 50, 51,
5 0/
C
C MAXEND = NUMBER OF CHARACTERS TO MATCH IN END STATEMENT
C LTREND = CHARACTERS OF END STATEMENT
DATA MAXEND/9/
DATA LTREND/' ',' ',' ',' ',' ',' ','E','N','D'/
C
C LINES WHICH MUST BE FOLLOWED BY CHARACTER STATEMENTS
DATA LTRSIX/'C','O','M','M','O','N','/','R','N','B',
1 'S','I','X','/','L','T'/
DATA LTRPR1/'D','I','M','E','N','S','I','O','N',' ',
1 'L','T','R','P','R','1'/
DATA LWRPR1/'D','I','M','E','N','S','I','O','N',' ',
1 'L','W','R','P','R','1'/
DATA LTR072/'D','I','M','E','N','S','I','O','N',' ',
1 'L','T','R','0','7','2'/
C
C UNIT NUMBERS FOR READING AND WRITING
DATA IDISK,JDISK/1,20/
C
C GET NAME OF FILE TO BE PROCESSED
TYPE 1
1 FORMAT(' REH2C (03/85)'/
1' CONVERTS RENBR USING HOLLERITH TO USE CHARACTER TYPE INSTEAD'/)
2 TYPE 3
3 FORMAT(' ORIGINAL HOLLERITH FILE: ',$)
ACCEPT 4,FILINP
4 FORMAT(1A10)
OPEN(UNIT=IDISK,FILE=FILINP,ACCESS='SEQIN',ERR=5)
GO TO 7
5 TYPE 6
6 FORMAT(' CANNOT OPEN ORIGINAL FILE')
GO TO 2
7 CONTINUE
C
C GET NAME OF NEW FILE
8 TYPE 9
9 FORMAT(' OUTPUT CHARACTER TYPE FILE: ',$)
ACCEPT 4,FILOUT
OPEN(UNIT=JDISK,FILE=FILOUT,ACCESS='SEQOUT',ERR=10)
GO TO 12
10 TYPE 11
11 FORMAT(' CANNOT OPEN OUTPUT FILE')
GO TO 8
12 CONTINUE
C
C READ NEXT INPUT LINE
KONTIN=0
KOMMON=0
IFSHOW=1
13 READ(IDISK,14,END=56)LTRBFR
14 FORMAT(80A1)
MAXBFR=80
15 IF(LTRBFR(MAXBFR).NE.' ')GO TO 16
MAXBFR=MAXBFR-1
IF(MAXBFR.GT.0)GO TO 15
GO TO 13
16 CONTINUE
IF(IFSHOW.NE.0)TYPE 17,(LTRBFR(I),I=1,MAXBFR)
17 FORMAT(1X,80A1)
IFSHOW=0
C
C CHECK IF THIS IS AN END LINE
IF(MAXBFR.NE.MAXEND)GO TO 19
DO 18 INDEX=1,MAXEND
IF(LTRBFR(INDEX).NE.LTREND(INDEX))GO TO 19
18 CONTINUE
IFSHOW=1
19 CONTINUE
C
C CHECK FOR COMMENT LINES AND CONTINUATION LINES
IF(LTRBFR(1).EQ.'C')GO TO 20
IF(LTRBFR(6).NE.' ')GO TO 30
C
C INSERT CHARACTER STATEMENTS
20 IF(KOMMON.EQ.0)GO TO 30
I=KOMMON
KOMMON=0
GO TO(21,24,26,28),I
21 WRITE(JDISK,22)
WRITE(JDISK,23)
22 FORMAT(
1'C'/
2'C SINGLE CHARACTER VARIABLES IN COMMON/RNBFIV/'/
3' CHARACTER*1 LTRCLN,LTRDDD,LTRDOT,LTREEE,LTREQL,'/
4' 1 LTREXC,LTRHHH,LTRLFT,LTRMNS,LTRNOW,LTRPLS,'/
5' 2 LTRQOT,LTRREF,LTRRIT,LTRSEM,LTRSLA,LTRSPC,'/
6' 3 LTRTAB,LTR1ST,LTR2ND,LWRDDD,LWREEE,LWRHHH')
23 FORMAT(
1'C'/
2'C CHARACTER ARRAYS IN COMMON/RNBSIX/'/
3' CHARACTER*1 LTRABC,LTRBGN,LTRBIG,LTRCOM,LTRDGT,'/
4' 1 LTREND,LTRFLG,LTRKEY,LTRNAM,LTROPR,LTRPRS,'/
5' 2 LTRSPL,LTRSRT,LTRTOC,LTRTOP,LTRTTL,LTRTYP,'/
6' 3 LTRUSE,LTR120,LWRABC,LWRBGN,LWREND,LWRFLG,'/
7' 4 LWRKEY,LWRPRS,LWRSRT,LWRTTL')
GO TO 30
24 WRITE(JDISK,25)
25 FORMAT(
1' CHARACTER*1 LTRPR1,LTR101,LTR201,LTR301')
GO TO 30
26 WRITE(JDISK,27)
27 FORMAT(
1' CHARACTER*1 LWRPR1,LWR101,LWR201,LWR301')
GO TO 30
28 WRITE(JDISK,29)
29 FORMAT(
1' CHARACTER*1 LTR072')
GO TO 30
C
C LOOK FOR STATEMENTS TO BE FOLLOWED BY CHARACTER DECLARATIONS
30 IF(LTRBFR(1).EQ.'C')GO TO 54
DO 36 KNDLIN=1,4
NOWBFR=6
DO 35 I=1,16
NOWBFR=NOWBFR+1
GO TO(31,32,33,34),KNDLIN
31 IF(LTRBFR(NOWBFR).EQ.LTRSIX(I))GO TO 35
GO TO 36
32 IF(LTRBFR(NOWBFR).EQ.LTRPR1(I))GO TO 35
GO TO 36
33 IF(LTRBFR(NOWBFR).EQ.LWRPR1(I))GO TO 35
GO TO 36
34 IF(LTRBFR(NOWBFR).EQ.LTR072(I))GO TO 35
GO TO 36
35 CONTINUE
KOMMON=KNDLIN
GO TO 37
36 CONTINUE
37 CONTINUE
C
C CONVERT H NOTATION TO QUOTE NOTATION
KOPY=0
NOWBFR=0
DO 38 I=1,6
KOPY=KOPY+1
NOWBFR=NOWBFR+1
38 LTRCPY(KOPY)=LTRBFR(NOWBFR)
C
C LOOK FOR FIRST NON-OPERATOR CHARACTER
39 NOWBFR=NOWBFR+1
40 IF(NOWBFR.GT.MAXBFR)GO TO 53
LOOKAT=NOWBFR
ITEST=1
41 IF(LOOKAT.GT.MAXBFR)GO TO 46
LTRNOW=LTRBFR(LOOKAT)
42 IF(LTRNOW.EQ.' ')GO TO 44
IF(LTRNOW.EQ.LTROPR(ITEST))GO TO 43
ITEST=NOTOPR(ITEST)
IF(ITEST.EQ.0)GO TO 46
GO TO 42
43 ITEST=MCHOPR(ITEST)
IF(ITEST.EQ.0)GO TO 45
44 LOOKAT=LOOKAT+1
GO TO 41
45 IF(NOWBFR.GT.LOOKAT)GO TO 40
KOPY=KOPY+1
LTRCPY(KOPY)=LTRBFR(NOWBFR)
NOWBFR=NOWBFR+1
GO TO 45
46 CONTINUE
C
C CHECK FOR NUMBER FOLLOWED BY H
DO 47 I=1,10
IF(LTRBFR(NOWBFR).EQ.LTRDGT(I))GO TO 48
47 CONTINUE
GO TO 52
48 LOOK=NOWBFR
NUMBER=0
49 DO 50 I=1,10
IF(LTRBFR(LOOKAT).NE.LTRDGT(I))GO TO 50
NUMBER=(10*NUMBER)+I-1
LOOKAT=LOOKAT+1
GO TO 49
50 CONTINUE
IF(LTRBFR(LOOKAT).NE.'H')GO TO 52
C
C CONVERT H NOTATION TO APOSTROPHE NOTATION
KOPY=KOPY+1
LTRCPY(KOPY)=''''
DO 51 I=1,NUMBER
LOOKAT=LOOKAT+1
KOPY=KOPY+1
LTRCPY(KOPY)=LTRBFR(LOOKAT)
IF(LTRBFR(LOOKAT).NE.'''')GO TO 51
KOPY=KOPY+1
LTRCPY(KOPY)=''''
51 CONTINUE
KOPY=KOPY+1
LTRCPY(KOPY)=''''
NOWBFR=LOOKAT
GO TO 39
52 KOPY=KOPY+1
LTRCPY(KOPY)=LTRBFR(NOWBFR)
GO TO 39
C
C OUTPUT THE COPIED LINE
53 WRITE(JDISK,14)(LTRCPY(I),I=1,KOPY)
GO TO 13
C
C OUTPUT THE ORIGINAL LINE
54 KONTIN=0
55 WRITE(JDISK,14)(LTRBFR(I),I=1,MAXBFR)
GO TO 13
56 STOP
END