Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-11 - 43,50534/csstot.cbl
There is 1 other file named csstot.cbl in the archive. Click here to see a list.
IDENTIFICATION DIVISION.
PROGRAM-ID. CSSTOT, VERSION-5, EDIT-5.
AUTHOR. BOB CONLON.
DATE-WRITTEN. 29-OCT-75, MODIFIED 04-FEB-81.
DATE-COMPILED.
REMARKS. THIS MODULE CREATES A COBOL SOURCE FILE BASED ON THE
	 EQUATIONS QUERIED FROM THE TTY.  IT WILL IN TURN PERFORM
	 THAT MATHEMATICAL OPERATION ON THE DATA BASE.

ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. DECSYSTEM-10.
OBJECT-COMPUTER. DECSYSTEM-10.

INPUT-OUTPUT SECTION.
FILE-CONTROL.

    SELECT FORMAT-FILE		ASSIGN TO DSK.

    SELECT VALID-FILE		ASSIGN TO DSK.

    SELECT SOURCE-FILE		ASSIGN TO DSK.

DATA DIVISION.
FILE SECTION.

FD  FORMAT-FILE; VALUE OF IDENTIFICATION IS FORMAT-NAME.

01  FORMAT-RECORD		PIC X(4035).

FD  VALID-FILE; VALUE OF IDENTIFICATION IS VLD-NAME.

01  VALID-RECORD.
    02 VB OCCURS 4000 TIMES	PIC X.

FD  SOURCE-FILE; VALUE OF IDENTIFICATION IS SOURCE-NAME.

01  SOURCE-RECORD		PIC X(84).

WORKING-STORAGE SECTION.
77  LINE-NUM			PIC S9(3); COMP.
77  D-LINE-NUM			PIC Z(3).
77  EXTRA-IND			PIC S9(6); COMP.
77  IR-IND			PIC S9(3); COMP.
77  IA-IND			PIC S9(3); COMP.
77  DONE-FLAG			PIC 9; COMP.
77  VLD-IND			PIC S9(3); COMP.
77  WR-IND			PIC S9(3); COMP.
77  PROMPT-IND			PIC S9(3); COMP.
77  USER-PASSWORD			PIC X(6).
77  A PIC X(24); VALUE "IDENTIFICATION DIVISION.".
77  E PIC X(15); VALUE "DATE-COMPILED.".
77  G PIC X(21); VALUE "ENVIRONMENT DIVISION.".
77  H PIC X(22); VALUE "CONFIGURATION SECTION.".
77  I PIC X(30); VALUE "SOURCE-COMPUTER. DECSYSTEM-10.".
77  J PIC X(30); VALUE "OBJECT-COMPUTER. DECSYSTEM-10.".
77  K PIC X(21); VALUE "INPUT-OUTPUT SECTION.".
77  L PIC X(13); VALUE "FILE-CONTROL.".
77  O PIC X(14); VALUE "DATA DIVISION.".
77  P PIC X(13); VALUE "FILE SECTION.".
77  R PIC X(11); VALUE "01  REC-IN.".
77  S PIC X(39); VALUE "FD  FORMAT-FILE             COPY FDFMT.".
77  T PIC X(24); VALUE "WORKING-STORAGE SECTION.".
77  W PIC X(17); VALUE "01  FILE-IN-NAME.".
77  Z PIC X(40); VALUE "01  PROMPT-INFO             COPY WSFMT1.".
77  A1 PIC X(19); VALUE "PROCEDURE DIVISION.".
77  A2 PIC X(16); VALUE "OPENING SECTION.".
77  A3 PIC X(32); VALUE "CHECK-IT.          COPY PRCHKPW.".
77  A4 PIC X(33); VALUE "PRIV-CHK.          COPY PRCHKPV2.".
77  A5 PIC X(31); VALUE "OPEN-IT.           COPY PRORD.".
77  A6 PIC X(33); VALUE "CONT.              COPY PRREWIT.".
77  A7 PIC X(34); VALUE "    MOVE OP-PAGE TO OVERLAY-ARRAY.".
77  A8 PIC X(9); VALUE "TOTAL-UP.".
77  BEF-DEC				PIC S9(3); COMP.
77  OP-FLAG				PIC 9; VALUE ZERO.
77  OL-ARRAY				PIC X(18); VALUE "01  OVERLAY-ARRAY.".
77  POUND	PIC X(34); VALUE "##################################".
77  REC-TYPE			PIC S9(3); COMP.


01  ZERO-LINE.
    02 FILLER PIC X(17); VALUE "    MOVE ZERO TO ".
    02 ZL-NUM		PIC Z(3).
    02 FILLER PIC X(5); VALUE "HOLD.".

01  TOTAL-UP-LINE-1.
    02 FILLER PIC X(36); VALUE "    PERFORM TOTAL-UP VARYING I FROM ".
    02 FILLER PIC X(17); VALUE "1 BY 1 UNTIL I > ".
    02 TUL1-NUM		PIC Z(3).
    02 FILLER PIC X; VALUE ".".

01  C.
    02 FILLER PIC X(8);VALUE "AUTHOR. ".
    02 AUTH-NAME		PIC X(32).
    02 FILLER 		PIC X; VALUE ".".

