PDP-10 Archive: decus/20-0081/datgen.cbl from decuslib20-03

Trailing-Edge - PDP-10 Archives - decuslib20-03 - decus/20-0081/datgen.cbl
There is 1 other file named datgen.cbl in the archive. Click here to see a list.
IDENTIFICATION DIVISION.
PROGRAM-ID.DATGEN.
AUTHOR. JOHN KAY DEC UK.
REMARKS. GENERATES A TEST DATA FILE.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 VERSION PIC 9 COMP VALUE 1.
01 FILNAM PIC X(10).
01 BLOCKN.
   02 BRICK OCCURS 2000 TIMES PIC X(6).
01 INAREA REDEFINES BLOCKN COMP .
02 INTWORDS OCCURS 2000 TIMES PIC 9(10) COMP.
01 PROMM PIC 9 COMP VALUE ZERO.

77 AMODE PIC X.
77 ASIXBIT PIC 9 COMP.
77 FSEP PIC X DISPLAY-7.
77 RNUM PIC 99 COMP.
77 N PIC 9999 COMP VALUE 1.
77 RECID PIC 99 COMP.
77 RECL PIC 9999 COMP.
77 WORKB PIC 999 COMP.
77 WORKC PIC 999 COMP.
77 M PIC 9 COMP.
77 ANSWER PIC XXX DISPLAY-7.
01 INREC.
   02 INRECF OCCURS 120 PIC X DISPLAY-7.
* PROMPT MUST ALWAYS FOLLOW INREC.
01 PROMPT PIC X(18).
01 WORKL.
   02 WORK OCCURS 6 PIC X.
01 FILLS.
02 FILLER PIC X(5).
02 FILLR PIC X.
01 FILLP REDEFINES FILLS PIC 9(5) COMP.
77 ERR PIC 99 COMP.


PROCEDURE DIVISION.
PHASE1.
DISPLAY " ".
DISPLAY " TEST DATA FILE GENERATOR-VERSION",VERSION.
DISPLAY "-----------------------------------".
DISPLAY "*******************************".
DISPLAY "*                             *".
DISPLAY "* FILE SPECIFICATION PHASE    *".
DISPLAY "*                             *".
DISPLAY "*******************************".
FILIN.
MOVE ZERO TO ERR.
MOVE SPACES TO FILNAM.
DISPLAY " FILENAME:" WITH NO ADVANCING.
ACCEPT FILNAM.
ENTER MACRO INITIO USING FILNAM,ERR.
IF ERR = 1 DISPLAY " INVALID FILENAME" GO TO FILIN.
DISPLAY " OUTPUT MODE? TYPE S OR A:" WITH NO ADVANCING.
MOVE 0 TO ASIXBIT.
ACCEPT AMODE.
IF AMODE = "A" MOVE 1 TO ASIXBIT.
DISPLAY " FIELD SEPARATOR:" WITH NO ADVANCING.
ACCEPT FSEP.
IF FSEP = " " MOVE HIGH-VALUE TO FSEP.

IF ERR NOT EQUAL ZERO GO TO ERRS2.
ENTER MACRO OUTIO USING ASIXBIT.

