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.