01  TOTAL-UP-LINE-2.
    02 FILLER PIC X(12); VALUE "    COMPUTE ".
    02 TUL2-NUM1 PIC Z(3).
    02 FILLER PIC X(7); VALUE "HOLD = ".
    02 TUL2-NUM2 PIC Z(3).
    02 FILLER PIC X(7); VALUE "HOLD + ".
    02 TUL2-NUM3 PIC Z(3).
    02 FILLER PIC X(6); VALUE "IN(I).".

01  IND.
    02 FILLER PIC X(29); VALUE "77  I".
    02 FILLER PIC X(16); VALUE "PIC S9(4); COMP.".

01  03-SYM.
    02 FILLER PIC X(10); VALUE "       03 ".
    02 03-ISYM-NUM1		PIC Z(3).
    02 FILLER PIC X(20); VALUE "INN".
    02 FILLER PIC X(4); VALUE "PIC ".
    02 03-ISYM-TYPE		PIC X(2).
    02 FILLER PIC X; VALUE "(".
    02 03-ISYM-NUM2		PIC 9(3).
    02 FILLER PIC X; VALUE ")".
    02 03-ISYM-PIC-INFO.
       03 03-ISYM-P-OR-V		PIC X(3).
       03 03-ISYM-NUM3			PIC 9(3).
       03 03-ISYM-PAREN2		PIC XX.
       03 03-ISYM-LIT		PIC X(17).

01  77-LINE.
    02 FILLER PIC X(4); VALUE "77  ".
    02 77-NUM1		PIC Z(3).
    02 FILLER PIC X(22); VALUE "HOLD".
    02 FILLER PIC X(7); VALUE "PIC S9(".
    02 77-NUM2			PIC 9(3).
    02 FILLER PIC X; VALUE ")".
    02 77-PIC-INFO.
       03 77-P-OR-V		PIC X(3).
       03 77-NUM3		PIC 9(3).
       03 77-PAREN2		PIC X(8).


01  OA-LINE.
    02 FILLER PIC X(17); VALUE "    02 OA OCCURS ".
    02 OAL-NUM1			PIC Z(3).
    02 FILLER PIC X(7); VALUE " TIMES.".

01  OA-LINE-OUT.
    02 FILLER PIC X(10); VALUE "       03 ".
    02 OALO-NUM1			PIC Z(3).
    02 FILLER PIC X(16); VALUE "IN".
    02 FILLER PIC X(4); VALUE "PIC ".
    02 OALO-TYPE		PIC X(3).
    02 OALO-NUM2		PIC 9(3).
    02 FILLER PIC X; VALUE ")".
    02 OALO-PIC-INFO.
       03 OALO-P-OR-V		PIC X(3).
       03 OALO-NUM3		PIC 9(3).
       03 OALO-PAREN2		PIC X(2).

01  B.
    02 FILLER PIC X(13); VALUE "PROGRAM-ID.".
    02 B-NAME			PIC X(6).
    02 FILLER			PIC X; VALUE ".".

01  D.
    02 FILLER PIC X(14); VALUE "DATE-WRITTEN.".
    02 D-DD		PIC Z9.
    02 FILLER		PIC X; VALUE "-".
    02 D-MON		PIC X(3).
    02 FILLER		PIC X; VALUE "-".
    02 D-YY		PIC 99.
    02 FILLER		PIC X; VALUE ".".

01  F.
    02 FILLER PIC X(21); VALUE "REMARKS.  THIS PROGRA".
    02 FILLER PIC X(21); VALUE "M WRITTEN BY CSSTOT.".

01  M.
    02 FILLER PIC X(18); VALUE "    SELECT FILE-IN".
    02 FILLER PIC X(19); VALUE SPACES.
    02 FILLER PIC X(13); VALUE "ASSIGN TO DSK".

01  M1.
    02 FILLER PIC X(37); VALUE SPACES.
    02 FILLER PIC X(22); VALUE "ACCESS MODE IS INDEXED".

01  M2.
    02 FILLER PIC X(37); VALUE SPACES.
    02 FILLER PIC X(23); VALUE "SYMBOLIC KEY IS SYM-KEY".

01  M3.
    02 FILLER PIC X(37); VALUE SPACES.
    02 FILLER PIC X(22); VALUE "RECORD KEY IS REC-KEY.".

01  N.
    02 FILLER PIC X(22); VALUE "    SELECT FORMAT-FILE".
    02 FILLER PIC X(15); VALUE SPACES.
    02 FILLER PIC X(14); VALUE "ASSIGN TO DSK.".

01  Q.
    02 FILLER PIC X(29); VALUE "FD  FILE-IN; RECORD CONTAINS".
    02 Q-NUM			PIC Z(4).
    02 FILLER PIC X(11); VALUE " CHARACTERS".

01  Q1.
    02 FILLER PIC X(28); VALUE "             BLOCK CONTAINS".
    02 Q1-NUM			PIC Z(3).
    02 FILLER PIC X(8); VALUE " RECORDS".

01  Q2.
    02 FILLER PIC X(13); VALUE SPACES.
    02 FILLER PIC X(40); VALUE "VALUE OF IDENTIFICATION IS FILE-IN-NAME.".

01  U.
    02 FILLER PIC X(13); VALUE "77  VERS-NUM".
    02 FILLER PIC X(15); VALUE SPACES.
    02 FILLER PIC X(16); VALUE "PIC 9(3); VALUE ".
    02 U-NUM			PIC Z(3).
    02 FILLER PIC X; VALUE ".".