PHASE2.
ADD 1 TO N.
DISPLAY " ".
DISPLAY "*******************************".
DISPLAY "*                             *".
DISPLAY "* RECORD SPECIFICATION PHASE  *".
DISPLAY "*                             *".
DISPLAY "*******************************".
DISPLAY " ".
FILNM.
MOVE SPACES TO FILNAM.
DISPLAY " RECORD LAYOUTS - FILENAME:" WITH NO ADVANCING.
ACCEPT FILNAM.
IF FILNAM = SPACES GO TO PHASE2A.
MOVE ZERO TO ERR.
ENTER MACRO RECRED USING FILNAM,ERR,INAREA.
IF ERR NOT = ZERO GO TO ERRS4.
ENDSCH.
IF BRICK(N) NOT = HIGH-VALUES GO TO ENDNXT.
ADD 1 TO N.
IF BRICK (N) NOT =HIGH-VALUES GO TO ENDNXT.
SUBTRACT 1 FROM N.
GO TO PHASE2A.
ENDNXT.
ADD 1 TO N.
IF N < 2000 GO TO ENDSCH.
DISPLAY "RECORD LAYOUT AREA OVERFLOW".
GO TO PHASEFIN.
PHASE2A.
MOVE ZERO TO ERR.
DISPLAY " RECORD NUMBER:" WITH NO ADVANCING.
ACCEPT RNUM.
IF RNUM = 0 GO TO ENDP2.
IF N < 3 GO TO NOTEST.
SUBTRACT 2 FROM N.
IF BRICK(N) NOT = HIGH-VALUES ADD 2 TO N.
NOTEST.
ENTER MACRO RECCK USING INAREA,RNUM,N.
IF ERR = 1 DISPLAY "RECORD ID NOT UNIQUE" ,GO TO PHASE2A.
MOVE HIGH-VALUES TO BRICK(N).
ADD 1 TO N.
DRECL.
DISPLAY " RECORD LENGTH:" WITH NO ADVANCING.
ACCEPT RECL.
DISPLAY " FILLER CHARACTER:" WITH NO ADVANCING.
ACCEPT FILLR.
MOVE RNUM TO INTWORDS(N).
MULTIPLY 64 BY INTWORDS(N).
MULTIPLY 4096 BY INTWORDS(N).
ADD RECL TO INTWORDS(N).
MULTIPLY 64 BY INTWORDS(N).
ADD FILLP TO INTWORDS(N).
ADD 1 TO N.
PHASE2B.
DISPLAY " ".
DISPLAY "DESC    TYPE    INPUT   CHAR    LENGTH  INIT    INC".
DISPLAY "                METHOD  POSN    (CHARS) VALUE".
DISPLAY "---------------------------------------------------".
PHASE2C.
ACCEPT INREC.
IF INREC = SPACES GO TO PHASE2A.
MOVE ZERO TO ERR.
MOVE SPACES TO BRICK(N).
MOVE SPACES TO WORKL.
PERFORM MOVEDESC VARYING M FROM 1 BY 1 UNTIL
INRECF(M) = "	" OR M > 6.
IF INRECF(M) NOT = "	" MOVE 1 TO ERR , GO TO ERRS2.
MOVE WORKL TO BRICK(N).
ADD 1 TO N.
ENTER MACRO VETRC USING INREC,INAREA,N,ASIXBIT.
IF ERR NOT EQUAL ZERO GO TO ERRS2.
GO TO PHASE2C.
MOVEDESC.
MOVE INRECF(M) TO WORK(M).
EXITP. EXIT.
ENDP2.
DISPLAY " ARE YOU SURE?" WITH NO ADVANCING.
ACCEPT ANSWER.
IF ANSWER = "N  " OR "NO " GO TO PHASE2A.
IF N < 3 GO TO NOTST.
SUBTRACT 2 FROM N.
IF BRICK(N) NOT = HIGH-VALUES ADD 2 TO N.
NOTST.
MOVE HIGH-VALUES TO BRICK(N).
ADD 1 TO N.
MOVE HIGH-VALUES TO BRICK(N).
FILN.
DISPLAY " SAVE RECORD LAYOUTS-FILENAME:" WITH NO ADVANCING.
MOVE SPACES TO FILNAM.
ACCEPT FILNAM.
IF FILNAM = SPACES GO TO PHASE3.
MOVE ZERO TO ERR.
ENTER MACRO RECRIT USING FILNAM ,ERR ,INAREA.
IF ERR = 16 GO TO ERRS2.
IF ERR = 18 GO TO ERRS3.
IF ERR = 1 OR 17 DISPLAY"INVALID FILENAME" ,GO TO FILN.


