Trailing-Edge
-
PDP-10 Archives
-
BB-H548C-BM
-
iql-source/iqm.cbl
There are 2 other files named iqm.cbl in the archive. Click here to see a list.
000100 IDENTIFICATION DIVISION.
000120 PROGRAM-ID. IQM.
000140 DATE-WRITTEN. 1977.
000160 SECURITY. COPYRIGHT 1981 AZREX INC.
000180
000200 REMARKS. IQM IS THE MULTIPLE REPORT MODULE OF IQL3;
000220 IT SEPARATES MULTIPLE REPORTS WHICH HAVE
000240 BEEN PREPARED BY THE EXECUTION PHASE (IQE);
000260 THE REPORTS ARE PASSED ON A DISK TEMP FILE
000280 AND THIS MODULE PICKS THEM APART;
000290 LAST UPDATED BY DWM 11 NOV 78.
000300
000320 BASIC LOGIC:
000340 (A) THE FIRST RECORD IN A REPORT
000360 MAY BE A HEADER. IF SO, IT HAS QTE-PAGE-NO = 0
000380 AND QTE-LINE-NO = 0
000400 AND IQM MOVES THE FORMATING PARAMETERS IN
000420 IT TO THE CURRENT CONTROL SLOTS. IF THERE
000440 IS NO HEADER, IQM USES THE FORMATING VALUES
000460 WHICH WERE USED FOR THE PRIOR REPORT
000480 (DEFAULT VALUES FOR THE FIRST REPORT).
000500
000520 (B) FOR HANDLING ACROSS AND/OR MULTIPLE
000540 LINES/REPORT, IQM KEEPS A TABLE
000560 OF WHAT PRINTX IS CURRENTLY CONTRIBUTING
000580 TO THE CONTENTS OF WHAT BUFFER. IT MATCHES
000600 BUFFERS UP ON THIS PRINTX. SINCE THE QTEXEC
000620 RECORD CONTAINS THE ORIGIN (RELATIVE TO
000640 COLUMN 1 OF WHERE IN THE PHYSICAL LINE THIS
000660 PRINT IMAGE GOES, IQM USES IQSXFR TO SLIDE
000680 THE NEW IMAGE INTO THE BUFFER. IF WE DO
000700 HAVE A TRUE ACROSSING SITUATION, THE
000720 QTE-ACROSS FIELD CONTAINS A COUNT WHICH IS
000740 (THIS-SETTING - ACROSS-SETTING)
000760 AND WE GO TO PRINT ONLY WHEN THIS VALUE
000780 BECOMES LESS THAN 1.
000800
000820*===NEEDS TO BE COMPLETELY CHECKED OUT===*
000840
000860 ENVIRONMENT DIVISION.
000880 CONFIGURATION SECTION.
000900 SOURCE-COMPUTER. DECSYSTEM-20.
000920 OBJECT-COMPUTER. DECSYSTEM-20.
000940 SPECIAL-NAMES. CHANNEL (1) IS TOP-OF-PAGE
000960 CONSOLE IS TTY.
000980
001000 INPUT-OUTPUT SECTION.
001020 FILE-CONTROL.
001040 SELECT QTEXEC ASSIGN TO DSK.
001060 SELECT QLEXEC ASSIGN TO DSK.
001080
001100 DATA DIVISION.
001120
001140 FILE SECTION.
001160
001180 FD QTEXEC
001200 VALUE OF IDENTIFICATION IS QT001MTMP
001220 LABEL RECORDS ARE STANDARD BLOCK CONTAINS 0 RECORDS
001240 DATA RECORDS ARE QTEXEC-REC1 QTEXEC-REC2.
001260
001280 01 QTEXEC-REC1 USAGE IS DISPLAY-6.
001300 02 QTE-RPT-PARAMS.
001320 04 QTE-RPT-NO PIC S9(10) COMP.
001340 04 QTE-PAGE-NO PIC S9(10) COMP.
001360 04 QTE-LINE-NO PIC S9(10) COMP.
001380 04 QTE-ACROSS PIC S9(10) COMP.
001400 04 QTE-VSPACE PIC S9(10) COMP.
001420 04 QTE-PRINTX PIC S9(10) COMP.
001440 02 QTE-PRINTPOS PIC S9(10) COMP.
001460 02 QTE-IMAGE PIC X(200).
001480
001500 01 QTEXEC-REC2 USAGE IS DISPLAY-6.
001520 02 FILLER PIC X(18).
001540 02 QTE-DISPLAY-FLAG PIC S9(10) COMP.
001560 02 QTE-PRINT-FLAG PIC S9(10) COMP.
001580 02 QTE-LINES-PAGE PIC S9(10) COMP.
001600 02 QTE-LINES-FORM PIC S9(10) COMP.
001620 02 FILLER PIC X(200).
001640
001660 FD QLEXEC
001680 VALUE OF IDENTIFICATION IS QLEXECLPT
001700 LABEL RECORDS ARE STANDARD BLOCK CONTAINS 0 RECORDS
001720 DATA RECORDS IS QLEXEC-REC.
001740
001760 01 QLEXEC-REC USAGE IS DISPLAY-7.
001764 02 MESSAGE-PART.
001780 04 PRINT-MSG PIC X(30).
001800 04 PRINT-COUNT PIC X(7).
001805 04 FILLER PIC X(5).
001810 04 QLEXECLPT-MSG PIC X(9).
001820 04 FILLER PIC X(149).
001824 02 DATA-LINE REDEFINES MESSAGE-PART.
001828 04 PRINT-CHAR PIC X OCCURS 200 INDEXED BY PCX.
001840
001860 WORKING-STORAGE SECTION.
000000*
000000 01 COPYRIGHT-NOTICE PIC X(50) VALUE
000000 "COPYRIGHT 1981 - AZREX, INC. - ALL RIGHTS RESERVED".
000000*
001880
001882 01 SIXBIT-SPACES PIC X(6) DISPLAY-6 VALUE SPACES.
001884 01 ASCII-NULLS REDEFINES SIXBIT-SPACES DISPLAY-7.
001886 02 ASCII-NULL PIC X.
001888 02 FILLER PIC XXXX.
001890
001900* *FLAGS AND COMP WORK ITEMS FOLLOW*
001920 01 CONST1 PIC S9(10) COMP VALUE 1.
001940 01 CURR-RPT-NO PIC S9(10) COMP VALUE 0.
001960 01 DEVICER PIC X(6) VALUE ' '.
001980 01 DISPLAY-FLAG PIC S9(10) COMP VALUE 1.
002000 01 DONE-FLAG PIC S9(10) COMP VALUE 1.
002002 01 FIRSTTIME PIC S9(10) COMP VALUE 0.
002020 01 I PIC S9(10) COMP VALUE 1.
002040 01 IMAGE-LENGTH PIC S9(10) COMP VALUE 200.
002060 01 J PIC S9(10) COMP VALUE 1.
002080 01 JOB-NO PIC S9(10) COMP VALUE 1.
002100 01 LINES-FORM PIC S9(10) COMP VALUE 66.
002120 01 LINES-PAGE PIC S9(10) COMP VALUE 59.
002140 01 MAX-PXX PIC S9(10) COMP VALUE 20.
002160 01 MAX-RPX PIC S9(10) COMP VALUE 99.
002180 01 MORE-TO-GO PIC S9(10) COMP VALUE 0.
002200 01 NO-OF-RPTS PIC S9(10) COMP VALUE 0.
002220 01 NO-TOTAL-LINES PIC S9(10) COMP VALUE 0.
002240 01 PAGE-LINE PIC S9(10) COMP VALUE 1.
002260 01 PRINT-FLAG PIC S9(10) COMP VALUE 1.
002280 01 PROJ PIC S9(10) COMP VALUE 0.
002300 01 USER PIC S9(10) COMP VALUE 0.
002320
002340* *DYNAMIC FILE NAMES FOLLOW*
002360 01 QT001MTMP.
002380 02 FILLER PIC X(02) VALUE 'QT'.
002400 02 QT001MNO PIC 999 VALUE 001.
002420 02 FILLER PIC X(04) VALUE 'MTMP'.
002440 01 QLEXECLPT.
002460 02 FILLER PIC X(02) VALUE 'QL'.
002480 02 QLEXECNO PIC 999 VALUE 001.
002500 02 FILLER REDEFINES QLEXECNO.
002520 04 QLEXEC-NODUP PIC X.
002540 04 FILLER PIC XX.
002560 02 FILLER PIC X(04) VALUE 'ELPT'.
002580
002600* *NAME OF NEXT MODULE TO BE EXECUTED GOES HERE*
002620 01 CALLED-NAME PIC X(6) USAGE IS DISPLAY-6.
002640
002660 01 DYN-FILE-CHAR-SET.
002680 02 FILLER PIC X VALUE '1'.
002700 02 FILLER PIC X VALUE '2'.
002720 02 FILLER PIC X VALUE '3'.
002740 02 FILLER PIC X VALUE '4'.
002760 02 FILLER PIC X VALUE '5'.
002780 02 FILLER PIC X VALUE '6'.
002800 02 FILLER PIC X VALUE '7'.
002820 02 FILLER PIC X VALUE '8'.
002840 02 FILLER PIC X VALUE '9'.
002860 02 FILLER PIC X VALUE 'A'.
002880 02 FILLER PIC X VALUE 'B'.
002900 02 FILLER PIC X VALUE 'C'.
002920 02 FILLER PIC X VALUE 'D'.
002940 02 FILLER PIC X VALUE 'E'.
002960 02 FILLER PIC X VALUE 'F'.
002980 02 FILLER PIC X VALUE 'G'.
003000 02 FILLER PIC X VALUE 'H'.
003020 02 FILLER PIC X VALUE 'I'.
003040 02 FILLER PIC X VALUE 'J'.
003060 02 FILLER PIC X VALUE 'K'.
003080 02 FILLER PIC X VALUE 'L'.
003100 02 FILLER PIC X VALUE 'M'.
003120 02 FILLER PIC X VALUE 'N'.
003140 02 FILLER PIC X VALUE 'O'.
003160 02 FILLER PIC X VALUE 'P'.
003180 02 FILLER PIC X VALUE 'Q'.
003200 02 FILLER PIC X VALUE 'R'.
003220 02 FILLER PIC X VALUE 'S'.
003240 02 FILLER PIC X VALUE 'T'.
003260 02 FILLER PIC X VALUE 'U'.
003280 02 FILLER PIC X VALUE 'V'.
003300 02 FILLER PIC X VALUE 'W'.
003320 02 FILLER PIC X VALUE 'X'.
003340 02 FILLER PIC X VALUE 'Y'.
003360 02 FILLER PIC X VALUE 'Z'.
003380
003400 01 DYN-FILE-CHAR-SET1 REDEFINES DYN-FILE-CHAR-SET.
003420 02 DYN-FILE-CHAR PIC X OCCURS 35 TIMES
003440 INDEXED BY DDX.
003460
003480
003500* *WORKING TABLE FOR KEEPING TRACK OF REPORT STATUS*
003520 01 RPTS-DONE.
003540 02 RPT-NO PIC S9(10) COMP OCCURS 99 TIMES
003560 INDEXED BY RPX.
003580
003600 01 PRINT-MASK PIC ZZZ,ZZ9.
003620
003640 01 PRINT-BUFFERS.
003660 02 PRINT-LINE PIC X(200) OCCURS 20 TIMES.
003680
003700 01 PRINT-POINTERS OCCURS 20 TIMES INDEXED BY PXX.
003720 02 BUFFER-PRINTX PIC S9(10) COMP.
003740 02 IP PIC S9 COMP.
003760 02 VSP PIC S999 COMP.
003780
003800 PROCEDURE DIVISION.
003820
003840 BEGIN.
003860* *INITIALIZE ENTIRE MULTIPLE REPORTS RUN*
003880 ENTER MACRO CLRTTY.
003900 ENTER MACRO IQGJOB USING JOB-NO.
003920 MOVE JOB-NO TO QT001MNO QLEXECNO.
003940* CANCEL IQGJOB.
003960 MOVE 0 TO NO-OF-RPTS NO-TOTAL-LINES.
003980 SET RPX TO 1.
004000
004020 INITIALIZER.
004040* *CLEAR OUT REPORT STATUS TABLE*
004060 MOVE 0 TO RPT-NO (RPX).
004080 IF RPX LESS THAN 99 SET RPX UP BY 1
004100 GO TO INITIALIZER.
004120
004140* *MAKE SURE PRINT FILE WILL NOT WRITE OVER ONE ALREADY THERE*
004160 DIVIDE JOB-NO BY 100 GIVING J.
004180 IF J = 0 MOVE '0' TO QLEXEC-NODUP GO TO UNIQUE-PRINTFILE1.
004200 UNIQUE-PRINTFILE.
004220 IF J GREATER THAN 35 MOVE '1' TO QLEXEC-NODUP
004240 DISPLAY ' %Writing over ' QLEXECLPT
004260 UPON CONSOLE GO TO KICKOFF-PRINT.
004280 SET DDX TO J.
004300 MOVE DYN-FILE-CHAR (DDX) TO QLEXEC-NODUP.
004320 UNIQUE-PRINTFILE1.
004340 ENTER MACRO IQLOOK USING DEVICER QLEXECLPT
004360 PROJ USER I.
004380 IF I = -1 ADD 1 TO J GO TO UNIQUE-PRINTFILE.
004400
004420 KICKOFF-PRINT.
004440 OPEN OUTPUT QLEXEC.
004460
004480 OPEN-REOPEN.
004500* *LOOP HERE TO START NEXT REPORT*
004520 OPEN INPUT QTEXEC.
004540 MOVE 0 TO MORE-TO-GO CURR-RPT-NO.
004560 SET PXX TO 1.
004580
004600 CLEAROUT-BUFFERS.
004620* *CLEAR OUT PRINT BUFFERS FOR NEXT REPORT*.
004640 MOVE 0 TO BUFFER-PRINTX (PXX).
004660 MOVE 0 TO IP (PXX).
004680 MOVE 1 TO VSP (PXX).
004700 IF PXX LESS THAN MAX-PXX
004720 SET PXX UP BY 1
004740 GO TO CLEAROUT-BUFFERS.
004760 MOVE SPACES TO PRINT-BUFFERS.
004780
004800 READ-LOOP.
004820* *LOOP HERE WITHIN A REPORT*
004840 MOVE 0 TO DONE-FLAG.
004860 READ QTEXEC AT END MOVE 1 TO DONE-FLAG GO TO SEE-IF-DONE.
004880
004900* *IF THIS IS A HEADER RECORD, SET OVERALL PARAMETERS*.
004920 IF QTE-PAGE-NO = 0 AND QTE-LINE-NO = 0
004940 MOVE QTE-DISPLAY-FLAG TO DISPLAY-FLAG
004960 MOVE QTE-PRINT-FLAG TO PRINT-FLAG
004980 MOVE QTE-LINES-PAGE TO LINES-PAGE
005000 MOVE QTE-LINES-FORM TO LINES-FORM
005020 GO TO READ-LOOP.
005040
005060 CHECK-RPT-NO.
005080 IF QTE-RPT-NO = CURR-RPT-NO GO TO PRINT-IT.
005100* *SEE IF THIS REPORT HAS BEEN DONE*.
005120 SET RPX TO QTE-RPT-NO.
005140 IF RPT-NO (RPX) = 1 GO TO READ-LOOP.
005160* *NO - SEE IF TIME TO KICK OFF ANOTHER REPORT*.
005180 IF CURR-RPT-NO NOT = 0
005200 MOVE 1 TO MORE-TO-GO
005220 GO TO READ-LOOP.
005240 ADD 1 TO NO-OF-RPTS.
005260 MOVE 1 TO RPT-NO (RPX).
005280 SET CURR-RPT-NO TO RPX.
005300 GO TO PRINT-IT.
005320
005340 PRINT-IT.
005360* *FIRST LOOK FOR A BUFFER WITH THE SAME PRINTX AS QTE*
005380 SET PXX TO 1.
005400
005420 FIND-PRINTX.
005440 IF BUFFER-PRINTX (PXX) = QTE-PRINTX GO TO ASSEMBLE-LINE.
005460* *IF NO SUCH BUFFER, ASSIGN ONE*
005480 IF BUFFER-PRINTX (PXX) = 0
005500 MOVE QTE-PRINTX TO BUFFER-PRINTX (PXX)
005520 GO TO ASSEMBLE-LINE.
005540 IF PXX LESS THAN MAX-PXX
005560 SET PXX UP BY 1 GO TO FIND-PRINTX.
005580 DISPLAY
005600 ' ?IQM buffer overflow- too many prints in report'
005620 UPON CONSOLE GO TO READ-LOOP.
005640
005660 ASSEMBLE-LINE.
005680* *NOW CONCATENATE LOGICAL PRINT IMAGES IF ACROSSING*
005700* *FIRST CALCULATE WHERE TO PUT THIS IMAGE*
005720 SET I TO PXX.
005740 SUBTRACT 1 FROM I.
005760 MULTIPLY I BY IMAGE-LENGTH GIVING I.
005780 ADD QTE-PRINTPOS TO I.
005800* *NOW CALCULATE HOW MANY CHARACTERS TO MOVE*
005820 ADD IMAGE-LENGTH 1 GIVING J.
005840 SUBTRACT QTE-PRINTPOS FROM J.
005860 ENTER MACRO IQSX66 USING J
005880 QTE-IMAGE CONST1 PRINT-BUFFERS I.
005900* *NOW SEE IF WANT TO DO PHYSICAL OUTPUT*
005920 IF QTE-ACROSS GREATER THAN 0
005940 MOVE QTE-VSPACE TO VSP (PXX)
005960 MOVE 1 TO IP (PXX)
005980 GO TO READ-LOOP.
006000 MOVE 0 TO IP (PXX).
006020 ASSEMBLE-LINE1.
006040* *UPDATE VERTICAL LINE POSITION IN CURRENT PAGE*
006060 IF QTE-VSPACE = 0
006080 SUBTRACT PAGE-LINE FROM LINES-FORM GIVING I
006100 MOVE 1 TO PAGE-LINE
006120 ELSE MOVE QTE-VSPACE TO I ADD I TO PAGE-LINE.
006130 MOVE PRINT-LINE (PXX) TO QLEXEC-REC.
006132 PERFORM TRAILING-NULLS THRU TRAILING-NULLS-EXIT.
006140 IF DISPLAY-FLAG NOT = 1 GO TO PRINT-VSPACE.
006160
006180 DISPLAY-VSPACE.
006200* *DO ANY NECESSARY VERTICAL SPACING ON TERMINAL*
006202* * (BUT NOT THE FIRSTIME THRU)*
006204 IF FIRSTTIME = 0
006206 MOVE 1 TO FIRSTTIME I
006208 ELSE
006220 IF I NOT GREATER THAN 1 NEXT SENTENCE ELSE
006240 DISPLAY ' ' UPON CONSOLE
006260 SUBTRACT 1 FROM I
006280 GO TO DISPLAY-VSPACE.
006300 DISPLAY QLEXEC-REC UPON CONSOLE.
006320
006340 PRINT-VSPACE.
006360* *SET UP TO DO ANY NECESSARY VERTICAL SPACING ON PRINTER*
006380 IF PRINT-FLAG NOT = 1 GO TO PRINT-IT-DONE.
006400 IF QTE-VSPACE NOT GREATER THAN 3 GO TO PRINT-IT1.
006420 MOVE SPACES TO QLEXEC-REC.
006440
006460 PRINT-VSPACE1.
006480 IF QTE-VSPACE GREATER THAN 3
006500 SUBTRACT 3 FROM QTE-VSPACE
006520 WRITE QLEXEC-REC AFTER ADVANCING 3 LINES
006540 GO TO PRINT-VSPACE1.
006560
006580 PRINT-IT1.
006582 MOVE PRINT-LINE (PXX) TO QLEXEC-REC.
006584 PERFORM TRAILING-NULLS THRU TRAILING-NULLS-EXIT.
006600 IF QTE-VSPACE = 0
006602 ENTER MACRO IQWRTS USING PCX
006620 WRITE QLEXEC-REC
006640 AFTER ADVANCING TOP-OF-PAGE
006660 ELSE
006662 ENTER MACRO IQWRTS USING PCX
006664 WRITE QLEXEC-REC
006680 AFTER ADVANCING QTE-VSPACE LINES.
006700
006720 PRINT-IT-DONE.
006740 ADD 1 TO NO-TOTAL-LINES.
006760 MOVE 1 TO QTE-VSPACE.
006780 IF DONE-FLAG = 0 GO TO READ-LOOP ELSE GO TO SEE-IF-DONE1.
006800
006820 SEE-IF-DONE.
006840 CLOSE QTEXEC.
006860 SET PXX TO 1.
006880 FLUSH-BUFFERS.
006900 IF IP (PXX) NOT = 0
006920 MOVE VSP (PXX) TO QTE-VSPACE
006940 MOVE 0 TO IP (PXX)
006960 GO TO ASSEMBLE-LINE1.
006980
007000 SEE-IF-DONE1.
007020 SET PXX UP BY 1.
007040 IF PXX LESS THAN MAX-PXX GO TO FLUSH-BUFFERS.
007060
007080 IF MORE-TO-GO = 1 GO TO OPEN-REOPEN.
007100 MOVE ' End multiple report phase; print file is '
007102 TO QLEXEC-REC
007104 MOVE QLEXECLPT TO QLEXECLPT-MSG.
007120 IF DISPLAY-FLAG NOT = 1 GO TO PRINT-WRAPUP.
007140 SUBTRACT PAGE-LINE FROM LINES-PAGE GIVING I.
007160
007180 DISPLAY-WRAPUP.
007200* *SPACE DOWN TO TOP OF NEXT TERMINAL PAGE*
007220 IF I GREATER THAN 1 DISPLAY ' ' UPON CONSOLE
007240 SUBTRACT 1 FROM I
007260 GO TO DISPLAY-WRAPUP.
007270 PERFORM TRAILING-NULLS THRU TRAILING-NULLS-EXIT.
007280 DISPLAY QLEXEC-REC UPON CONSOLE.
007300
007320 PRINT-WRAPUP.
007340 IF PRINT-FLAG = 1
007360 WRITE QLEXEC-REC AFTER ADVANCING TOP-OF-PAGE.
007380 MOVE SPACES TO QLEXEC-REC.
007400 MOVE ' Reports printed-' TO PRINT-MSG.
007420 MOVE NO-OF-RPTS TO PRINT-MASK.
007440 MOVE PRINT-MASK TO PRINT-COUNT.
007460 IF DISPLAY-FLAG = 1 DISPLAY ' ' UPON CONSOLE
007470 PERFORM TRAILING-NULLS THRU TRAILING-NULLS-EXIT.
007480 DISPLAY QLEXEC-REC UPON CONSOLE.
007500 IF PRINT-FLAG = 1
007520 WRITE QLEXEC-REC AFTER ADVANCING 2 LINES.
007540 MOVE SPACES TO QLEXEC-REC.
007560 MOVE ' Lines printed-' TO PRINT-MSG.
007580 MOVE NO-TOTAL-LINES TO PRINT-MASK.
007600 MOVE PRINT-MASK TO PRINT-COUNT.
007620 IF DISPLAY-FLAG = 1
007624 PERFORM TRAILING-NULLS THRU TRAILING-NULLS-EXIT
007626 DISPLAY QLEXEC-REC UPON CONSOLE.
007640 IF PRINT-FLAG = 1
007660 WRITE QLEXEC-REC AFTER ADVANCING 1 LINES.
007680
007700 REALLY-DONE.
007720 CLOSE QLEXEC.
007740 OPEN INPUT QTEXEC.
007760 CLOSE QTEXEC WITH DELETE.
007780* CLOSE QTEXEC.
007800 MOVE 'IQL ' TO CALLED-NAME.
007820 ENTER MACRO IQNEXT USING CALLED-NAME.
007840 STOP RUN.
007860
007880 TRAILING-NULLS.
007900 SET PCX TO 200.
007920 TRAILING-NULLS1.
007940 IF PRINT-CHAR (PCX) = SPACE IF PCX >1
007960 MOVE ASCII-NULL TO PRINT-CHAR (PCX)
007980 SET PCX DOWN BY 1 GO TO TRAILING-NULLS1.
007800 TRAILING-NULLS-EXIT.
007820 EXIT.