01  V.
    02 FILLER PIC X(27); VALUE "77  SYM-KEY".
    02 FILLER PIC X(4); VALUE "PIC ".
    02 SK-PIC				PIC XX.
    02 FILLER			PIC X; VALUE "(".
    02 V-NUM			PIC 9(3).
    02 FILLER PIC XX; VALUE ").".


01  X.
    02 FILLER PIC X(27); VALUE "    02 FIN".
    02 FILLER PIC X(16); VALUE "PIC X(6); VALUE ".
    02 FILLER PIC X; VALUE QUOTE.
    02 X-FNAME			PIC X(6).
    02 FILLER PIC X; VALUE QUOTE.
    02 FILLER PIC X; VALUE ".".

01  Y.
    02 FILLER PIC X(27); VALUE "    02 FILLER".
    02 FILLER PIC X(16); VALUE "PIC X(3); VALUE".
    02 FILLER PIC X; VALUE QUOTE.
    02 FILLER PIC X(3); VALUE "IDX".
    02 FILLER PIC X; VALUE QUOTE.
    02 FILLER PIC X; VALUE ".".

01  P-TODAY.
    02 TOD.
       03 P-YY		PIC 99.
       03 P-MM		PIC 99.
       03 P-DD		PIC 99.
    02 FILLER		PIC X(6).

01  MONTH-REGISTER.
    02 FILLER PIC X(36); VALUE "JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC".

01  MONTH-ARRAY REDEFINES MONTH-REGISTER.
    02 M-BUFF OCCURS 12 TIMES PIC X(3).

01  IN-SYM.
    02 FILLER PIC X(7); VALUE "    02 ".
    02 IS-NUM1			PIC ZZ9.
    02 FILLER PIC X(3); VALUE "INN".
    02 IS-REDEF			PIC X(20).
    02 FILLER PIC X(4); VALUE "PIC".
    02 IS-PIC			PIC XX.
    02 FILLER			PIC X; VALUE "(".
    02 IS-NUM2			PIC 9(3).
    02 FILLER PIC X; VALUE ")".
    02 IS-PIC-INFO.
       03 IP-PERIOD-OR-V		PIC X(3).
       03 IP-NUM1			PIC 9(3).
       03 IP-PAREN2			PIC XX.
       03 IP-LIT			PIC X(17).

01  REC-K.
    02 FILLER PIC X(33); VALUE "    02 REC-KEY".
    02 FILLER PIC X(4); VALUE "PIC ".
    02 RK-PIC			PIC XX.
    02 FILLER PIC X; VALUE "(".
    02 RK-NUM			PIC 9(3).
    02 FILLER PIC XX; VALUE ").".

01  IA-BUFFER.
    02 IA-1 PIC X(12); VALUE "    COMPUTE ".
    02 IA-2			PIC X(72).



01  LEDFMT-RECORD.
    02 PROMPT-TABLE OCCURS 150 TIMES	PIC X(20).
    02 LENGTH-OF-FIELD OCCURS 150 TIMES PIC 9(3).
    02 NUMBER-FIELDS                    PIC 9(3).
    02 NAMES OCCURS 28 TIMES		PIC X(6).
    02 VAL-ID			PIC X.
    02 AC-DAT			PIC X.
    02 SPC			PIC X.
    02 FILLER			PIC X(3).
    02 IND-BLOCK-FACT			PIC 9(3).
    02 OVER-LAY-PAGE			PIC 9(3).
    02 BLOCKING-FACTOR			PIC 9(3).
    02 PRI.
       03 PRIV OCCURS 28 TIMES		PIC 9(3).
    02 FILLER			PIC X(3).
    02 VERSION-NUMBER			PIC 9(3).
    02 NUM-CHARS			PIC 9(4).
    02 POS-KEY				PIC 99.
    02 NUM-PAGES			PIC 9(3).
    02 TOP-LINE OCCURS 50 TIMES		PIC 9(3).
    02 DECIMAL-POSIT OCCURS 150 TIMES	PIC 9.

01  WORK-RECORD.
    02 WR-BUFF OCCURS 34 TIMES PIC X.

01  INPUT-REGISTER.
    02 IR-BUFF OCCURS 72 TIMES PIC X.

01  INPUT-ARRAY.
    02 IA-BUFF OCCURS 31 TIMES PIC X(72).

01  IN-HOLD.
    02 IN1			PIC 9.
    02 IN2			PIC 9.
    02 IN3			PIC 9.

01  IN-HOLD1 REDEFINES IN-HOLD PIC 9(3).

01  FORMAT-NAME.
    02 F-NAME.
       03 FNAME		PIC X(3).
       03 FNAME1		PIC X(3).
    02 FILLER			PIC X(3); VALUE "FMT".

01  SOURCE-NAME.
    02 SNAME.
       03 FILLER PIC X(3); VALUE "TOT".
       03 S-NAME			PIC X(3).
    02 SEXT PIC X(3); VALUE "CBL".

01  VLD-NAME.
    02 VLDNAME			PIC X(6).
    02 FILLER			PIC X(3); VALUE "VLD".