PHASE3.
DISPLAY " ".
DISPLAY "*******************************".
DISPLAY "*                             *".
DISPLAY "* RECORD GENERATION PHASE     *".
DISPLAY "*                             *".
DISPLAY "*******************************".
DISPLAY " ".
DISREC.
MOVE SPACES TO INREC.
DISPLAY "        RECORD ID:" WITH NO ADVANCING.
ACCEPT RECID.
IF RECID EQUAL ZERO GO TO PHASE4.
MOVE ZERO TO ERR.
MOVE SPACES TO PROMPT.
MOVE ZERO TO PROMM.
ENTER MACRO GENREC USING INAREA,RECID,PROMPT,FSEP,INREC,PROMM.
PHASEPROMPT.
IF PROMM = 3 GO TO DISREC.
IF ERR = 1 DISPLAY " INVALID RECORD ID" , GO TO DISREC.
IF FSEP NOT = HIGH-VALUES AND PROMM = 2 GO TO NOACC.
DISPLAY PROMPT WITH NO ADVANCING.
DISPLAY "      " WITH NO ADVANCING.
IF PROMM = 2 GO TO NOACCEPT.
INACC.
MOVE ZERO TO ERR.
ACCEPT INREC.
IF INREC = SPACES DISPLAY "			"WITH NO ADVANCING.
ENTER MACRO DVALUE USING INREC , PROMPT.
IF ERR NOT EQUAL ZERO GO TO ERRS3.
GO TO PHASEPROMPT.
NOACCEPT.
DISPLAY " ".
DISPLAY "			" WITH NO ADVANCING.
NOACC.
ENTER MACRO OVALUE USING PROMPT.
PHASE3A.
IF ERR NOT EQUAL ZERO GO TO ERRS3.
GO TO PHASEPROMPT.

PHASE4.
DISPLAY " ARE YOU SURE? " WITH NO ADVANCING.
ACCEPT ANSWER.
IF ANSWER = "N  " OR "NO " GO TO DISREC.
ENTER MACRO CLOS.
DISPLAY " END OF RUN".
GO TO PHASEFIN.
ERRS2.
IF ERR =1 DISPLAY "DESCRIPTION TOO LONG".
IF ERR = 2 DISPLAY "INVALID TYPE".
IF ERR = 3 DISPLAY "INVALID INPUT METHOD".
IF ERR = 4 DISPLAY "INVALID CHARACTER POSITION".
IF ERR = 5 DISPLAY "FIELDS OVERLAP".
IF ERR = 6 DISPLAY "BINARY FIELD IN ASCII RECORD".
IF ERR = 7 DISPLAY "BINARY FIELD NOT FULL WORD ALIGNED".
IF ERR = 8 DISPLAY "INVALID FIELD LENGTH ".
IF ERR = 9 DISPLAY "INVALID INITIAL VALUE ".
IF ERR = 10 DISPLAY "INVALID INCREMENT".
IF ERR = 11 DISPLAY "FLOATING POINT NOT AVAILABLE".
IF ERR = 12 DISPLAY "DOUBLE LENGTH COMP NOT AVAILABLE".
SUBTRACT 1 FROM N.
IF ERR = 16 DISPLAY "I/O ERROR ON INIT" GO TO PHASEFIN.
IF ERR = 17 DISPLAY "I/O ERROR ON ENTER " GO TO PHASEFIN.



GO TO PHASE2C.
ERRS3.
IF ERR = 22 DISPLAY "ERROR ON OUTPUT UUO" , GO TO PHASEFIN.
IF ERR = 2 DISPLAY " VALUE INPUT OUT OF RANGE".
IF ERR = 3 DISPLAY " USER INPUT REQUIRED".
MOVE ZERO TO ERR.
GO TO PHASEPROMPT.
ERRS4.
IF ERR = 16 DISPLAY "I/O ERROR ON INIT".
IF ERR = 17 DISPLAY " I/O ERROR ON LOOKUP" ,GO TO FILNM.
IF ERR = 18 DISPLAY "I/O ERROR ON INPUT UUO".
IF ERR = 1 DISPLAY "INVALID FILNAME" ,GO TO FILNM.
GO TO PHASEFIN.
PHASEFIN.
STOP RUN.