Trailing-Edge
-
PDP-10 Archives
-
decuslib20-07
-
decus/20-0170/merge.for
There are 3 other files named merge.for in the archive. Click here to see a list.
C RENBR(MERGE/MERGE FROFF COMPOSITE TEST FILES)
C
C DONALD E. BARTH, YALE SCHOOL OF MANAGEMENT
C
C THE VERIFICATION FILES SUPPLIED WITH FROFF EACH
C CONTAIN MANY TEST CASES OR THE RESULTS WHICH ARE
C EXPECTED WHEN THESE TEST CASES ARE PROCESSED. EACH
C TEST CASE BEGINS WITH A LINE CONTAINING THE COMMAND
C .DEBUG FOLLOWED BY A UNIQUE NAME OF 6 OR LESS
C CHARACTERS. EACH RESULT BEGINS WITH A LINE
C CONTAINING THE WORD DEBUG FOLLOWED BY THE NAME OF THE
C TEST CASE. THIS PROGRAM MERGES THE INDIVIDUAL TEST
C CASES INTO A COMPOSITE TEST FILE, AND MERGES THE
C INDIVIDUAL RESULT FILES EXPECTED FROM PROCESSING THE
C INDIVIDUAL TEST CASES INTO A COMPOSITE RESULT FILE.
C AN ADDITIONAL FILE IS READ WHICH CONTAINS THE NAMES
C OF THE TEST CASES.
C
DIMENSION LTRBFR(132),LTRTRY(6),LTRGET(6),LTRCMP(6),
1LTRMAX(6),LTRALL(10),LWRTRY(6),LWRGET(6),LWRALL(10)
DOUBLE PRECISION FILINP,FILOUT,FILNAM,FILBAS
DATA LTRALL/1H.,1HR,1HE,1HS,1HE,1HT,1H ,1HA,1HL,1HL/
DATA LWRALL/1H.,1Hr,1He,1Hs,1He,1Ht,1H ,1Ha,1Hl,1Hl/
DATA LTRTRY/1H.,1HD,1HE,1HB,1HU,1HG/
DATA LWRTRY/1H.,1Hd,1He,1Hb,1Hu,1Hg/
DATA LTRGET/1H ,1HD,1HE,1HB,1HU,1HG/
DATA LWRGET/1H ,1Hd,1He,1Hb,1Hu,1Hg/
DATA LTRSPA/1H /
DATA IDSK,JDSK,KDSK/1,20,21/
TYPE 1
1 FORMAT(' MERGE'/
1' MERGES FROFF TEST CASES INTO COMPOSITE FILES'/
2' LIST OF NAMES MUST BE IN FILE HAVING .NAM EXTENSION'/
3' INDIVIDUAL TEST FILES MUST HAVE .RNO EXTENSION'/
4' INDIVIDUAL RESULT FILES MUST HAVE .DOC EXTENSION')
TYPE 2
2 FORMAT(' MERGE WHICH FILE (NO PERIOD): ',$)
ACCEPT 3,FILBAS
3 FORMAT(1A10)
ENCODE(10,4,FILNAM)FILBAS
4 FORMAT(1A6,4H.NAM)
C
C MERGE THE INDIVIDUAL TEST CASES
OPEN(UNIT=KDSK,FILE=FILNAM,ACCESS='SEQIN',ERR=42)
IFOPEN=0
MAXWID=0
5 READ(KDSK,6,END=23)LTRCMP
6 FORMAT(6A1)
IF(IFOPEN.NE.0)GO TO 8
ENCODE(10,7,FILOUT)FILBAS
7 FORMAT(1A6,4H.TRY)
OPEN(UNIT=JDSK,FILE=FILOUT,ACCESS='SEQOUT')
8 IFOPEN=IFOPEN+1
ENCODE(10,9,FILINP)LTRCMP
9 FORMAT(6A1,4H.RNO)
OPEN(UNIT=IDSK,FILE=FILINP,ACCESS='SEQIN',ERR=46)
KNTLIN=0
IRESET=0
10 READ(IDSK,11,END=21)LTRBFR
11 FORMAT(132A1)
MAXBFR=132
12 IF(LTRBFR(MAXBFR).NE.LTRSPA)GO TO 13
MAXBFR=MAXBFR-1
IF(MAXBFR.GT.1)GO TO 12
13 IF(KNTLIN.NE.0)GO TO 15
DO 14 I=1,6
IF(LTRBFR(I).EQ.LTRTRY(I))GO TO 14
IF(LTRBFR(I).EQ.LWRTRY(I))GO TO 14
GO TO 48
14 CONTINUE
15 IRESET=0
IF(MAXBFR.NE.10)GO TO 17
DO 16 I=1,10
IF(LTRBFR(I).EQ.LTRALL(I))GO TO 16
IF(LTRBFR(I).NE.LWRALL(I))GO TO 17
16 CONTINUE
IRESET=1
17 KNTLIN=KNTLIN+1
IF(MAXWID.GE.MAXBFR)GO TO 19
MAXWID=MAXBFR
DO 18 I=1,6
LTRMAX(I)=LTRCMP(I)
18 CONTINUE
19 WRITE(JDSK,20)(LTRBFR(I),I=1,MAXBFR)
20 FORMAT(132A1)
GO TO 10
21 IF(IRESET.EQ.0)WRITE(JDSK,22)
22 FORMAT('.RESET')
CLOSE(UNIT=IDSK)
GO TO 5
23 CLOSE(UNIT=KDSK)
IF(IFOPEN.EQ.0)GO TO 44
CLOSE(UNIT=JDSK)
TYPE 24,IFOPEN,MAXWID,LTRMAX
24 FORMAT(' NUMBER OF TEST CASES',1I4/
1' LENGTH OF LONGEST LINE',1I4/
2' LONGEST LINE IS IN TEST CASE ',6A1)
C
C MERGE THE INDIVIDUAL RESULTS
OPEN(UNIT=KDSK,FILE=FILNAM,ACCESS='SEQIN')
IFOPEN=0
MAXWID=0
25 READ(KDSK,26,END=40)LTRCMP
26 FORMAT(6A1)
IF(IFOPEN.NE.0)GO TO 28
ENCODE(10,27,FILOUT)FILBAS
27 FORMAT(1A6,4H.GET)
OPEN(UNIT=JDSK,FILE=FILOUT,ACCESS='SEQOUT')
28 IFOPEN=IFOPEN+1
ENCODE(10,29,FILINP)LTRCMP
29 FORMAT(6A1,4H.DOC)
OPEN(UNIT=IDSK,FILE=FILINP,ACCESS='SEQIN',ERR=50)
KNTLIN=0
30 READ(IDSK,31,END=39)LTRBFR
31 FORMAT(132A1)
MAXBFR=132
32 IF(LTRBFR(MAXBFR).NE.LTRSPA)GO TO 33
MAXBFR=MAXBFR-1
IF(MAXBFR.GT.1)GO TO 32
33 IF(KNTLIN.NE.0)GO TO 35
DO 34 I=1,6
IF(LTRBFR(I).EQ.LTRGET(I))GO TO 34
IF(LTRBFR(I).EQ.LWRGET(I))GO TO 34
GO TO 52
34 CONTINUE
35 KNTLIN=KNTLIN+1
IF(MAXWID.GE.MAXBFR)GO TO 37
MAXWID=MAXBFR
DO 36 I=1,6
LTRMAX(I)=LTRCMP(I)
36 CONTINUE
37 WRITE(JDSK,38)(LTRBFR(I),I=1,MAXBFR)
38 FORMAT(132A1)
GO TO 30
39 CLOSE(UNIT=IDSK)
GO TO 25
40 CLOSE(UNIT=KDSK)
CLOSE(UNIT=JDSK)
TYPE 41,MAXWID,LTRMAX
41 FORMAT(' LENGTH OF LONGEST LINE',1I4/
1' LONGEST LINE IS IN RESULT ',6A1)
GO TO 54
C
C ERROR MESSAGES
42 TYPE 43
43 FORMAT(' NAME FILE MISSING')
GO TO 54
44 TYPE 45
45 FORMAT(' NAME FILE IS EMPTY')
GO TO 54
46 TYPE 47,LTRCMP
47 FORMAT(' INDIVIDUAL TEST CASE ',6A1,' MISSING')
GO TO 54
48 TYPE 49,LTRCMP
49 FORMAT(' INDIVIDUAL TEST CASE ',6A1,' MISSING DEBUG LINE')
GO TO 54
50 TYPE 51,LTRCMP
51 FORMAT(' INDIVIDUAL RESULT ',6A1,' MISSING')
GO TO 54
52 TYPE 53,LTRCMP
53 FORMAT(' INDIVIDUAL RESULT ',6A1,' MISSING DEBUG LINE')
GO TO 54
54 STOP
END