PROCEDURE DIVISION.
OPENING-SECTION.
CHECK-IT.
    ENTER MACRO NAMDAT.
    DISPLAY "TYPE NAME OF INPUT FORMAT FILE: "; WITH NO ADVANCING.
    ACCEPT F-NAME.
    IF FNAME NOT = "DBM" DISPLAY "ILLEGAL FILE NAME" GO TO CHECK-IT.
    OPEN INPUT FORMAT-FILE.
    READ FORMAT-FILE; AT END STOP RUN.
    MOVE FORMAT-RECORD TO LEDFMT-RECORD.
    IF SPC = "(" MOVE 0 TO REC-TYPE, ENTER MACRO UNSSCR USING REC-TYPE, LEDFMT-RECORD.
    IF VAL-ID NOT = "Y" DISPLAY "YOU MUST HAVE A VALIDATION FILE TO RUN CSSTOT"
    ,STOP RUN.
    ENTER MACRO NOECHO USING PROMPT-IND, BREAK-1, PRI, USER-PASSWORD.
    SET PROMPT-IND TO ZERO.

LOOP1.
    SET PROMPT-IND UP BY 1.
    IF PROMPT-IND > 28 GO TO BREAK-1.
    IF USER-PASSWORD = NAMES(PROMPT-IND) GO TO BREAK-1.
    GO TO LOOP1.

BREAK-1.
    IF PROMPT-IND > 28 DISPLAY "CANNOT ACCESS THIS DATA", STOP RUN.
    DISPLAY " ".
    IF PRIV(PROMPT-IND) < 3 DISPLAY "NO PRIVILEGES TO RUN THIS PROGRAM"
    ,STOP RUN.
    MOVE F-NAME TO VLDNAME.
    DISPLAY "CSS ARITHMETIC PROCESSOR CSSTOT(V05-5)".
    DISPLAY " ".
    DISPLAY "TYPE A 3 CHARACTER IDENTIFIER FOR THIS APPLICATION:  "; WITH NO ADVANCING.
    ACCEPT S-NAME.

GET-AUTH.
    DISPLAY " ".
    DISPLAY "TYPE IN YOUR NAME:  "; WITH NO ADVANCING.
    ACCEPT AUTH-NAME.
    IF AUTH-NAME = SPACES GO TO GET-AUTH.
    OPEN INPUT VALID-FILE.
    READ VALID-FILE; AT END STOP RUN.
    MOVE ZERO TO IR-IND, IA-IND, LINE-NUM.
    DISPLAY "TYPE IN UP TO 30 EQUATIONS; TERMINATE EACH WITH A .<CR>".
    DISPLAY " ".

LOOP2.
    IF DONE-FLAG = 1 SET LINE-NUM TO IA-IND.
    SET LINE-NUM UP BY 1.
    MOVE LINE-NUM TO D-LINE-NUM.
    DISPLAY D-LINE-NUM " : "; WITH NO ADVANCING.
    ACCEPT INPUT-REGISTER.
    IF INPUT-REGISTER NOT = "L" GO TO LOOP2-CONT.
    DISPLAY "#"; WITH NO ADVANCING.
    ACCEPT LINE-NUM.
    SET LINE-NUM DOWN BY 1.
    MOVE LINE-NUM TO IA-IND.
    GO TO LOOP2.

LOOP2-CONT.
    IF INPUT-REGISTER = SPACES GO TO NEW-PROGRAM.
    MOVE ZERO TO DONE-FLAG.
    PERFORM CHK-NUM THRU CN-EXIT VARYING IR-IND FROM 1
    ,BY 1 UNTIL IR-IND > 72.
    IF DONE-FLAG = 1 , GO TO LOOP2.
    EXAMINE INPUT-REGISTER TALLYING ALL "@".
    IF TALLY = ZERO GO TO NO-AT.
    IF OVER-LAY-PAGE > ZERO GO TO NO-AT.
    DISPLAY "YOUR DATA BASE HAS NO OVERLAY PAGE CAPABILITIES".
    DISPLAY "@ IS ILLEGAL".
    SET DONE-FLAG TO 1.
    GO TO LOOP2.

NO-AT.
    EXAMINE INPUT-REGISTER TALLYING ALL "(".
    MOVE TALLY TO EXTRA-IND.
    EXAMINE INPUT-REGISTER TALLYING ALL ")".
    IF TALLY NOT = EXTRA-IND DISPLAY "WRONG NUMBER OF PARENTHESIS"
    ,SET DONE-FLAG TO 1, GO TO LOOP2.
    EXAMINE INPUT-REGISTER TALLYING ALL ".".
    IF TALLY NOT = 1 DISPLAY "WRONG NUMBER OF PERIODS IN STATEMENT"
    ,SET DONE-FLAG TO 1, GO TO LOOP2.
    SET IA-IND UP BY 1.
    IF IA-IND > 30 GO TO NEW-PROGRAM.
    PERFORM GET-AT THRU GA-EXIT VARYING IR-IND FROM 1 BY 1
    ,UNTIL IR-IND > 72.
    MOVE INPUT-REGISTER TO IA-BUFF(IA-IND).
    GO TO LOOP2.




