Trailing-Edge
-
PDP-10 Archives
-
decuslib10-04
-
43,50343/datgen.cbl
There is 1 other file named datgen.cbl in the archive. Click here to see a list.
00100 IDENTIFICATION DIVISION.
00200 PROGRAM-ID.DATGEN.
00300 AUTHOR. JOHN KAY DEC UK.
00400 REMARKS. GENERATES A TEST DATA FILE.
00500 DATA DIVISION.
00600 WORKING-STORAGE SECTION.
00700 01 VERSION PIC 9 COMP VALUE 1.
00800 01 FILNAM PIC X(10).
00900 01 BLOCKN.
01000 02 BRICK OCCURS 2000 TIMES PIC X(6).
01100 01 INAREA REDEFINES BLOCKN COMP .
01200 02 INTWORDS OCCURS 2000 TIMES PIC 9(10) COMP.
01300 01 PROMM PIC 9 COMP VALUE ZERO.
01400
01500 77 MODE PIC X.
01600 77 SIXBIT PIC 9 COMP.
01700 77 FSEP PIC X DISPLAY-7.
01800 77 RNUM PIC 99 COMP.
01900 77 N PIC 9999 COMP VALUE 1.
02000 77 RECID PIC 99 COMP.
02100 77 RECL PIC 9999 COMP.
02200 77 WORKB PIC 999 COMP.
02300 77 WORKC PIC 999 COMP.
02400 77 M PIC 9 COMP.
02410 77 ANSWER PIC XXX DISPLAY-7.
02500 01 INREC.
02600 02 INRECF OCCURS 120 PIC X DISPLAY-7.
02700 * PROMPT MUST ALWAYS FOLLOW INREC.
02800 01 PROMPT PIC X(18).
02900 01 WORKL.
03000 02 WORK OCCURS 6 PIC X.
03100 01 FILLS.
03200 02 FILLER PIC X(5).
03300 02 FILLR PIC X.
03400 01 FILLP REDEFINES FILLS PIC 9(5) COMP.
03500 77 ERR PIC 99 COMP.
03600
03700
03800 PROCEDURE DIVISION.
03900 PHASE1.
04000 DISPLAY " ".
04100 DISPLAY " TEST DATA FILE GENERATOR-VERSION",VERSION.
04200 DISPLAY "-----------------------------------".
04300 DISPLAY "*******************************".
04400 DISPLAY "* *".
04500 DISPLAY "* FILE SPECIFICATION PHASE *".
04600 DISPLAY "* *".
04700 DISPLAY "*******************************".
04800 FILIN.
04900 MOVE ZERO TO ERR.
04950 MOVE SPACES TO FILNAM.
05000 DISPLAY " FILENAME:" WITH NO ADVANCING.
05100 ACCEPT FILNAM.
05200 ENTER MACRO INITIO USING FILNAM,ERR.
05300 IF ERR = 1 DISPLAY " INVALID FILENAME" GO TO FILIN.
05400 DISPLAY " OUTPUT MODE? TYPE S OR A:" WITH NO ADVANCING.
05500 MOVE 0 TO SIXBIT.
05600 ACCEPT MODE.
05700 IF MODE = "A" MOVE 1 TO SIXBIT.
05800 DISPLAY " FIELD SEPARATOR:" WITH NO ADVANCING.
05900 ACCEPT FSEP.
06000 IF FSEP = " " MOVE HIGH-VALUE TO FSEP.
06100
06125 IF ERR NOT EQUAL ZERO GO TO ERRS2.
06150 ENTER MACRO OUTIO USING SIXBIT.
06200
06300 PHASE2.
06350 ADD 1 TO N.
06400 DISPLAY " ".
06500 DISPLAY "*******************************".
06600 DISPLAY "* *".
06700 DISPLAY "* RECORD SPECIFICATION PHASE *".
06800 DISPLAY "* *".
06900 DISPLAY "*******************************".
07000 DISPLAY " ".
07003 FILNM.
07005 MOVE SPACES TO FILNAM.
07010 DISPLAY " RECORD LAYOUTS - FILENAME:" WITH NO ADVANCING.
07015 ACCEPT FILNAM.
07020 IF FILNAM = SPACES GO TO PHASE2A.
07022 MOVE ZERO TO ERR.
07025 ENTER MACRO RECRED USING FILNAM,ERR,INAREA.
07027 IF ERR NOT = ZERO GO TO ERRS4.
07030 ENDSCH.
07035 IF BRICK(N) NOT = HIGH-VALUES GO TO ENDNXT.
07040 ADD 1 TO N.
07045 IF BRICK (N) NOT =HIGH-VALUES GO TO ENDNXT.
07050 SUBTRACT 1 FROM N.
07055 GO TO PHASE2A.
07060 ENDNXT.
07065 ADD 1 TO N.
07070 IF N < 2000 GO TO ENDSCH.
07075 DISPLAY "RECORD LAYOUT AREA OVERFLOW".
07080 GO TO PHASEFIN.
07100 PHASE2A.
07200 MOVE ZERO TO ERR.
07300 DISPLAY " RECORD NUMBER:" WITH NO ADVANCING.
07400 ACCEPT RNUM.
07500 IF RNUM = 0 GO TO ENDP2.
07550 IF N < 3 GO TO NOTEST.
07600 SUBTRACT 2 FROM N.
07700 IF BRICK(N) NOT = HIGH-VALUES ADD 2 TO N.
07750 NOTEST.
07800 ENTER MACRO RECCK USING INAREA,RNUM,N.
07900 IF ERR = 1 DISPLAY "RECORD ID NOT UNIQUE" ,GO TO PHASE2A.
08000 MOVE HIGH-VALUES TO BRICK(N).
08100 ADD 1 TO N.
08200 DRECL.
08300 DISPLAY " RECORD LENGTH:" WITH NO ADVANCING.
08400 ACCEPT RECL.
09100 DISPLAY " FILLER CHARACTER:" WITH NO ADVANCING.
09200 ACCEPT FILLR.
09300 MOVE RNUM TO INTWORDS(N).
09400 MULTIPLY 64 BY INTWORDS(N).
09500 MULTIPLY 4096 BY INTWORDS(N).
09600 ADD RECL TO INTWORDS(N).
09700 MULTIPLY 64 BY INTWORDS(N).
09800 ADD FILLP TO INTWORDS(N).
09900 ADD 1 TO N.
10000 PHASE2B.
10100 DISPLAY " ".
10200 DISPLAY "DESC TYPE INPUT CHAR LENGTH INIT INC".
10300 DISPLAY " METHOD POSN (CHARS) VALUE".
10400 DISPLAY "---------------------------------------------------".
10500 PHASE2C.
10600 ACCEPT INREC.
10700 IF INREC = SPACES GO TO PHASE2A.
10800 MOVE ZERO TO ERR.
10900 MOVE SPACES TO BRICK(N).
11000 MOVE SPACES TO WORKL.
11100 PERFORM MOVEDESC VARYING M FROM 1 BY 1 UNTIL
11200 INRECF(M) = " " OR M > 6.
11300 IF INRECF(M) NOT = " " MOVE 1 TO ERR , GO TO ERRS2.
11400 MOVE WORKL TO BRICK(N).
11500 ADD 1 TO N.
11600 ENTER MACRO VETRC USING INREC,INAREA,N,SIXBIT.
11700 IF ERR NOT EQUAL ZERO GO TO ERRS2.
11800 GO TO PHASE2C.
11900 MOVEDESC.
12000 MOVE INRECF(M) TO WORK(M).
12100 EXITP. EXIT.
12200 ENDP2.
12205 DISPLAY " ARE YOU SURE?" WITH NO ADVANCING.
12210 ACCEPT ANSWER.
12215 IF ANSWER = "N " OR "NO " GO TO PHASE2A.
12220 IF N < 3 GO TO NOTST.
12225 SUBTRACT 2 FROM N.
12230 IF BRICK(N) NOT = HIGH-VALUES ADD 2 TO N.
12235 NOTST.
12300 MOVE HIGH-VALUES TO BRICK(N).
12400 ADD 1 TO N.
12500 MOVE HIGH-VALUES TO BRICK(N).
12502 FILN.
12505 DISPLAY " SAVE RECORD LAYOUTS-FILENAME:" WITH NO ADVANCING.
12507 MOVE SPACES TO FILNAM.
12510 ACCEPT FILNAM.
12515 IF FILNAM = SPACES GO TO PHASE3.
12517 MOVE ZERO TO ERR.
12520 ENTER MACRO RECRIT USING FILNAM ,ERR ,INAREA.
12525 IF ERR = 16 GO TO ERRS2.
12530 IF ERR = 18 GO TO ERRS3.
12540 IF ERR = 1 OR 17 DISPLAY"INVALID FILENAME" ,GO TO FILN.
12600
12700
12800 PHASE3.
12900 DISPLAY " ".
13000 DISPLAY "*******************************".
13100 DISPLAY "* *".
13200 DISPLAY "* RECORD GENERATION PHASE *".
13300 DISPLAY "* *".
13400 DISPLAY "*******************************".
13500 DISPLAY " ".
13600 DISREC.
13700 MOVE SPACES TO INREC.
13800 DISPLAY " RECORD ID:" WITH NO ADVANCING.
13900 ACCEPT RECID.
14000 IF RECID EQUAL ZERO GO TO PHASE4.
14100 MOVE ZERO TO ERR.
14200 MOVE SPACES TO PROMPT.
14300 MOVE ZERO TO PROMM.
14400 ENTER MACRO GENREC USING INAREA,RECID,PROMPT,FSEP,INREC,PROMM.
14500 PHASEPROMPT.
14600 IF PROMM = 3 GO TO DISREC.
14700 IF ERR = 1 DISPLAY " INVALID RECORD ID" , GO TO DISREC.
14750 IF FSEP NOT = HIGH-VALUES AND PROMM = 2 GO TO NOACC.
14800 DISPLAY PROMPT WITH NO ADVANCING.
14900 DISPLAY " " WITH NO ADVANCING.
15000 IF PROMM = 2 GO TO NOACCEPT.
15100 INACC.
15200 MOVE ZERO TO ERR.
15300 ACCEPT INREC.
15310 IF INREC = SPACES DISPLAY " "WITH NO ADVANCING.
15400 ENTER MACRO DVALUE USING INREC , PROMPT.
15500 IF ERR NOT EQUAL ZERO GO TO ERRS3.
15800 GO TO PHASEPROMPT.
15900 NOACCEPT.
15910 DISPLAY " ".
15920 DISPLAY " " WITH NO ADVANCING.
15930 NOACC.
16000 ENTER MACRO OVALUE USING PROMPT.
16100 PHASE3A.
16200 IF ERR NOT EQUAL ZERO GO TO ERRS3.
16400 GO TO PHASEPROMPT.
16500
16600 PHASE4.
16605 DISPLAY " ARE YOU SURE? " WITH NO ADVANCING.
16610 ACCEPT ANSWER.
16615 IF ANSWER = "N " OR "NO " GO TO DISREC.
16700 ENTER MACRO CLOS.
16800 DISPLAY " END OF RUN".
16900 GO TO PHASEFIN.
17000 ERRS2.
17100 IF ERR =1 DISPLAY "DESCRIPTION TOO LONG".
17200 IF ERR = 2 DISPLAY "INVALID TYPE".
17300 IF ERR = 3 DISPLAY "INVALID INPUT METHOD".
17400 IF ERR = 4 DISPLAY "INVALID CHARACTER POSITION".
17500 IF ERR = 5 DISPLAY "FIELDS OVERLAP".
17600 IF ERR = 6 DISPLAY "BINARY FIELD IN ASCII RECORD".
17700 IF ERR = 7 DISPLAY "BINARY FIELD NOT FULL WORD ALIGNED".
17800 IF ERR = 8 DISPLAY "INVALID FIELD LENGTH ".
17900 IF ERR = 9 DISPLAY "INVALID INITIAL VALUE ".
18000 IF ERR = 10 DISPLAY "INVALID INCREMENT".
18100 IF ERR = 11 DISPLAY "FLOATING POINT NOT AVAILABLE".
18200 IF ERR = 12 DISPLAY "DOUBLE LENGTH COMP NOT AVAILABLE".
18300 SUBTRACT 1 FROM N.
18400 IF ERR = 16 DISPLAY "I/O ERROR ON INIT" GO TO PHASEFIN.
18500 IF ERR = 17 DISPLAY "I/O ERROR ON ENTER " GO TO PHASEFIN.
18600
18700
18800
18900 GO TO PHASE2C.
19000 ERRS3.
19005 IF ERR = 22 DISPLAY "ERROR ON OUTPUT UUO" , GO TO PHASEFIN.
19010 IF ERR = 2 DISPLAY " VALUE INPUT OUT OF RANGE".
19020 IF ERR = 3 DISPLAY " USER INPUT REQUIRED".
19030 MOVE ZERO TO ERR.
19035 GO TO PHASEPROMPT.
19040 ERRS4.
19050 IF ERR = 16 DISPLAY "I/O ERROR ON INIT".
19060 IF ERR = 17 DISPLAY " I/O ERROR ON LOOKUP" ,GO TO FILNM.
19070 IF ERR = 18 DISPLAY "I/O ERROR ON INPUT UUO".
19075 IF ERR = 1 DISPLAY "INVALID FILNAME" ,GO TO FILNM.
19080 GO TO PHASEFIN.
19100 PHASEFIN.
19200 STOP RUN.