Inside COBOL #83 (Making Speedware fast with COBOL)
by
Shawn Gordon
President
The Kompany
This is maybe a bit off track, but it does illustrate non-obvious ways to use COBOL in a mixed 3GL/4GL enivronment. I’ve used Speedware off and on for about 15 years now, and it is really my 4GL of choice. One of its strengths is that it treats everything as a database with the same syntax for accessing it, this allows you to swap out the underlying structure with relative ease. You could start with a flat file, change to a KSAM and then change to an Image or Allbase DBMS without ever having to change your code.
The downside to this methodology is that behind the scenes it is terribly inneffecient at large scale flat file IO. Some years ago I worked at a payroll company and when the end of the year came around we had to produce W2 forms. This was done by extracting the formatted data to a flat file and then FCOPYing it to tape and sending it out to be printed. There were tens of millions of records in these files. Using the standard IO in Speedware it took about 10 days to run. I thought this was insane so I set out to figure it out.
I decided to run a trace on what intrinsics Speedware was actually calling when it was writing to a file. Seems for each record it would FLOCK/FPOINT/FWRITE/FUNLOCK. Considering all we wanted to do was appended writes the overhead associated with the three extra intrinsics, and high overhead ones at that, was tremendous. I messed with every option in Speedware you can imagine to no avail, I could not get it to do just normal appended/exclusive access (Speedware might have fixed this by now). I then messed with file equations, also to no avail. Finally it occurred to me that Speedware has a very good and well documented ability to interface with other languages, so I realized that I could write my own file write routines in COBOL and just bypass Speedware altogether.
In the example below we have a subprogram that is loaded into an XL file which has three entry points. The entry points make it more straight forward to call the appropriate section of the code without having some switch in the calling sequence. You’ll note that we try to be intelligent about the options that are available so that you can write your code to always create a new file or append to an existing file. I also have READ access ability in these routines. I didn’t find much speed improvement by swapping that out, but it was added for completeness.
What you will be interested to note is that by replacing the native file access of Speedware with these COBOL routines, we dropped the execution time down to about 18 hours, which suddenly made it possible to run on the weekend and not destroy the performance of our machine, which was a 957 at the time.
There are a number of other cute things in here such as the use of macros and the coding of direct file intrinsics instead of using the native COBOL IO, which is also abstracted from the file system, but not in the style of Speedware. This makes the COBOL application about as fast as anything is going to be for file writes. We’ve covered pretty much all of these topics at one time or another, so I present this as an exercise in how to subvert things that frustrate you.
$CONTROL USLINIT, DYNAMIC, NOWARN, BOUNDS
IDENTIFICATION DIVISION.
PROGRAM-ID. PFILEIO.
*
*************************************************
* this series of subprograms is meant to be
* called from SPEEDWARE to do faster file io than
* the native speedware routines.
*************************************************
*
DATE-WRITTEN. THU, JUL 17, 1997.
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SPECIAL-NAMES.
CONDITION-CODE IS CC.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 FOPTIONS PIC S9(4) COMP VALUE 0.
01 AOPTIONS PIC S9(4) COMP VALUE 0.
01 ERR PIC S9(4) COMP VALUE 0.
01 ERR-LEN PIC S9(4) COMP VALUE 0.
01 REC PIC S9(4) COMP VALUE 0.
01 EXT PIC S9(4) COMP VALUE 32.
01 INITE PIC S9(4) COMP VALUE 32.
01 OUT-BUFF PIC X(80) VALUE SPACES.
01 Z PIC X VALUE SPACE.
*
01 ITEMNUM.
03 PIC S9(4) COMP VALUE 19.
03 PIC S9(4) COMP VALUE 0.
*
01 ITEM.
03 EOF PIC S9(9) COMP VALUE 0.
*
01 ITEMERR.
03 PIC S9(4) COMP VALUE 0.
*
LINKAGE SECTION.
01 FILE-NAME PIC X(28).
01 REC-SIZE PIC S9(4) COMP.
01 BLK-SIZE PIC S9(4) COMP.
* 1 = Create (append if there)
* 2 = New (purge if there)
* 3 = Read access
01 ACCESS-MODE PIC S9(4) COMP.
01 NUM-RECS PIC S9(9) COMP.
01 FNUM PIC S9(4) COMP.
01 LS-STATUS PIC S9(4) COMP.
01 BUFF PIC X(5120).
PROCEDURE DIVISION.
$DEFINE %FOPEN=
MOVE !1 TO FOPTIONS
MOVE !2 TO AOPTIONS
CALL INTRINSIC "FOPEN" USING FILE-NAME, FOPTIONS,
AOPTIONS, REC, \\,
\\, \\, BLK-SIZE,
\\, NUM-RECS
GIVING FNUM
IF CC < 0
CALL INTRINSIC 'PRINTFILEINFO' USING FNUM
CALL INTRINSIC 'FCHECK' USING FNUM, LS-STATUS
CALL INTRINSIC 'FERRMSG' USING LS-STATUS, OUT-BUFF,
ERR-LEN
DISPLAY OUT-BUFF(1:ERR-LEN)
DISPLAY 'Failed to FOPEN: ' FILE-NAME
GOBACK
END-IF#
*
$DEFINE %FCLOSE=
CALL INTRINSIC "FCLOSE" USING FNUM, !1, 0
IF CC < 0
CALL INTRINSIC 'PRINTFILEINFO' USING FNUM
CALL INTRINSIC 'FCHECK' USING FNUM, LS-STATUS
CALL INTRINSIC 'FERRMSG' USING LS-STATUS, OUT-BUFF,
ERR-LEN
DISPLAY OUT-BUFF(1:ERR-LEN)
DISPLAY 'Failed to FCLOSE!'
DISPLAY 'Failed in FCLOSE - status = ' LS-STATUS
GOBACK
END-IF#
*
A1000-OPEN.
ENTRY "PFOPEN" USING FILE-NAME, REC-SIZE, BLK-SIZE, ACCESS-MODE,
NUM-RECS, FNUM, LS-STATUS.
CALL INTRINSIC "FLABELINFO" USING FILE-NAME, 2,
ERR, ITEMNUM,
ITEM, ITEMERR.
MULTIPLY REC-SIZE BY -1 GIVING REC.
IF (FILE-NAME = SPACES) OR (REC-SIZE = 0) OR (BLK-SIZE = 0)
OR (ACCESS-MODE = 0) OR (NUM-RECS = 0)
MOVE 99 TO LS-STATUS
DISPLAY 'At least one parameter is missing - check'
DISPLAY 'FILE = ' FILE-NAME
DISPLAY 'REC-SIZE = ' REC-SIZE
DISPLAY 'BLK-SIZE = ' BLK-SIZE
DISPLAY 'MODE = ' ACCESS-MODE
DISPLAY 'NUM RECS = ' NUM-RECS
GOBACK.
* do an FCLOSE after the open, then re-open to make sure the file
* exists in a standard form for the other routines.
MOVE ZEROES TO LS-STATUS.
IF ACCESS-MODE = 1
IF ERR = 0
* File exists - open for append access
%FOPEN(%5#,%3#)
ELSE
* File needs to be created
%FOPEN(%4#,%2#)
%FCLOSE(%1#)
%FOPEN(%5#,%1#)
END-IF
GOBACK.
IF ACCESS-MODE = 2
* File exists - purge first
IF ERR = 0
%FOPEN(%5#,%1#)
%FCLOSE(%4#)
END-IF
*'Open new file'
%FOPEN(%4#,%2#)
*'Save the new file'
%FCLOSE(%1#)
*'Open the old file now'
%FOPEN(%5#,%1#).
IF ACCESS-MODE = 3
IF ERR <> 0
MOVE ERR TO LS-STATUS
GOBACK
END-IF
CALL INTRINSIC "FOPEN" USING FILE-NAME, %5, %1140
GIVING FNUM
IF CC < 0
CALL INTRINSIC 'PRINTFILEINFO' USING FNUM
CALL INTRINSIC 'FCHECK' USING FNUM, LS-STATUS
CALL INTRINSIC 'FERRMSG' USING LS-STATUS, OUT-BUFF,
ERR-LEN
DISPLAY OUT-BUFF(1:ERR-LEN)
DISPLAY 'Failed to FOPEN: ' FILE-NAME.
GOBACK.
*
A2000-WRITE.
ENTRY "PFWRITE" USING FNUM, REC-SIZE, BUFF, LS-STATUS.
MULTIPLY REC-SIZE BY -1 GIVING REC.
CALL INTRINSIC "FWRITE" USING FNUM,
BUFF(1:REC-SIZE),
REC, 0.
IF CC <> 0
CALL INTRINSIC 'PRINTFILEINFO' USING FNUM
CALL INTRINSIC 'FCHECK' USING FNUM, LS-STATUS
CALL INTRINSIC 'FERRMSG' USING LS-STATUS, OUT-BUFF,
ERR-LEN
DISPLAY OUT-BUFF(1:ERR-LEN)
DISPLAY 'Failed in FWRITE - staus = ' LS-STATUS.
GOBACK.
*
A2500-READ.
ENTRY "PFREAD" USING FNUM, REC-SIZE, BUFF, LS-STATUS.
MULTIPLY REC-SIZE BY -1 GIVING REC.
CALL INTRINSIC "FREAD" USING FNUM, BUFF(1:REC-SIZE), REC.
IF CC > 0
MOVE 9999 TO LS-STATUS.
IF CC < 0
CALL INTRINSIC 'PRINTFILEINFO' USING FNUM
CALL INTRINSIC 'FCHECK' USING FNUM, LS-STATUS
CALL INTRINSIC 'FERRMSG' USING LS-STATUS, OUT-BUFF,
ERR-LEN
DISPLAY OUT-BUFF(1:ERR-LEN)
DISPLAY 'Failed in FWRITE - staus = ' LS-STATUS.
GOBACK.
A3000-CLOSE.
ENTRY "PFCLOSE" USING FNUM, LS-STATUS.
%FCLOSE(%1#).
GOBACK.