CHK-NUM.
    IF DONE-FLAG = 1 GO TO CN-EXIT.
    MOVE ZEROES TO IN-HOLD.
    IF IR-BUFF(IR-IND) NOT = "I" GO TO CN-EXIT.
    MOVE IR-IND TO EXTRA-IND.
    SET EXTRA-IND DOWN BY 1.
    IF EXTRA-IND = ZERO DISPLAY "INVALID SYMBOL 0INN"
    ,SET DONE-FLAG TO 1, GO TO CN-EXIT.
    IF IR-BUFF(EXTRA-IND) NOT NUMERIC DISPLAY "INVALID SYMBOL INN"
    ,SET DONE-FLAG TO 1, GO TO CN-EXIT.
    MOVE IR-BUFF(EXTRA-IND) TO IN3.
    IF EXTRA-IND = 1 PERFORM CHK-P-IND THRU CP-EXIT, GO TO CN-EXIT.
    SET EXTRA-IND DOWN BY 1.
    IF IR-BUFF(EXTRA-IND) NOT NUMERIC PERFORM CHK-P-IND THRU CP-EXIT, GO TO CN-EXIT.
    MOVE IR-BUFF(EXTRA-IND) TO IN2.
    IF EXTRA-IND = 1 PERFORM CHK-P-IND THRU CP-EXIT, GO TO CN-EXIT.
    SET EXTRA-IND DOWN BY 1.
    IF IR-BUFF(EXTRA-IND) NOT NUMERIC PERFORM CHK-P-IND THRU CP-EXIT, GO TO CN-EXIT.
    MOVE IR-BUFF(EXTRA-IND) TO IN1.
    PERFORM CHK-P-IND THRU CP-EXIT.


CN-EXIT.





CHK-P-IND.
    IF IN-HOLD1 > NUMBER-FIELDS DISPLAY IN-HOLD1 "INN DOESN'T EXIST"
    ,GO TO CP-EXIT.
    MOVE ZERO TO VLD-IND.
    PERFORM TOTAL-UP VARYING PROMPT-IND FROM 1 BY 1 UNTIL 
    PROMPT-IND = IN-HOLD1.
    MOVE POUND TO WORK-RECORD.
    ADD 1 TO VLD-IND.
    MOVE ZERO TO WR-IND.
    PERFORM GET-VLD VARYING VLD-IND FROM VLD-IND BY 1 UNTIL
    ,WR-IND = LENGTH-OF-FIELD(IN-HOLD1).
    EXAMINE WORK-RECORD TALLYING ALL SPACES.
    IF TALLY = LENGTH-OF-FIELD(IN-HOLD1) GO TO CP-EXIT.
    EXAMINE WORK-RECORD TALLYING ALL "N".
    IF TALLY NOT = LENGTH-OF-FIELD(IN-HOLD1)
    ,DISPLAY IN-HOLD1 "INN IS NOT NUMERIC IN THE VALIDATION FILE"
    ,SET DONE-FLAG TO 1.

CP-EXIT.  EXIT.


TOTAL-UP.
    COMPUTE VLD-IND = VLD-IND + LENGTH-OF-FIELD(PROMPT-IND).

GET-VLD.
    SET WR-IND UP BY 1.
    MOVE VB(VLD-IND) TO WR-BUFF(WR-IND).

GET-AT.
    IF IR-BUFF(IR-IND) NOT = "@" GO TO GA-EXIT.
    MOVE "D" TO IR-BUFF(IR-IND).
    COMPUTE EXTRA-IND = IR-IND - 1.
    MOVE "L" TO IR-BUFF(EXTRA-IND).
    SET EXTRA-IND DOWN BY 1.
    MOVE "O" TO IR-BUFF(EXTRA-IND).
    SET EXTRA-IND DOWN BY 1.
    MOVE "H" TO IR-BUFF(EXTRA-IND).

GA-EXIT.  EXIT.

NEW-PROGRAM SECTION.
NP-OPENERS.
    DISPLAY "    CREATING " SNAME "." SEXT "  ...   "; WITH NO ADVANCING.
    OPEN OUTPUT SOURCE-FILE.
    WRITE SOURCE-RECORD FROM A.
    MOVE SNAME TO B-NAME.
    WRITE SOURCE-RECORD FROM B.
    WRITE SOURCE-RECORD FROM C.
    MOVE TODAY TO P-TODAY.
    MOVE P-DD TO D-DD.
    MOVE M-BUFF(P-MM) TO D-MON.
    MOVE P-YY TO D-YY.
    WRITE SOURCE-RECORD FROM D.
    WRITE SOURCE-RECORD FROM E.
    WRITE SOURCE-RECORD FROM F BEFORE ADVANCING 2 LINES.
    WRITE SOURCE-RECORD FROM G.
    WRITE SOURCE-RECORD FROM H.
    WRITE SOURCE-RECORD FROM I.
    WRITE SOURCE-RECORD FROM J BEFORE ADVANCING 2 LINES.
    WRITE SOURCE-RECORD FROM K.
    WRITE SOURCE-RECORD FROM L BEFORE ADVANCING 2 LINES.
    WRITE SOURCE-RECORD FROM M.
    WRITE SOURCE-RECORD FROM M1.
    WRITE SOURCE-RECORD FROM M2.
    WRITE SOURCE-RECORD FROM M3 BEFORE ADVANCING 2 LINES.
    WRITE SOURCE-RECORD FROM N BEFORE ADVANCING 2 LINES.
    WRITE SOURCE-RECORD FROM O.
    WRITE SOURCE-RECORD FROM P BEFORE ADVANCING 3 LINES.
    MOVE NUM-CHARS TO Q-NUM.
    WRITE SOURCE-RECORD FROM Q.
    MOVE BLOCKING-FACTOR TO Q1-NUM.
    WRITE SOURCE-RECORD FROM Q1.
    WRITE SOURCE-RECORD FROM Q2 BEFORE ADVANCING 2 LINES.
    WRITE SOURCE-RECORD FROM R.
    SET VLD-IND TO 1.
    PERFORM RO-SETUP THRU RO-EXIT VARYING PROMPT-IND FROM 1 BY 1
    ,UNTIL LENGTH-OF-FIELD(PROMPT-IND) = ZERO.
    MOVE SPACES TO SOURCE-RECORD.
    WRITE SOURCE-RECORD BEFORE ADVANCING 2 LINES.
    WRITE SOURCE-RECORD FROM S BEFORE ADVANCING 3 LINES.
    WRITE SOURCE-RECORD FROM T.
    IF OVER-LAY-PAGE = ZERO GO TO NO-OVERLAY-1.
    MOVE TOP-LINE(OVER-LAY-PAGE) TO PROMPT-IND.
    MOVE ZERO TO VLD-IND.
    PERFORM TOTAL-UP VARYING PROMPT-IND FROM 1 BY 1
    ,UNTIL PROMPT-IND = TOP-LINE(OVER-LAY-PAGE).
    SET VLD-IND UP BY 1.
    COMPUTE IR-IND = OVER-LAY-PAGE + 1.
    PERFORM 77-SETUP THRU 77-DONE VARYING PROMPT-IND FROM PROMPT-IND
    ,BY 1 UNTIL PROMPT-IND = TOP-LINE(IR-IND).
    WRITE SOURCE-RECORD FROM IND.

