Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-09 - decus/20-34/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