NO-OVERLAY-1.
    MOVE VERSION-NUMBER TO U-NUM.
    WRITE SOURCE-RECORD FROM U.
    MOVE LENGTH-OF-FIELD(POS-KEY) TO V-NUM.
    WRITE SOURCE-RECORD FROM V.
    MOVE "77  LINE-COUNT      PIC S9(3); COMP." TO SOURCE-RECORD.
    WRITE SOURCE-RECORD BEFORE ADVANCING 3 LINES.
    IF OVER-LAY-PAGE = ZERO GO TO NO-OVERLAY-2.
    WRITE SOURCE-RECORD FROM OL-ARRAY.
    COMPUTE IR-IND = (NUM-PAGES - OVER-LAY-PAGE) + 1.
    MOVE IR-IND TO OAL-NUM1, TUL1-NUM.
    WRITE SOURCE-RECORD FROM OA-LINE.
    MOVE ZERO TO VLD-IND.
    PERFORM TOTAL-UP VARYING PROMPT-IND FROM 1 BY 1
    ,UNTIL PROMPT-IND = TOP-LINE(OVER-LAY-PAGE).
    SET VLD-IND UP BY 1.
    MOVE TOP-LINE(OVER-LAY-PAGE) TO PROMPT-IND.
    COMPUTE IR-IND = OVER-LAY-PAGE + 1.
    PERFORM OA-SETUP THRU OA-EXIT VARYING PROMPT-IND FROM PROMPT-IND
    ,BY 1 UNTIL PROMPT-IND = TOP-LINE(IR-IND).
    MOVE SPACES TO SOURCE-RECORD.
    WRITE SOURCE-RECORD.

NO-OVERLAY-2.
    WRITE SOURCE-RECORD FROM W.
    MOVE F-NAME TO X-FNAME.
    WRITE SOURCE-RECORD FROM X.
    WRITE SOURCE-RECORD FROM Y BEFORE ADVANCING 2 LINES.
    WRITE SOURCE-RECORD FROM Z BEFORE ADVANCING 3 LINES.
    WRITE SOURCE-RECORD FROM A1.
    WRITE SOURCE-RECORD FROM A2.
    WRITE SOURCE-RECORD FROM A3.
    WRITE SOURCE-RECORD FROM A4 BEFORE ADVANCING 2 LINES.
    WRITE SOURCE-RECORD FROM A5.
    PERFORM DUMP-IA THRU DIA-CONT VARYING IA-IND FROM 1 BY 1
    ,UNTIL IA-BUFF(IA-IND) = SPACES.
    WRITE SOURCE-RECORD FROM A6.
    MOVE "WRONG.  COPY PRRTWR." TO SOURCE-RECORD, WRITE SOURCE-RECORD.
    IF OVER-LAY-PAGE = ZERO GO TO NO-OVERLAY-4.
    WRITE SOURCE-RECORD FROM A8.
    MOVE ZERO TO VLD-IND.
    PERFORM TOTAL-UP VARYING PROMPT-IND FROM 1 BY 1
    ,UNTIL PROMPT-IND = TOP-LINE(OVER-LAY-PAGE).
    SET VLD-IND UP BY 1.
    COMPUTE IR-IND = OVER-LAY-PAGE + 1.
    PERFORM TOT-LIN-SETUP THRU TL-EXIT VARYING PROMPT-IND FROM PROMPT-IND
    ,BY 1 UNTIL PROMPT-IND = TOP-LINE(IR-IND).

NO-OVERLAY-4.
    CLOSE SOURCE-FILE, FORMAT-FILE, VALID-FILE.
    STOP RUN.

RO-SETUP.
    MOVE "." TO IS-PIC-INFO, 03-ISYM-PIC-INFO.
    MOVE LENGTH-OF-FIELD(PROMPT-IND) TO IS-NUM2, 03-ISYM-NUM2.
    PERFORM GET-PIC THRU GP-DONE.
    MOVE SPACES TO IS-REDEF.
    IF PROMPT-IND = POS-KEY PERFORM GET-REC-KEY.
    MOVE PROMPT-IND TO IS-NUM1, 03-ISYM-NUM1.
    IF OVER-LAY-PAGE = ZERO GO TO RO-WRITE.
    IF PROMPT-IND < TOP-LINE(OVER-LAY-PAGE) GO TO RO-WRITE.
    IF OP-FLAG = 1 GO TO RO-WRITE-03.
    MOVE "    02 OP-PAGE." TO SOURCE-RECORD.
    WRITE SOURCE-RECORD.
    SET OP-FLAG TO 1.

RO-WRITE-03.
    WRITE SOURCE-RECORD FROM 03-SYM.
    GO TO RO-EXIT.

RO-WRITE.
    WRITE SOURCE-RECORD FROM IN-SYM.

RO-EXIT.  EXIT.

GET-PIC.
    MOVE " X" TO IS-PIC, RK-PIC, 03-ISYM-TYPE.
    MOVE POUND TO WORK-RECORD.
    MOVE ZERO TO WR-IND.
    PERFORM GET-VLD VARYING VLD-IND FROM VLD-IND BY 1
    ,UNTIL WR-IND = LENGTH-OF-FIELD(PROMPT-IND).
    EXAMINE WORK-RECORD TALLYING ALL SPACES.
    IF TALLY = LENGTH-OF-FIELD(PROMPT-IND) GO TO GP-NUM.
    EXAMINE WORK-RECORD TALLYING ALL "N".
    IF TALLY NOT = LENGTH-OF-FIELD(PROMPT-IND) GO TO GP-DONE.

GP-NUM.

*** THE NEXT TWO STATEMENTS WERE MODIFIED TO ALWAYS CAUSE THE KEY ***
*** PICTURE STATEMENTS TO BE DEFINED AS PIC X                     ***

    IF PROMPT-IND = POS-KEY GO TO GP-DONE.
    MOVE "S9" TO IS-PIC, 03-ISYM-TYPE.
*** THE NEXT STATEMENT REMOVES THE "BLANK WHEN ZERO" FROM NON-DECIMAL ITEMS.
*** THE STATEMENT FOLLOWING WILL INCLUDE "BLANK WHEN ZERO" IF EXECUTED.
    IF DECIMAL-POSIT(PROMPT-IND) = ZERO GO TO GP-DONE.
*   IF DECIMAL-POSIT(PROMPT-IND) = ZERO PERFORM LIT-SETUP, GO TO GP-DONE.
    COMPUTE BEF-DEC = LENGTH-OF-FIELD(PROMPT-IND) - DECIMAL-POSIT(PROMPT-IND).
    MOVE BEF-DEC TO IS-NUM2, 03-ISYM-NUM2.
    MOVE "V9(" TO IP-PERIOD-OR-V, 03-ISYM-P-OR-V.
    MOVE DECIMAL-POSIT(PROMPT-IND) TO IP-NUM1, 03-ISYM-NUM3.
*** REMOVAL OF THE NEXT 2 STATEMENTS ELIMINATES "BLANK WHEN ZERO"
*** STATEMENTS ON ELEMENTS WITH DECIMALS.
*   MOVE ");" TO IP-PAREN2, 03-ISYM-PAREN2.
*   MOVE " BLANK WHEN ZERO." TO IP-LIT, 03-ISYM-LIT.
    MOVE ")." TO IP-PAREN2, 03-ISYM-PAREN2.

GP-DONE.  EXIT.

77-SETUP.
    MOVE POUND TO WORK-RECORD.
    MOVE ZERO TO WR-IND.
    PERFORM GET-VLD VARYING VLD-IND FROM VLD-IND BY 1
    ,UNTIL WR-IND = LENGTH-OF-FIELD(PROMPT-IND).
    EXAMINE WORK-RECORD TALLYING ALL SPACES.
    IF TALLY = LENGTH-OF-FIELD(PROMPT-IND) GO TO 77-NUM.
    EXAMINE WORK-RECORD TALLYING ALL "N".
    IF TALLY NOT = LENGTH-OF-FIELD(PROMPT-IND) GO TO 77-DONE.

77-NUM.
    MOVE LENGTH-OF-FIELD(PROMPT-IND) TO 77-NUM2.
    MOVE PROMPT-IND TO 77-NUM1.
    MOVE "; COMP." TO 77-PIC-INFO.
    IF DECIMAL-POSIT(PROMPT-IND) = ZERO GO TO 77-WRITE.
    COMPUTE BEF-DEC = LENGTH-OF-FIELD(PROMPT-IND) - DECIMAL-POSIT(PROMPT-IND).
    MOVE "V9(" TO 77-P-OR-V.
    MOVE BEF-DEC TO 77-NUM2.
    MOVE DECIMAL-POSIT(PROMPT-IND) TO 77-NUM3.
    MOVE "); COMP." TO 77-PAREN2.

77-WRITE.
    WRITE SOURCE-RECORD FROM 77-LINE.

77-DONE.  EXIT.

OA-SETUP.
    MOVE POUND TO WORK-RECORD.
    SET WR-IND TO ZERO.
    PERFORM GET-VLD VARYING VLD-IND FROM VLD-IND BY 1
    ,UNTIL WR-IND = LENGTH-OF-FIELD(PROMPT-IND).
    MOVE PROMPT-IND TO OALO-NUM1.
    MOVE " X(" TO OALO-TYPE.
    MOVE LENGTH-OF-FIELD(PROMPT-IND) TO OALO-NUM2.
    MOVE "." TO OALO-PIC-INFO.
    EXAMINE WORK-RECORD TALLYING ALL SPACES.
    IF TALLY = LENGTH-OF-FIELD(PROMPT-IND) GO TO OA-NUM.
    EXAMINE WORK-RECORD TALLYING ALL "N".
    IF TALLY NOT = LENGTH-OF-FIELD(PROMPT-IND) GO TO OA-EXIT.

OA-NUM.
    MOVE "S9(" TO OALO-TYPE.
    IF DECIMAL-POSIT(PROMPT-IND) = ZERO GO TO OA-EXIT.
    COMPUTE BEF-DEC = LENGTH-OF-FIELD(PROMPT-IND) - DECIMAL-POSIT(PROMPT-IND).
    MOVE BEF-DEC TO OALO-NUM2.
    MOVE DECIMAL-POSIT(PROMPT-IND) TO OALO-NUM3.
    MOVE "V9(" TO OALO-P-OR-V.
    MOVE ")." TO OALO-PAREN2.

OA-EXIT.
    WRITE SOURCE-RECORD FROM OA-LINE-OUT.
GET-REC-KEY.
    MOVE LENGTH-OF-FIELD(POS-KEY) TO RK-NUM.
    WRITE SOURCE-RECORD FROM REC-K.
    MOVE " REDEFINES REC-KEY" TO IS-REDEF.
    MOVE " X" TO SK-PIC.

*** THIS PREVIOUS PARAGRAPH WAS MODIFIED DELETING 4 LINES OF CODE ***
*** WHICH CHECKED AND CHANGED THE SYMBOLIC PICTURE STATEMENT IF   ***
*** VALIDATION DATA SHOWED THE KEY TO BE NUMERIC                  ***

DUMP-IA.
    EXAMINE IA-BUFF(IA-IND) TALLYING ALL "H".
    IF TALLY = 0 GO TO DIA-CONT.
*** FROM HERE TO DIA-CONT WAS MOVED SO THAT THE COLLECTIVE COMPUTATION ***
*** WILL BE DONE AFTER EVERYTHING IS COMPUTED.                             ***

    IF OVER-LAY-PAGE = ZERO GO TO DIA-CONT.
    MOVE ZERO TO VLD-IND.
    PERFORM TOTAL-UP VARYING PROMPT-IND FROM 1 BY 1
    ,UNTIL PROMPT-IND = TOP-LINE(OVER-LAY-PAGE).
    SET VLD-IND UP BY 1.
    COMPUTE IR-IND = OVER-LAY-PAGE + 1.
    PERFORM Z-LINE-SETUP THRU ZL-EXIT VARYING PROMPT-IND FROM PROMPT-IND
    ,BY 1 UNTIL PROMPT-IND = TOP-LINE(IR-IND).
    MOVE "    MOVE OP-PAGE TO OVERLAY-ARRAY." TO SOURCE-RECORD.
    WRITE SOURCE-RECORD.
    WRITE SOURCE-RECORD FROM TOTAL-UP-LINE-1.

DIA-CONT.
    MOVE IA-BUFF(IA-IND) TO IA-2.
    WRITE SOURCE-RECORD FROM IA-BUFFER.

Z-LINE-SETUP.
    MOVE POUND TO WORK-RECORD.
    MOVE ZERO TO WR-IND.
    PERFORM GET-VLD VARYING VLD-IND FROM VLD-IND BY 1
    ,UNTIL WR-IND = LENGTH-OF-FIELD(PROMPT-IND).
    EXAMINE WORK-RECORD TALLYING ALL SPACES.
    IF TALLY = LENGTH-OF-FIELD(PROMPT-IND) GO TO Z-NUM.
    EXAMINE WORK-RECORD TALLYING ALL "N".
    IF TALLY NOT = LENGTH-OF-FIELD(PROMPT-IND) GO TO ZL-EXIT.

Z-NUM.
    MOVE PROMPT-IND TO ZL-NUM.
    WRITE SOURCE-RECORD FROM ZERO-LINE.

ZL-EXIT.  EXIT.

TOT-LIN-SETUP.
    MOVE POUND TO WORK-RECORD.
    MOVE ZERO TO WR-IND.
    PERFORM GET-VLD VARYING VLD-IND FROM VLD-IND BY 1
    ,UNTIL WR-IND = LENGTH-OF-FIELD(PROMPT-IND).
    EXAMINE WORK-RECORD TALLYING ALL SPACES.
    IF TALLY = LENGTH-OF-FIELD(PROMPT-IND) GO TO TOT-NUM.
    EXAMINE WORK-RECORD TALLYING ALL "N".
    IF TALLY NOT = LENGTH-OF-FIELD(PROMPT-IND) GO TO TL-EXIT.

TOT-NUM.
    MOVE PROMPT-IND TO TUL2-NUM1, TUL2-NUM2, TUL2-NUM3.
    WRITE SOURCE-RECORD FROM TOTAL-UP-LINE-2.

TL-EXIT.  EXIT.

LIT-SETUP.
    MOVE "; BLANK WHEN ZERO." TO IS-PIC-INFO, 03-ISYM-PIC-INFO.