Microsoft COBOL v4.5

Microsoft COBOL v45/BINB/E.CBL

@@ -0,0 +1,58 @@
+         IDENTIFICATION DIVISION.
+         PROGRAM-ID.  E.
+      *  REMARKS. generate digits of e
+         ENVIRONMENT DIVISION.
+         CONFIGURATION SECTION.
+         DATA DIVISION.
+         WORKING-STORAGE SECTION.
+         01 ARRAYS.
+             02 A PIC 9(04) COMP OCCURS 200 TIMES.
+         01 X PIC 9(04) COMP VALUE 0.
+         01 TMOD PIC 9(04) COMP VALUE 0.
+         01 TM PIC 9(04) COMP VALUE 0.
+         01 TD PIC 9(04) COMP VALUE 0.
+         01 N PIC 9(04) COMP VALUE 0.
+         01 HV PIC 9(04) COMP VALUE 0.
+         01 NUM-DISP PIC 9999.
+
+         PROCEDURE DIVISION.
+         MAIN.
+             DISPLAY 'computing e'.
+             PERFORM INITA-ROUTINE.
+             PERFORM INITA-ROUTINE-B.
+             PERFORM INITA-ROUTINE-C.
+             PERFORM OUTER-LOOP.
+             STOP RUN.
+
+         INITA-ROUTINE.
+             MOVE 200 TO HV.
+             MOVE 0 TO X.
+             MOVE 199 TO N.
+
+         INITA-ROUTINE-B.
+             MOVE 1 TO A( N + 1 ).
+             SUBTRACT 1 FROM N.
+             IF N > 0 GO TO INITA-ROUTINE-B.
+
+         INITA-ROUTINE-C.
+             MOVE 2 TO A( 2 ).
+             MOVE 0 TO A( 1 ).
+          
+         OUTER-LOOP.
+             SUBTRACT 1 FROM HV.
+             MOVE HV TO N.
+             PERFORM INNER-LOOP.
+             IF HV > 9 GO TO OUTER-LOOP.
+
+         INNER-LOOP.
+             DIVIDE X BY N GIVING TD.
+             COMPUTE TMOD = ( X - ( TD * N ) )
+             IF 0 = X MOVE 0 TO TMOD.
+             MOVE TMOD TO A( N + 1 ).
+             MULTIPLY 10 BY A( N ) GIVING TM.
+             COMPUTE X = TM + TD.
+             SUBTRACT 1 FROM N.
+             IF N > 0 GO TO INNER-LOOP.
+             MOVE X TO NUM-DISP.
+             DISPLAY NUM-DISP.
+

Microsoft COBOL v45/BINB/SIEVE.CBL

@@ -0,0 +1,51 @@
+         IDENTIFICATION DIVISION.
+         PROGRAM-ID.  SIEVE.
+      *  REMARKS. BYTE magazine benchmark.
+         ENVIRONMENT DIVISION.
+         CONFIGURATION SECTION.
+         DATA DIVISION.
+         WORKING-STORAGE SECTION.
+         01 MISC.
+             03 I PIC 9(4) COMP.
+             03 PRIME PIC 9(5) COMP.
+             03 K PIC 9(4) COMP.
+             03 TOTAL-PRIME-COUNT PIC 9(4) COMP.
+         02 SIEVETABLE.
+             04 FLAGS PIC 9 COMP OCCURS 8191 TIMES.
+         01 NUM-DISP PIC 9999.
+
+         PROCEDURE DIVISION.
+         MAIN.
+             PERFORM ITER-ROUTINE 10 TIMES.
+             MOVE TOTAL-PRIME-COUNT TO NUM-DISP.
+             DISPLAY NUM-DISP ' primes'.
+             STOP RUN.
+
+         ITER-ROUTINE.
+             MOVE ZEROES TO TOTAL-PRIME-COUNT.
+             PERFORM TFR VARYING I FROM 1 BY 1 UNTIL I = 8191.
+             PERFORM DCP THRU DCE VARYING I FROM 0 BY 1 UNTIL I = 8190.
+
+         TFR.
+             MOVE 1 TO FLAGS(I).
+             
+         DCP.
+             IF FLAGS( I + 1 ) = 0
+                 GO TO DCE.
+             COMPUTE PRIME = I + I + 3.
+             COMPUTE K = I + PRIME.
+
+         FIRST1.
+             IF K > 8190 GO TO NEXT1.
+             MOVE 0 TO FLAGS( K + 1 ).
+             COMPUTE K = PRIME + K.
+             GO TO FIRST1.
+
+         NEXT1.
+             ADD 1 TO TOTAL-PRIME-COUNT.
+      *       MOVE PRIME TO NUM-DISP.
+      *       DISPLAY 'FOUND PRIME = ' NUM-DISP.
+
+         DCE.
+             EXIT.
+

Microsoft COBOL v45/BINB/TTT.CBL

@@ -0,0 +1,168 @@
+         IDENTIFICATION DIVISION.
+         PROGRAM-ID.  TTT.
+      *  REMARKS. prove tic-tac-toe is not winnable against a good foe.
+         ENVIRONMENT DIVISION.
+         CONFIGURATION SECTION.
+         DATA DIVISION.
+         WORKING-STORAGE SECTION.
+         01 BOARD.
+             05 B PIC 9(04) COMP OCCURS 9 TIMES.
+             05 VALST PIC 9(04) COMP OCCURS 10 TIMES.
+             05 ALPHAST PIC 9(04) COMP OCCURS 10 TIMES.
+             05 BETAST PIC 9(04) COMP OCCURS 10 TIMES.
+             05 XST PIC 9(04) COMP OCCURS 10 TIMES.
+             05 PMST PIC 9(04) COMP OCCURS 10 TIMES.
+         01 MOVECOUNT PIC 9(04) COMP VALUE 0.
+         01 DEPTH PIC 9(04) COMP VALUE 0.
+         01 NUM-DISP PIC 9999.
+         01 ITER PIC 9(04) COMP VALUE 0.
+         01 WI PIC 9(04) COMP VALUE 0.
+         01 VAL PIC 9(04) COMP VALUE 0.
+         01 T PIC 9(04) COMP VALUE 0.
+         01 D PIC 9(04) COMP VALUE 0.
+         01 M PIC 9(04) COMP VALUE 0.
+         01 X PIC 9(04) COMP VALUE 0.
+         01 PM PIC 9(04) COMP VALUE 0.
+         01 SC PIC 9(04) COMP VALUE 0.
+         01 Z PIC 9(04) COMP VALUE 0.
+         01 ALPHA PIC 9(04) COMP VALUE 0.
+         01 BETA PIC 9(04) COMP VALUE 0.
+         01 FIRSTMOVE PIC 9(04) COMP VALUE 0.
+
+         PROCEDURE DIVISION.
+         MAIN.
+             DISPLAY 'hello from cobol'.
+             MOVE 1 TO ITER.
+         INITBOARD.
+             MOVE 0 TO B( ITER ).
+             ADD 1 TO ITER.
+             IF ITER < 10 GO TO INITBOARD.
+
+             MOVE 0 TO ITER.
+         NEXTITER.
+             MOVE 0 TO MOVECOUNT.
+             MOVE 1 TO FIRSTMOVE.
+             PERFORM RUNMM.
+             MOVE 2 TO FIRSTMOVE.
+             PERFORM RUNMM.
+             MOVE 5 TO FIRSTMOVE.
+             PERFORM RUNMM.
+             ADD 1 TO ITER.
+             IF ITER < 10 GO TO NEXTITER.
+
+             DISPLAY 'final move count and winner: '.
+             MOVE MOVECOUNT TO NUM-DISP.
+             DISPLAY NUM-DISP.
+             MOVE SC TO NUM-DISP.
+             DISPLAY NUM-DISP.
+
+             STOP RUN.
+
+         RUNMM.
+             MOVE 1 TO B( FIRSTMOVE ).
+             MOVE FIRSTMOVE TO X
+             MOVE 2 TO ALPHA
+             MOVE 9 TO BETA
+             PERFORM MINMAX.
+             MOVE 0 TO B( FIRSTMOVE ).
+
+         WINNER.
+             MOVE 0 TO WI.
+             MOVE B( 1 ) TO T.
+             IF 0 NOT = T AND T=B(2) AND T=B(3) MOVE T TO WI
+             ELSE IF 0 NOT= T AND  T=B(4) AND T=B(7) MOVE T TO WI.
+
+             IF 0 = WI
+               MOVE B(2) TO T
+               IF 0 NOT= T AND T=B(5) AND T=B(8) MOVE T TO WI
+               ELSE
+                 MOVE B(3) TO T
+                 IF 0 NOT= T AND T=B(6) AND T=B(9) MOVE T TO WI
+                 ELSE
+                   MOVE B(4) TO T
+                   IF 0 NOT= T AND T=B(5) AND T=B(6) MOVE T TO WI
+                   ELSE
+                     MOVE B(7) TO T
+                     IF 0 NOT= T AND T=B(8) AND T=B(9) MOVE T TO WI
+                     ELSE
+                       MOVE B(5) TO T
+                       IF 0 NOT= T AND T=B(1) AND T=B(9) MOVE T TO WI
+                       ELSE
+                         IF 0 NOT= T AND T=B(3) AND T=B(7) MOVE T TO WI.
+
+         SHOWPOS.
+             MOVE B(Z) TO NUM-DISP.
+             DISPLAY NUM-DISP.
+
+         SHOWBOARD.
+             DISPLAY 'board: '.
+             PERFORM SHOWPOS VARYING Z FROM 1 BY 1 UNTIL Z>9.
+
+         INITVALPM.
+             DIVIDE DEPTH BY 2 GIVING D.
+             MULTIPLY D BY 2 GIVING M.
+
+             IF DEPTH NOT = M
+                 MOVE 2 TO VAL
+                 MOVE 1 TO PM
+             ELSE
+                 MOVE 9 TO VAL
+                 MOVE 2 TO PM.
+
+         MINMAX.
+             ADD 1 TO MOVECOUNT.
+             MOVE 0 TO VAL.
+
+             IF DEPTH > 3
+                 PERFORM WINNER
+                 IF WI NOT = 0
+                     IF WI = 1 MOVE 6 TO VAL ELSE MOVE 4 TO VAL
+                 ELSE IF DEPTH = 8 MOVE 5 TO VAL.
+
+             IF 0 = VAL
+                 PERFORM INITVALPM
+
+                 ADD 1 TO DEPTH
+                 PERFORM MAKEMOVE VARYING X FROM 1 BY 1 UNTIL (X>9)
+                 SUBTRACT 1 FROM DEPTH.
+
+             MOVE VAL TO SC.
+
+         UPDATEODD.
+                 IF SC = 6 MOVE 10 TO X.
+                 IF SC > VAL MOVE SC TO VAL.
+                 IF VAL NOT < BETA MOVE 10 TO X.
+                 IF VAL > ALPHA MOVE VAL TO ALPHA.
+
+         UPDATEEVEN.
+                 IF SC = 4 MOVE 10 TO X.
+                 IF SC < VAL MOVE SC TO VAL.
+                 IF VAL NOT > ALPHA MOVE 10 TO X.
+                 IF VAL < BETA MOVE VAL TO BETA.
+
+         UPDATESTATE.
+                 IF PM = 1 PERFORM UPDATEODD
+                 ELSE PERFORM UPDATEEVEN.
+  
+         MAKEMOVE.
+             IF B( X ) = 0
+                 MOVE PM TO B( X )
+
+                 MOVE VAL TO VALST( DEPTH )
+                 MOVE X TO XST( DEPTH )
+                 MOVE PM TO PMST( DEPTH )
+                 MOVE ALPHA TO ALPHAST( DEPTH )
+                 MOVE BETA TO BETAST( DEPTH )
+
+                 PERFORM MINMAX
+
+                 MOVE BETAST( DEPTH ) TO BETA
+                 MOVE ALPHAST( DEPTH ) TO ALPHA
+                 MOVE PMST( DEPTH ) TO PM
+                 MOVE XST( DEPTH ) TO X
+                 MOVE VALST( DEPTH ) TO VAL
+
+                 MOVE 0 TO B( X )
+
+                 PERFORM UPDATESTATE.
+

Microsoft COBOL v45/BINB/m.bat

@@ -0,0 +1,9 @@
+del %1.obj
+del %1.exe
+
+ntvdm -r:.. -m -c -d -e:path=c:\binb;c:\binr cobol %1,%1,%1,%1
+
+ntvdm -h -c -r:.. -e:lib=c:\lib link %1,,%1,,nul.def
+
+ntvdm -c -m -r:.. -e:path=c:\binb;c:\binr %1
+

Microsoft COBOL v45/BINR/NEW-VARS.BAT

@@ -0,0 +1,12 @@
+REM  The following lines should be placed in a DOS CONFIG.SYS
+REM  FILES=100
+REM  BUFFERS=10
+REM
+REM  The following lines should be placed in AUTOEXEC.BAT
+PATH=C:\COBOL\BINB;C:\COBOL\BINR;%PATH%
+SET COBDIR=C:\COBOL\BINB;C:\COBOL\BINR
+SET LIB=C:\COBOL\LIB;%LIB%
+SET COBHNF=C:\COBOL\HELP
+SET INCLUDE=C:\COBOL\SOURCE;%INCLUDE%
+SET HELPFILES=C:\COBOL\HELP;%HELPFILES%
+SET INIT=C:\COBOL\INIT;%INIT%

Microsoft COBOL v45/DEMO/ADMOUSE.CBL

@@ -0,0 +1,73 @@
+      $set noosvs mf ans85
+      ************************************************************
+      *                                                          *
+      *              (C) Micro Focus Ltd. 1990                   *
+      *                                                          *
+      *                     ADMOUSE.CBL                          *
+      *                                                          *
+      *    This program demonstrates the use of a mouse in       *
+      *    ADIS ACCEPT statements.                               *
+      *                                                          *
+      ************************************************************
+       identification division.
+       data division.
+
+       working-storage section.
+       01 filler.
+           04 occurs 6.
+            05 occurs 10.
+             06 ws-item    pic 999 value zero.
+       01 mouse-param      pic 99 comp-x.
+       01 use-mouse        pic 99 comp-x value 64.
+       01 use-panels       pic 99 comp-x value 49.
+
+       screen section.
+       01 g-admouse.
+         02 background-color 7 foreground-color 1.
+          03 blank screen.
+          03 line 2 col 15 value "USING THE MOUSE POINTER TO MOVE AROUND
+      -                          " FIELDS" background-color 3 underline.
+          03 line 4 col 8  value "Move the mouse to the field in which y
+      -                          "ou wish to enter data, then".
+          03 line 5 col 8  value "press the left hand  button  on the mo
+      -                          "use to move the text cursor".
+          03 line 6 col 8  value "to the selected field.".
+          03 line 8 col 4 value "SALES FIGURES" foreground-color 4
+                                                underline.
+         02 background-color 7 foreground-color 6.
+          03 line 10 col 13 value "  JAN   FEB   MAR   APR   MAY   JUN
+      -" JUL   AUG   SEP   OCT".
+          03 line 11 col 13 value "ÚÄÄÄÄÄÂÄÄÄÄÄÂÄÄÄÄÄÂÄÄÄÄÄÂÄÄÄÄÄÂÄÄÄÄÄÂ
+      -"ÄÄÄÄÄÂÄÄÄÄÄÂÄÄÄÄÄÂÄÄÄÄÄ¿".
+          03 occurs 6.
+           05 line + 1 col 13 value "³     ³     ³     ³     ³     ³
+      -" ³     ³     ³     ³     ³".
+           05 line + 1 col 13  value "ÃÄÄÄÄÄÅÄÄÄÄÄÅÄÄÄÄÄÅÄÄÄÄÄÅÄÄÄÄÄÅÄÄÄ
+      -"ÄÄÅÄÄÄÄÄÅÄÄÄÄÄÅÄÄÄÄÄÅÄÄÄÄÄ´".
+          03 line 23 col 13 value "ÀÄÄÄÄÄÁÄÄÄÄÄÁÄÄÄÄÄÁÄÄÄÄÄÁÄÄÄÄÄÁÄÄÄÄÄÁ
+      -"ÄÄÄÄÄÁÄÄÄÄÄÁÄÄÄÄÄÁÄÄÄÄÄÙ".
+          03 line 12 col 4 value "Jam".
+          03 line + 2 col 4 value "Honey".
+          03 line + 2 col 4 value "Sugar".
+          03 line + 2 col 4 value "Bread".
+          03 line + 2 col 4 value "Flour".
+          03 line + 2 col 4 value "Butter".
+          03 line 12 col 15.
+         02 background-color 7 foreground-color 0.
+           04 occurs 6.
+            05 occurs 10.
+             06 pic 999 using ws-item.
+             06 col + 4.
+            05 line + 2 col - 60.
+
+       procedure division.
+           call x"af" using use-mouse mouse-param
+      * activate the mouse
+           move 1 to mouse-param
+           call x"af" using use-mouse mouse-param.
+           display g-admouse.
+           accept g-admouse.
+      * terminate the mouse
+           move 0 to mouse-param
+           call x"af" using use-mouse mouse-param.
+           stop run.

Microsoft COBOL v45/DEMO/APPCDEMO/ACSSVC.CPY

@@ -0,0 +1,164 @@
+      *******************************************************************
+      *                                                                 *
+      *                  (C) Micro Focus Ltd. 1990                      *
+      *                                                                 *
+      *                       ACSSVC copy file                          *
+      *                                                                 *
+      *******************************************************************
+
+      *=================================================================
+      *                 verb parameter constants
+      *=================================================================
+
+       78 sv-add                               value 0.
+       78 sv-change                            value 1.
+       78 sv-ignore                            value 0.
+       78 sv-no-add                            value 1.
+       78 sv-no-send                           value 1.
+       78 sv-send                              value 0.
+
+       78 sv-no                                value h"00".
+       78 sv-yes                               value h"01".
+       78 sv-a                                 value h"01".
+       78 sv-ae                                value h"00".
+       78 sv-alert-subvectors                  value h"02".
+       78 sv-ascii-to-ebcdic                   value h"00".
+       78 sv-ebcdic-to-ascii                   value h"01".
+       78 sv-g                                 value h"02".
+       78 sv-intrv                             value h"00".
+       78 sv-nmvt                              value h"01".
+       78 sv-no-intrv                          value h"01".
+       78 sv-off                               value h"00".
+       78 sv-on                                value h"01".
+       78 sv-pdstats-subvectors                value h"03".
+       78 sv-substitute                        value h"00".
+       78 sv-round-trip                        value h"01".
+       78 sv-user-defined                      value h"00".
+
+      *=================================================================
+      *                 return codes
+      *=================================================================
+
+       78 sv-invalid-verb-segment              value h"f008".
+       78 sv-invalid-verb                      value h"ffff".
+       78 sv-keylock-secured                   value h"f013".
+       78 sv-ok                                value h"0000".
+       78 sv-parameter-check                   value h"0001".
+       78 sv-comm-subsystem-not-loaded         value h"f012".
+       78 sv-state-check                       value h"0002".
+       78 sv-unexpected-dos-error              value h"f011".
+
+       78 sv-conversion-error                  value h"00000406".
+       78 sv-data-exceeds-ru-size              value h"00000302".
+       78 sv-invalid-character-set             value h"00000402".
+       78 sv-invalid-data-segment              value h"00000006".
+       78 sv-invalid-data-type                 value h"00000303".
+       78 sv-invalid-direction                 value h"00000401".
+       78 sv-invalid-first-character           value h"00000404".
+       78 sv-invalid-message-action            value h"00000621".
+       78 sv-invalid-set                       value h"00000624".
+       78 sv-invalid-storage-size              value h"00000627".
+       78 sv-sscp-pu-session-not-active        value h"00000301".
+       78 sv-table-error                       value h"00000405".
+       78 sv-invalid-nmvt-header               value h"00000304".
+       78 sv-invalid-char-not-found            value h"00000630".
+       78 sv-invalid-source-code-page          value h"00000631".
+       78 sv-invalid-target-code-page          value h"00000632".
+
+      *=================================================================
+      *                 operation codes
+      *=================================================================
+
+       78 sv-convert                           value h"1a00".
+       78 sv-define-trace                      value h"1d00".
+       78 sv-get-cp-convert-table              value h"1900".
+       78 sv-log-message                       value h"1f00".
+       78 sv-transfer-ms-data                  value h"1c00".
+
+
+      *=================================================================
+      *                verb structures
+      *=================================================================
+      *-----------------------------------------------------------------
+      *                convert service verb record definitions
+      *-----------------------------------------------------------------
+
+      *--------------- convert verb ------------------------------------
+       01 convert-verb redefines vcb.
+         03 opcode-cvt          pic 9(4) comp-x.
+         03 filler              pic x(2).
+         03 primary-rc-cvt      pic 9(4) comp-x.
+         03 secondary-rc-cvt    pic 9(8) comp-x.
+         03 direction-cvt       pic 9(2) comp-x.
+         03 char-set-cvt        pic 9(2) comp-x.
+         03 len-cvt             pic 9(4) comp-5.
+         03 src-ptr-cvt         usage pointer.
+         03 targ-ptr-cvt        usage pointer.
+      *-----------------------------------------------------------------
+
+      *--------------- define-trace verb -------------------------------
+       01  define-trace-verb redefines vcb.
+         03 opcode-dft          pic 9(4) comp-x.
+         03 filler              pic x(2).
+         03 primary-rc-dft      pic 9(4) comp-x.
+         03 secondary-rc-dft    pic 9(8) comp-x.
+         03 filler              pic x(8).
+         03 dt-set-dft          pic 9(2) comp-x.
+         03 appc-dft            pic 9(2) comp-x.
+         03 filler              pic x.
+         03 srpi-dft            pic 9(2) comp-x.
+         03 sdlc-dft            pic 9(2) comp-x.
+         03 tkn-rng-dlc-dft     pic 9(2) comp-x.
+         03 pcnet-dlc-dft       pic 9(2) comp-x.
+         03 dft-data            pic 9(2) comp-x.
+         03 acdi-data           pic 9(2) comp-x.
+         03 filler              pic x.
+         03 comm-serv-dft       pic 9(2) comp-x.
+         03 filler              pic x(16).
+         03 reset-trc-dft       pic 9(2) comp-x.
+         03 trunc-dft           pic 9(4) comp-5.
+         03 strg-size-dft       pic 9(4) comp-5.
+         03 filler              pic x(65).
+      *-----------------------------------------------------------------
+
+      *--------------- get-cp-convert-table verb -----------------------
+       01 get-cp-convert-table-verb redefines vcb.
+         03 opcode-gcp             pic 9(4) comp-x.
+         03 filler                 pic x(2).
+         03 primary-rc-gcp         pic 9(4) comp-x.
+         03 secondary-rc-gcp       pic 9(8) comp-x.
+         03 source-cp-gcp          pic 9(4) comp-x.
+         03 target-cp-gcp          pic 9(4) comp-x.
+         03 conv-tbl-addr-gcp      usage pointer.
+         03 char-not-fnd-gcp       pic 9(2) comp-x.
+         03 sub-char-gcp           pic 9(2) comp-x.
+      *-----------------------------------------------------------------
+
+      *--------------- log-message verb --------------------------------
+       01 log-message-verb redefines vcb.
+         03 opcode-lmg               pic 9(4) comp-x.
+         03 filler                   pic x(2).
+         03 primary-rc-lmg           pic 9(4) comp-x.
+         03 secondary-rc-lmg         pic 9(8) comp-x.
+         03 msg-num-lmg              pic 9(4) comp-5.
+         03 origntr-id-lmg           pic x(8).
+         03 msg-file-name-lmg        pic x(3).
+         03 msg-action-lmg           pic 9(2) comp-x.
+         03 msg-ins-len-lmg          pic 9(4) comp-x.
+         03 msg-ins-addr-lmg         usage pointer.
+      *-----------------------------------------------------------------
+
+      *--------------- transfer-ms-data verb----------------------------
+       01 transfer-ms-data-verb redefines vcb.
+         03 opcode-tmd               pic 9(4) comp-x.
+         03 type-tmd                 pic 9(2) comp-x.
+         03 filler                   pic x.
+         03 primary-rc-tmd           pic 9(4) comp-x.
+         03 secondary-rc-tmd         pic 9(8) comp-x.
+         03 options-tmd              pic 9(2) comp-x.
+         03 filler                   pic x.
+         03 origntr-id-tmd           pic x(8).
+         03 dlen-tmd                 pic 9(4) comp-5.
+         03 data-ptr-tmd             usage pointer.
+      *-----------------------------------------------------------------
+

Microsoft COBOL v45/DEMO/APPCDEMO/APPC.CPY

@@ -0,0 +1,712 @@
+      *******************************************************************
+      *                                                                 *
+      *                  (C) Micro Focus Ltd. 1990                      *
+      *                                                                 *
+      *                      APPC copy file                             *
+      *                                                                 *
+      *******************************************************************
+
+      *=================================================================
+      *                 verb parameter constants
+      *=================================================================
+
+       78 ap-no                                value h"00".
+       78 ap-yes                               value h"01".
+       
+       78 ap-abend                             value h"05".
+       78 ap-abend-prog                        value h"02".
+       78 ap-abend-svc                         value h"03".
+       78 ap-abend-timer                       value h"04".
+       78 ap-basic-conversation                value h"00".
+       78 ap-buffer                            value h"00".
+       78 ap-confirm-sync-level                value h"01".
+       78 ap-flush                             value h"01".
+       78 ap-hard                              value h"01".
+       78 ap-immediate                         value h"01".
+       78 ap-ll                                value h"01".
+       78 ap-long                              value h"01".
+       78 ap-mapped-conversation               value h"01".
+       78 ap-none                              value h"00".
+       78 ap-pgm                               value h"02".
+       78 ap-prog                              value h"00".
+       78 ap-same                              value h"01".
+       78 ap-short                             value h"00".
+       78 ap-soft                              value h"00".
+       78 ap-svc                               value h"01".
+       78 ap-sync-level                        value h"00".
+       78 ap-when-session-allocated            value h"00".
+       78 ap-when-session-free                 value h"02".
+       
+       78 ap-confirm-what-received             value h"0200".
+       78 ap-confirm-deallocate                value h"0400".
+       78 ap-confirm-send                      value h"0300".
+       78 ap-data                              value h"0001".
+       78 ap-data-complete                     value h"0002".
+       78 ap-data-incomplete                   value h"0004".
+       78 ap-send                              value h"0100".
+       
+      *=================================================================
+      *                 return codes
+      *=================================================================
+       78 ap-allocation-error                  value h"0003".
+       78 ap-cancelled                         value h"0021".
+       78 ap-comm-subsystem-abended            value h"f003".
+       78 ap-comm-subsystem-not-loaded         value h"f004".
+       78 ap-conv-failure-retry                value h"000f".
+       78 ap-conv-failure-no-retry             value h"0010".
+       78 ap-conversation-type-mixed           value h"0019".
+       78 ap-dealloc-abend                     value h"0005".
+       78 ap-dealloc-abend-prog                value h"0006".
+       78 ap-dealloc-abend-svc                 value h"0007".
+       78 ap-dealloc-abend-timer               value h"0008".
+       78 ap-dealloc-normal                    value h"0009".
+       78 ap-invalid-verb-segment              value h"f008".
+       78 ap-ok                                value h"0000".
+       78 ap-parameter-check                   value h"0001".
+       78 ap-prog-error-no-trunc               value h"000c".
+       78 ap-prog-error-purging                value h"000e".
+       78 ap-prog-error-trunc                  value h"000d".
+       78 ap-state-check                       value h"0002".
+       78 ap-svc-error-no-trunc                value h"0011".
+       78 ap-svc-error-purging                 value h"0013".
+       78 ap-svc-error-trunc                   value h"0012".
+       78 ap-tp-busy                           value h"f002".
+       78 ap-unexpected-dos-error              value h"f011".
+       78 ap-unsuccessful                      value h"0014".
+       78 ap-stack-too-small                   value h"f015".
+       
+       78 ap-allocate-not-pending              value h"00000509".
+       78 ap-alloc-failure-no-retry            value h"00000004".
+       78 ap-alloc-failure-retry               value h"00000005".
+       78 ap-attach-mgr-inactive               value h"00000508".
+       78 ap-bad-conv-id                       value h"00000002".
+       78 ap-bad-conv-type                     value h"00000011".
+       78 ap-bad-ll                            value h"000000f1".
+       78 ap-bad-lu-name                       value h"00000003".
+       78 ap-bad-return-control                value h"00000014".
+       78 ap-bad-security                      value h"00000013".
+       78 ap-bad-sync-level                    value h"00000012".
+       78 ap-bad-tp-id                         value h"00000001".
+       78 ap-confirm-bad-state                 value h"00000032".
+       78 ap-confirm-not-ll-bdy                value h"00000033".
+       78 ap-confirm-on-sync-lvl-none          value h"00000031".
+       78 ap-confirmed-bad-state               value h"00000041".
+       78 ap-conv-type-mismatch                value h"10086034".
+       78 ap-dealloc-bad-type                  value h"00000051".
+       78 ap-dealloc-conf-bad-state            value h"00000053".
+       78 ap-dealloc-flush-bad-state           value h"00000052".
+       78 ap-dealloc-log-ll-wrong              value h"00000057".
+       78 ap-dealloc-not-ll-bdy                value h"00000055".
+       78 ap-flush-not-send-state              value h"00000061".
+       78 ap-invalid-data-segment              value h"00000006".
+       78 ap-invalid-process                   value h"00000525".
+       78 ap-invalid-semaphore-handle          value h"000000d6".
+       78 ap-no-use-of-snasvcmg                value h"00000017".
+       78 ap-p-to-r-invalid-type               value h"000000a1".
+       78 ap-p-to-r-not-ll-bdy                 value h"000000a2".
+       78 ap-p-to-r-not-send-state             value h"000000a3".
+       78 ap-pip-len-incorrect                 value h"00000016".
+       78 ap-pip-not-allowed                   value h"10086031".
+       78 ap-pip-not-spec-correct              value h"10086032".
+       78 ap-rcv-and-post-not-ll-bdy           value h"000000d2".
+       78 ap-r-t-s-bad-state                   value h"000000e1".
+       78 ap-rcv-and-post-bad-fill             value h"000000d5".
+       78 ap-rcv-and-post-bad-state            value h"000000d1".
+       78 ap-rcv-and-wait-bad-fill             value h"000000b5".
+       78 ap-rcv-and-wait-bad-state            value h"000000b1".
+       78 ap-rcv-and-wait-not-ll-bdy           value h"000000b2".
+       78 ap-rcv-immd-bad-fill                 value h"000000c4".
+       78 ap-rcv-immd-bad-state                value h"000000c1".
+       78 ap-security-not-valid                value h"080f6051".
+       78 ap-send-data-bad-map-name            value h"000000f3".
+       78 ap-send-data-not-send-state          value h"000000f2".
+       78 ap-send-error-bad-type               value h"00000103".
+       78 ap-sync-level-not-supported          value h"10086041".
+       78 ap-send-error-log-ll-wrong           value h"00000102".
+       78 ap-too-many-tps                      value h"00000243".
+       78 ap-tp-name-not-recognized            value h"10086021".
+       78 ap-t-pgm-not-avail-no-retry          value h"084c0000".
+       78 ap--pgm-not-avail-retry              value h"084b6031".
+       78 ap-undefined-tp-name                 value h"00000506".
+       78 ap-unknown-partner-mode              value h"00000018".
+       
+      *=================================================================
+      *                 operation codes
+      *=================================================================
+       78 ap-b-allocate                        value h"0100".
+       78 ap-b-confirm                         value h"0300".
+       78 ap-b-confirmed                       value h"0400".
+       78 ap-b-deallocate                      value h"0500".
+       78 ap-b-flush                           value h"0600".
+       78 ap-b-get-attributes                  value h"0700".
+       78 ap-b-prepare-to-receive              value h"0a00".
+       78 ap-b-receive-and-post                value h"0d00".
+       78 ap-b-receive-and-wait                value h"0b00".
+       78 ap-b-receive-immediate               value h"0c00".
+       78 ap-b-request-to-send                 value h"0e00".
+       78 ap-b-send-data                       value h"0f00".
+       78 ap-b-send-error                      value h"1000".
+       78 ap-b-test-rts                        value h"1200".
+       
+       78 ap-m-allocate                        value h"0100".
+       78 ap-m-confirm                         value h"0300".
+       78 ap-m-confirmed                       value h"0400".
+       78 ap-m-deallocate                      value h"0500".
+       78 ap-m-flush                           value h"0600".
+       78 ap-m-get-attributes                  value h"0700".
+       78 ap-m-prepare-to-receive              value h"0a00".
+       78 ap-m-receive-and-post                value h"0d00".
+       78 ap-m-receive-and-wait                value h"0b00".
+       78 ap-m-receive-immediate               value h"0c00".
+       78 ap-m-request-to-send                 value h"0e00".
+       78 ap-m-send-data                       value h"0f00".
+       78 ap-m-send-error                      value h"1000".
+       78 ap-m-test-rts                        value h"1200".
+       
+       78 ap-get-type                          value h"0800".
+       78 ap-receive-allocate                  value h"1600".
+       78 ap-tp-ended                          value h"1300".
+       78 ap-tp-started                        value h"1400".
+       
+       
+      *=================================================================
+      *                verb structures
+      *=================================================================
+
+      *-----------------------------------------------------------------
+      *                verb control block
+      *
+      * this is a buffer which is passed to all of the APPC verbs.
+      * the contents of the VCB are different for each verb called
+      * Not all the fields of the VCB are used in every verb call,
+      * those that are not should be zeroed.
+      *
+      * The VCB is defined below - and the redefinitions that follow
+      * specify the structure of each verb.
+      *
+      *-----------------------------------------------------------------
+       01 vcb.
+         03 opcode-vcb          pic 9(4) comp-x.
+         03 opext-vcb           pic 9(2) comp-x.
+         03 filler              pic x.
+         03 prim-rc-vcb         pic 9(4) comp-x.
+         03 sec-rc-vcb          pic 9(8) comp-x.
+         03 filler              pic x(290).
+
+      *-----------------------------------------------------------------
+      *                transaction program control interface
+      *-----------------------------------------------------------------
+
+      *--------------- receive-allocate verb ---------------------------
+       01 rcv-alloc-verb redefines vcb.
+         03 opcode-ral          pic 9(4) comp-x.
+         03 filler              pic x(2).
+         03 prim-rc-ral         pic 9(4) comp-x.
+         03 sec-rc-ral          pic 9(8) comp-x.
+         03 tp-name-ral         pic x(64).
+         03 tp-id-ral           pic x(8).
+         03 conv-id-ral         pic x(4).
+         03 sync-lvl-ral        pic 9(2) comp-x.
+         03 conv-type-ral       pic 9(2) comp-x.
+         03 user-id-ral         pic x(10).
+         03 lu-alias-ral        pic x(8).
+         03 plu-alias-ral       pic x(8).
+         03 mode-name-ral       pic x(8).
+         03 filler              pic x(28).
+      *-----------------------------------------------------------------
+       
+      *--------------- tp-ended ----------------------------------------
+       01 tp-ended-verb redefines vcb.
+         03 opcode-tpe          pic 9(4) comp-x.
+         03 filler              pic x(2).
+         03 prim-rc-tpe         pic 9(4) comp-x.
+         03 sec-rc-tpe          pic 9(8) comp-x.
+         03 tp-id-tpe           pic x(8).
+         03 filler              pic x(28).
+      *-----------------------------------------------------------------
+       
+      *--------------- tp-started --------------------------------------
+       01 tp-started-verb redefines vcb.
+         03 opcode-tps          pic 9(4) comp-x.
+         03 filler              pic x(2).
+         03 prim-rc-tps         pic 9(4) comp-x.
+         03 sec-rc-tps          pic 9(8) comp-x.
+         03 lu-alias-tps        pic x(8).
+         03 tp-id-tps           pic x(8).
+         03 tp-name-tps         pic x(64).
+      *-----------------------------------------------------------------
+       
+      *-----------------------------------------------------------------
+      *        Transaction programming interface - basic conversation
+      *-----------------------------------------------------------------
+       
+      *--------------- allocate ----------------------------------------
+       01 alloc-verb redefines vcb.
+         03 opcode-alc          pic 9(4) comp-x.
+         03 opext-alc           pic 9(2) comp-x.
+         03 filler              pic x.
+         03 prim-rc-alc         pic 9(4) comp-x.
+         03 sec-rc-alc          pic 9(8) comp-x.
+         03 tp-id-alc           pic x(8).
+         03 conv-id-alc         pic x(4).
+         03 conv-type-alc       pic 9(2) comp-x.
+         03 sync-lvl-alc        pic 9(2) comp-x.
+         03 filler              pic x(2).
+         03 rtn-ctl-alc         pic 9(2) comp-x.
+         03 filler              pic x(9).
+         03 plu-alias-alc       pic x(8).
+         03 mode-name-alc       pic x(8).
+         03 tp-name-alc         pic x(64).
+         03 security-alc        pic 9(2) comp-x.
+         03 filler              pic x(11).
+         03 pwd-alc             pic x(10).
+         03 user-id-alc         pic x(10).
+         03 pip-dlen-alc        pic 9(4) comp-5.
+         03 pip-dptr-alc        usage pointer.
+         03 filler              pic x(26).
+      *-----------------------------------------------------------------
+
+      *--------------- confirm -----------------------------------------
+       01 cnfrm-verb redefines vcb.
+         03 opcode-cfm          pic 9(4) comp-x.
+         03 opext-cfm           pic 9(2) comp-x.
+         03 filler              pic x.
+         03 prim-rc-cfm         pic 9(4) comp-x.
+         03 sec-rc-cfm          pic 9(8) comp-x.
+         03 tp-id-cfm           pic x(8).
+         03 conv-id-cfm         pic x(4).
+         03 rts-rcvd-cfm        pic 9(2) comp-x.
+      *-----------------------------------------------------------------
+       
+      *--------------- confirmed ---------------------------------------
+       01 cnfrmd-verb redefines vcb.
+         03 opcode-cfd          pic 9(4) comp-x.
+         03 opext-cfd           pic 9(2) comp-x.
+         03 filler              pic x.
+         03 prim-rc-cfd         pic 9(4) comp-x.
+         03 sec-rc-cfd          pic 9(8) comp-x.
+         03 tp-id-cfd           pic x(8).
+         03 conv-id-cfd         pic x(4).
+      *-----------------------------------------------------------------
+       
+      *--------------- deallocate --------------------------------------
+       01 dealloc-verb redefines vcb.
+         03 opcode-dal          pic 9(4) comp-x.
+         03 opext-dal           pic 9(2) comp-x.
+         03 filler              pic x.
+         03 prim-rc-dal         pic 9(4) comp-x.
+         03 sec-rc-dal          pic 9(8) comp-x.
+         03 tp-id-dal           pic x(8).
+         03 conv-id-dal         pic x(4).
+         03 filler              pic x.
+         03 dealloc-type-dal    pic 9(2) comp-x.
+         03 log-dlen-dal        pic 9(4) comp-5.
+         03 log-dptr-dal        usage pointer.
+      *-----------------------------------------------------------------
+       
+      *--------------- flush -------------------------------------------
+       01 flush-verb redefines vcb.
+         03 opcode-fls          pic 9(4) comp-x.
+         03 opext-fls           pic 9(2) comp-x.
+         03 filler              pic x.
+         03 prim-rc-fls         pic 9(4) comp-x.
+         03 sec-rc-fls          pic 9(8) comp-x.
+         03 tp-id-fls           pic x(8).
+         03 conv-id-fls         pic x(4).
+      *-----------------------------------------------------------------
+       
+      *--------------- get-attributes ----------------------------------
+       01 get-atts-verb redefines vcb.
+         03 opcode-gat          pic 9(4) comp-x.
+         03 opext-gat           pic 9(2) comp-x.
+         03 filler              pic x.
+         03 prim-rc-gat         pic 9(4) comp-x.
+         03 sec-rc-gat          pic 9(8) comp-x.
+         03 tp-id-gat           pic x(8).
+         03 conv-id-gat         pic x(4).
+         03 filler              pic x.
+         03 sync-lvl-gat        pic 9(2) comp-x.
+         03 mode-name-gat       pic x(8).
+         03 net-name-gat        pic x(8).
+         03 lu-name-gat         pic x(8).
+         03 lu-alias-gat        pic x(8).
+         03 plu-alias-gat       pic x(8).
+         03 plu-un-name-gat     pic x(8).
+         03 filler              pic x(2).
+         03 fqplun-gat          pic x(17).
+         03 filler              pic x.
+         03 user-id-gat         pic x(10).
+         03 filler              pic x(26).
+      *-----------------------------------------------------------------
+       
+      *--------------- prepare-to-receive ------------------------------
+       01 prp-to-rcv-verb redefines vcb.
+         03 opcode-ptr          pic 9(4) comp-x.
+         03 opext-ptr           pic 9(2) comp-x.
+         03 filler              pic x.
+         03 prim-rc-ptr         pic 9(4) comp-x.
+         03 sec-rc-ptr          pic 9(8) comp-x.
+         03 tp-id-ptr           pic x(8).
+         03 conv-id-ptr         pic x(4).
+         03 ptr-type-ptr        pic 9(2) comp-x.
+         03 locks-ptr           pic 9(2) comp-x.
+      *-----------------------------------------------------------------
+       
+      *--------------- receive-and-post --------------------------------
+       01 rcv-and-post-verb redefines vcb.
+         03 opcode-rap          pic 9(4) comp-x.
+         03 opext-rap           pic 9(2) comp-x.
+         03 filler              pic x.
+         03 prim-rc-rap         pic 9(4) comp-x.
+         03 sec-rc-rap          pic 9(8) comp-x.
+         03 tp-id-rap           pic x(8).
+         03 conv-id-rap         pic x(4).
+         03 what-rcvd-rap       pic 9(4) comp-x.
+         03 filler              pic x.
+         03 fill-rap            pic 9(2) comp-x.
+         03 rts-rcvd-rap        pic 9(2) comp-x.
+         03 filler              pic x.
+         03 max-len-rap         pic 9(4) comp-5.
+         03 dlen-rap            pic 9(4) comp-5.
+         03 dptr-rap            usage pointer.
+         03 sema-rap            pic 9(8) comp-5.
+         03 filler              pic x.
+      *-----------------------------------------------------------------
+
+      *--------------- receive-and-wait --------------------------------
+       01 rcv-and-wait-verb redefines vcb.
+         03 opcode-raw          pic 9(4) comp-x.
+         03 opext-raw           pic 9(2) comp-x.
+         03 filler              pic x.
+         03 prim-rc-raw         pic 9(4) comp-x.
+         03 sec-rc-raw          pic 9(8) comp-x.
+         03 tp-id-raw           pic x(8).
+         03 conv-id-raw         pic x(4).
+         03 what-rcvd-raw       pic 9(4) comp-x.
+         03 filler              pic x.
+         03 fill-raw            pic 9(2) comp-x.
+         03 rts-rcvd-raw        pic 9(2) comp-x.
+         03 filler              pic x.
+         03 max-len-raw         pic 9(4) comp-5.
+         03 dlen-raw            pic 9(4) comp-5.
+         03 dptr-raw            usage pointer.
+         03 filler              pic x(5).
+      *-----------------------------------------------------------------
+
+      *--------------- receive-immediate -------------------------------
+       01 rcv-imm-verb redefines vcb.
+         03 opcode-rim          pic 9(4) comp-x.
+         03 opext-rim           pic 9(2) comp-x.
+         03 filler              pic x.
+         03 prim-rc-rim         pic 9(4) comp-x.
+         03 sec-rc-rim          pic 9(8) comp-x.
+         03 tp-id-rim           pic x(8).
+         03 conv-id-rim         pic x(4).
+         03 what-rcvd-rim       pic 9(4) comp-x.
+         03 filler              pic x.
+         03 fill-rim            pic 9(2) comp-x.
+         03 rts-rcvd-rim        pic 9(2) comp-x.
+         03 filler              pic x.
+         03 max-len-rim         pic 9(4) comp-5.
+         03 dlen-rim            pic 9(4) comp-5.
+         03 dptr-rim            usage pointer.
+         03 filler              pic x(5).
+      *-----------------------------------------------------------------
+       
+      *--------------- request-to-send ---------------------------------
+       01 rq-to-snd-verb redefines vcb.
+         03 opcode-rts          pic 9(4) comp-x.
+         03 opext-rts           pic 9(2) comp-x.
+         03 filler              pic x.
+         03 prim-rc-rts         pic 9(4) comp-x.
+         03 sec-rc-rts          pic 9(8) comp-x.
+         03 tp-id-rts           pic x(8).
+         03 conv-id-rts         pic x(4).
+      *-----------------------------------------------------------------
+       
+      *--------------- send-data ---------------------------------------
+       01 snd-data-verb redefines vcb.
+         03 opcode-sdt          pic 9(4) comp-x.
+         03 opext-sdt           pic 9(2) comp-x.
+         03 filler              pic x.
+         03 prim-rc-sdt         pic 9(4) comp-x.
+         03 sec-rc-sdt          pic 9(8) comp-x.
+         03 tp-id-sdt           pic x(8).
+         03 conv-id-sdt         pic x(4).
+         03 rts-rcvd-sdt        pic 9(2) comp-x.
+         03 filler              pic x.
+         03 dlen-sdt            pic 9(4) comp-5.
+         03 dptr-sdt            usage pointer.
+         03 filler              pic x(2).
+      *-----------------------------------------------------------------
+       
+      *--------------- send-error --------------------------------------
+       01 snd-err-verb redefines vcb.
+         03 opcode-ser          pic 9(4) comp-x.
+         03 opext-ser           pic 9(2) comp-x.
+         03 filler              pic x.
+         03 prim-rc-ser         pic 9(4) comp-x.
+         03 sec-rc-ser          pic 9(8) comp-x.
+         03 tp-id-ser           pic x(8).
+         03 conv-id-ser         pic x(4).
+         03 rts-rcvd-ser        pic 9(2) comp-x.
+         03 err-type-ser        pic 9(2) comp-x.
+         03 filler              pic x(2).
+         03 log-dlen-ser        pic 9(4) comp-5.
+         03 l-dptr-ser          usage pointer.
+      *-----------------------------------------------------------------
+       
+      *--------------- test-rts ----------------------------------------
+       01 test-rts-verb redefines vcb.
+         03 opcode-tst          pic 9(4) comp-x.
+         03 opext-tst           pic 9(2) comp-x.
+         03 filler              pic x.
+         03 prim-rc-tst         pic 9(4) comp-x.
+         03 sec-rc-tst          pic 9(8) comp-x.
+         03 tp-id-tst           pic x(8).
+         03 conv-id-tst         pic x(4).
+         03 filler              pic x.
+      *-----------------------------------------------------------------
+       
+      *-----------------------------------------------------------------
+      *        Transaction programming interface - mapped conversation
+      *-----------------------------------------------------------------
+
+      *--------------- mc-allocate -------------------------------------
+       01 mc-alloc-verb redefines vcb.
+         03 opcode-mal          pic 9(4) comp-x.
+         03 opext-mal           pic 9(2) comp-x.
+         03 filler              pic x.
+         03 prim-rc-mal         pic 9(4) comp-x.
+         03 sec-rc-mal          pic 9(8) comp-x.
+         03 tp-id-mal           pic x(8).
+         03 conv-id-mal         pic x(4).
+         03 conv-type-mal       pic 9(2) comp-x.
+         03 sync-lvl-mal        pic 9(2) comp-x.
+         03 filler              pic x(2).
+         03 rtn-ctl-mal         pic 9(2) comp-x.
+         03 filler              pic x(9).
+         03 plu-alias-mal       pic x(8).
+         03 mode-name-mal       pic x(8).
+         03 tp-name-mal         pic x(64).
+         03 security-mal        pic 9(2) comp-x.
+         03 filler              pic x(11).
+         03 pwd-mal             pic x(10).
+         03 user-id-mal         pic x(10).
+         03 pip-dlen-mal        pic 9(4) comp-5.
+         03 pip-dptr-mal        usage pointer.
+         03 filler              pic x(26).
+      *-----------------------------------------------------------------
+
+      *--------------- mc-confirm --------------------------------------
+       01 mc-cnfrm-verb redefines vcb.
+         03 opcode-mcm          pic 9(4) comp-x.
+         03 opext-mcm           pic 9(2) comp-x.
+         03 filler              pic x.
+         03 prim-rc-mcm         pic 9(4) comp-x.
+         03 sec-rc-mcm          pic 9(8) comp-x.
+         03 tp-id-mcm           pic x(8).
+         03 conv-id-mcm         pic x(4).
+         03 rts-rcvd-mcm        pic 9(2) comp-x.
+      *-----------------------------------------------------------------
+       
+      *--------------- mc-confirmed ------------------------------------
+       01 mc-cnfrmd-verb redefines vcb.
+         03 opcode-mcd         pic 9(4) comp-x.
+         03 opext-mcd           pic 9(2) comp-x.
+         03 filler              pic x.
+         03 prim-rc-mcd         pic 9(4) comp-x.
+         03 sec-rc-mcd          pic 9(8) comp-x.
+         03 tp-id-mcd           pic x(8).
+         03 conv-id-mcd         pic x(4).
+      *-----------------------------------------------------------------
+       
+      *--------------- mc-deallocate -----------------------------------
+       01 mc-dealloc-verb redefines vcb.
+         03 opcode-mda          pic 9(4) comp-x.
+         03 opext-mda           pic 9(2) comp-x.
+         03 filler              pic x.
+         03 prim-rc-mda         pic 9(4) comp-x.
+         03 sec-rc-mda          pic 9(8) comp-x.
+         03 tp-id-mda           pic x(8).
+         03 conv-id-mda         pic x(4).
+         03 filler              pic x.
+         03 dealloc-type-mda    pic 9(2) comp-x.
+         03 filler              pic x(6).
+      *-----------------------------------------------------------------
+       
+      *--------------- mc-flush ----------------------------------------
+       01 mc-flush-verb redefines vcb.
+         03 opcode-mfl          pic 9(4) comp-x.
+         03 opext-mfl           pic 9(2) comp-x.
+         03 filler              pic x.
+         03 prim-rc-mfl         pic 9(4) comp-x.
+         03 sec-rc-mfl          pic 9(8) comp-x.
+         03 tp-id-mfl           pic x(8).
+         03 conv-id-mfl         pic x(4).
+      *-----------------------------------------------------------------
+       
+      *--------------- mc-get-attributes -------------------------------
+       01 mc-get-atts-verb redefines vcb.
+         03 opcode-mga          pic 9(4) comp-x.
+         03 opext-mga           pic 9(2) comp-x.
+         03 filler              pic x.
+         03 prim-rc-mga         pic 9(4) comp-x.
+         03 sec-rc-mga          pic 9(8) comp-x.
+         03 tp-id-mga           pic x(8).
+         03 conv-id-mga         pic x(4).
+         03 filler              pic x.
+         03 sync-lvl-mga        pic 9(2) comp-x.
+         03 mode-name-mga       pic x(8).
+         03 net-name-mga        pic x(8).
+         03 lu-name-mga         pic x(8).
+         03 lu-alias-mga        pic x(8).
+         03 plu-alias-mga       pic x(8).
+         03 plu-un-name-mga     pic x(8).
+         03 filler              pic x(2).
+         03 fqplun-mga          pic x(17).
+         03 filler              pic x.
+         03 user-id-mga         pic x(10).
+         03 filler              pic x(26).
+      *-----------------------------------------------------------------
+       
+      *--------------- mc-prepare-to-receive ---------------------------
+       01 mc-prp-to-rcv-verb redefines vcb.
+         03 opcode-mpr          pic 9(4) comp-x.
+         03 opext-mpr           pic 9(2) comp-x.
+         03 filler              pic x.
+         03 prim-rc-mpr         pic 9(4) comp-x.
+         03 sec-rc-mpr          pic 9(8) comp-x.
+         03 tp-id-mpr           pic x(8).
+         03 conv-id-mpr         pic x(4).
+         03 ptr-type-mpr        pic 9(2) comp-x.
+         03 locks-mpr           pic 9(2) comp-x.
+      *-----------------------------------------------------------------
+       
+      *--------------- mc-receive-and-post -----------------------------
+       01 mc-rcv-and-post-verb redefines vcb.
+         03 opcode-mrp          pic 9(4) comp-x.
+         03 opext-mrp           pic 9(2) comp-x.
+         03 filler              pic x.
+         03 prim-rc-mrp         pic 9(4) comp-x.
+         03 sec-rc-mrp          pic 9(8) comp-x.
+         03 tp-id-mrp           pic x(8).
+         03 conv-id-mrp         pic x(4).
+         03 what-rcvd-mrp       pic 9(4) comp-x.
+         03 filler              pic x(2).
+         03 rts-rcvd-mrp        pic 9(2) comp-x.
+         03 filler              pic x.
+         03 max-len-mrp         pic 9(4) comp-5.
+         03 dlen-mrp            pic 9(4) comp-5.
+         03 dptr-mrp            usage pointer.
+         03 sema-mrp            pic 9(8) comp-5.
+         03 filler              pic x.
+      *-----------------------------------------------------------------
+
+      *--------------- mc-receive-and-wait -----------------------------
+       01 mc-rcv-and-wait-verb redefines vcb.
+         03 opcode-mrw          pic 9(4) comp-x.
+         03 opext-mrw           pic 9(2) comp-x.
+         03 filler              pic x.
+         03 prim-rc-mrw         pic 9(4) comp-x.
+         03 sec-rc-mrw          pic 9(8) comp-x.
+         03 tp-id-mrw           pic x(8).
+         03 conv-id-mrw         pic x(4).
+         03 what-rcvd-mrw       pic 9(4) comp-x.
+         03 filler              pic x(2).
+         03 rts-rcvd-mrw        pic 9(2) comp-x.
+         03 filler              pic x.
+         03 max-len-mrw         pic 9(4) comp-5.
+         03 dlen-mrw            pic 9(4) comp-5.
+         03 dptr-mrw            usage pointer.
+         03 filler              pic x(5).
+      *-----------------------------------------------------------------
+
+      *--------------- mc-receive-immediate ----------------------------
+       01 mc-rcv-imm-verb redefines vcb.
+         03 opcode-mri          pic 9(4) comp-x.
+         03 opext-mri           pic 9(2) comp-x.
+         03 filler              pic x.
+         03 prim-rc-mri         pic 9(4) comp-x.
+         03 sec-rc-mri          pic 9(8) comp-x.
+         03 tp-id-mri           pic x(8).
+         03 conv-id-mri         pic x(4).
+         03 what-rcvd-mri       pic 9(4) comp-x.
+         03 filler              pic x(2).
+         03 rts-rcvd-mri        pic 9(2) comp-x.
+         03 filler              pic x.
+         03 max-len-mri         pic 9(4) comp-5.
+         03 dlen-mri            pic 9(4) comp-5.
+         03 dptr-mri            usage pointer.
+         03 filler              pic x(5).
+      *-----------------------------------------------------------------
+       
+      *--------------- mc-request-to-send ------------------------------
+       01 mc-rq-to-snd-verb redefines vcb.
+         03 opcode-mrs          pic 9(4) comp-x.
+         03 opext-mrs           pic 9(2) comp-x.
+         03 filler              pic x.
+         03 prim-rc-mrs         pic 9(4) comp-x.
+         03 sec-rc-mrs          pic 9(8) comp-x.
+         03 tp-id-mrs           pic x(8).
+         03 conv-id-mrs         pic x(4).
+      *-----------------------------------------------------------------
+       
+      *--------------- mc-send-data ------------------------------------
+       01 mc-snd-data-verb redefines vcb.
+         03 opcode-msd          pic 9(4) comp-x.
+         03 opext-msd           pic 9(2) comp-x.
+         03 filler              pic x.
+         03 prim-rc-msd         pic 9(4) comp-x.
+         03 sec-rc-msd          pic 9(8) comp-x.
+         03 tp-id-msd           pic x(8).
+         03 conv-id-msd         pic x(4).
+         03 rts-rcvd-msd        pic 9(2) comp-x.
+         03 filler              pic x.
+         03 dlen-msd            pic 9(4) comp-5.
+         03 dptr-msd            usage pointer.
+         03 filler              pic x(2).
+      *-----------------------------------------------------------------
+       
+      *--------------- mc-send-error -----------------------------------
+       01 mc-snd-err-verb redefines vcb.
+         03 opcode-mse          pic 9(4) comp-x.
+         03 opext-mse           pic 9(2) comp-x.
+         03 filler              pic x.
+         03 prim-rc-mse         pic 9(4) comp-x.
+         03 sec-rc-mse          pic 9(8) comp-x.
+         03 tp-id-mse           pic x(8).
+         03 conv-id-mse         pic x(4).
+         03 rts-rcvd-mse        pic 9(2) comp-x.
+         03 err-type-mse        pic 9(2) comp-x.
+         03 filler              pic x(8).
+      *-----------------------------------------------------------------
+       
+      *--------------- mc-test-rts -------------------------------------
+       01 mc-test-rts-verb redefines vcb.
+         03 opcode-mtr          pic 9(4) comp-x.
+         03 opext-mtr           pic 9(2) comp-x.
+         03 filler              pic x.
+         03 prim-rc-mtr         pic 9(4) comp-x.
+         03 sec-rc-mtr          pic 9(8) comp-x.
+         03 tp-id-mtr           pic x(8).
+         03 conv-id-mtr         pic x(4).
+         03 filler              pic x.
+      *-----------------------------------------------------------------
+
+      *-----------------------------------------------------------------
+      *        type independent conversation interface
+      *-----------------------------------------------------------------
+
+      *--------------- get-type ----------------------------------------
+       01 get-type-verb redefines vcb.
+         03 opcode-gtt          pic 9(4) comp-x.
+         03 opext-gtt           pic 9(2) comp-x.
+         03 filler              pic x.
+         03 prim-rc-gtt         pic 9(4) comp-x.
+         03 sec-rc-gtt          pic 9(8) comp-x.
+         03 tp-id-gtt           pic x(8).
+         03 conv-id-gtt         pic x(4).
+         03 conv-type-gtt       pic 9(2) comp-x.
+      *-----------------------------------------------------------------
+

Microsoft COBOL v45/DEMO/APPCDEMO/APPCDEMO.DOC

@@ -0,0 +1,254 @@
+
+
+            COBOL Advanced Program to Program (APPC) Demonstration
+            ======================================================
+
+
+   Contents
+   --------
+
+       Introduction
+       Hardware/software requirements
+       Amending the configuration profiles
+       Changing CONFIG.SYS
+       Compiling and running the demonstration
+       User instructions
+
+
+   Introduction
+   ------------
+
+       This document describes how to run a demonstration which uses
+       Advanced Program to Program Communication to communicate between two
+       programs on a network.
+
+       The demonstration is the game Battleships.  Each program controls
+       the two player's views of the battle scene, showing positions of his
+       own ships and coordinates where previous attacks have been made.
+       The game involves a simple two way communication of sending
+       coordinates, receiving opponent's damage reports, receiving
+       opponent's attack coordinates and sending own damage reports.
+       Instructions for playing the game are provided later.
+
+       If you have no previous knowledge of APPC, we recommend that you read
+       the IBM OS/2 Extended Edition Version 1.1 APPC Programming Reference
+       manual to gain a basic understanding of the concepts and terminology.
+       For detailed information about configuring Communications Manager,
+       refer to the IBM Operating System/2 Extended Edition Version 1.1
+       System Administrator's Guide for Communications.  Also read the
+       section on using APPC in the document INTERFAC.DOC.
+
+
+   Hardware/Software requirements
+   ------------------------------
+
+   Hardware:
+
+      o Two IBM PS/2s or machines capable of running IBM OS/2 1.1 Extended
+        Edition
+
+      o Memory enough to run IBM OS/2 1.1 EE with Communications Manager,
+        this will be around 6 megabytes.
+
+      o Both machines to be connected to an IBM Token Ring Network or PC LAN
+        Network
+
+   System Software:
+
+       o IBM OS/2 1.1 Extended Edition
+
+       o Communications Manager (CM)
+
+       o CM configuration profile to run APPC
+
+       o Network Driver software relevent to type of network being used
+
+   Application Software:
+
+       o The following programs/configurations have been provided:
+
+           BATTLEL.CBL  - main program for local machine
+           BATTRER.CBL  - main program for remote machine
+           BATTLE.WKS   - working storage copy file
+           BATTLE.SS    - screen section copy file
+           BATTLE.CBL   - procedure copy file
+           BATTLE.CMD   - batch file to create run files
+           BATTAPPC.CBL - communications interface
+           APPCBATL.CFG - CM configuration profile for local machine
+           APPCBATR.CFG - CM configuration profile for remote machine
+           ADAPTER.EXE  - Utility program to get adapter address
+           APPC.CPY     - APPC COBOL definitions (appc basic/mapped verbs)
+           ACSSVC.CPY   - ACSSVC COBOL definitions (common service verbs)
+
+       o APPC.CPY and ACSSVC.CPY are general purpose copy files, and can be
+         used by any COBOL APPC application.  The files contain definitions
+         for each verb's control block, operation codes, error codes and
+         constants.
+
+
+   Amending the configuration profiles
+   -----------------------------------
+
+   Before you can start running the demonstration programs you must amend
+   one and possibly both the configuration files. The configurations
+   provided assume that you will be using an IBM Token Ring Network running
+   on a PS/2 machine. If you have a different type of machine or you are
+   using a different DLC type (eg. IBM PC Network ) it is likely that you
+   will have to amend the configurations.
+
+   The other change, which you should make to APPCBATL.CFG, is to fill in
+   the adapter number field in the Partner Logical Unit Profiles of the SNA
+   Feature Profiles menu.  This tells Communications Manager which machine
+   on the network to talk converse with.
+
+   The profile which you should change is called DEMOPLU.  To change this
+   field:
+
+     o start Communications Manager with the configuration file as a
+       parameter: 'CM APPCBATL'
+     o press F10 and select 'A' to get to the advanced pull down menu
+     o select 'C' for configuration
+     o enter configuration name APPCBATL (if not already shown) and press
+       enter key
+     o select the SNA Feature Profiles menu
+     o select the PLU profile menu
+     o enter 'H' to change profile
+     o enter profile name 'DEMOPLU1' and press enter key
+     o press enter key to accept first screen
+     o move cursor to adapter number field and enter the adapter address of
+       the network adapter card in the machine that will use the other
+       configuration ie. APPCBATR.CFG.
+     o keep pressing the enter key until you reach the SNA Feature
+       Configuration menu, then press the escape key to get back to
+       Communication Configuration menu
+     o press F10 and then 'V' and the enter key to verify the changes you
+       have made
+     o the verification should complete successfully
+     o exit Communications Manager
+
+   The adapter number is the hard coded address of the network adapter card
+   (each card is given a unique address by the manufacturer). You can find out
+   this address by running ADAPTER.EXE (OS/2 1.1), or by looking in ACSLAN.LOG
+   in the CMLIB directory (OS/2 1.2) on the machine which will use the
+   configuration file 'APPCBATR.CFG'.
+
+
+   Changing CONFIG.SYS
+   -------------------
+
+   The device drivers which control the network hardware require the CM
+   configuration profiles to be specified as parameters.
+
+   If you are using a IBM Token Ring Network amend the following lines in
+   CONFIG.SYS.
+       o on the local machine:
+
+           DEVICE=C:\CMLIB\TRNETDD.SYS CFG=C:\CMLIB\APPCBATL.CFG
+           DEVICE=C:\CMLIB\NETBDD.SYS CFG=C:\CMLIB\APPCBATL.CFG
+
+       o on the remote machine:
+
+           DEVICE=C:\CMLIB\TRNETDD.SYS CFG=C:\CMLIB\APPCBATR.CFG
+           DEVICE=C:\CMLIB\NETBDD.SYS CFG=C:\CMLIB\APPCBATR.CFG
+
+   If you are using a IBM PC LAN Network amend the following lines in
+   CONFIG.SYS.
+       o on the local machine:
+
+           DEVICE=C:\CMLIB\PCNETDD.SYS CFG=C:\CMLIB\APPCBATL.CFG
+           DEVICE=C:\CMLIB\NETBDD.SYS CFG=C:\CMLIB\APPCBATL.CFG
+
+       o on the remote machine:
+
+           DEVICE=C:\CMLIB\PCNETDD.SYS CFG=C:\CMLIB\APPCBATR.CFG
+           DEVICE=C:\CMLIB\NETBDD.SYS CFG=C:\CMLIB\APPCBATR.CFG
+
+       After changing CONFIG.SYS reboot both machines so that the device
+       drivers are reactivated with the correct configurations.
+
+
+   Starting Communications Manager
+   -------------------------------
+
+       Before you start running the demo program you must make sure that you
+       have started Communications Manager (CM) on each machine with the
+       respective configuration file active.  To make the configuration
+       active supply its name as a parameter when you start CM.
+
+       eg. STARTCM APPCBATL
+
+       If you receive any error messages when you start CM you should fix
+       these problems before attempting to run the programs.  If you do have
+       problems record the error message number and refer to the IBM OS/2 EE
+       Manual on Programming Services and Problem Determination for
+       Communications for help.
+
+
+   Compiling and running the demonstration
+   ---------------------------------------
+
+   The demonstration programs can be compiled for use with Animator or as
+   object files which can then be linked to produce standalone executable
+   programs.
+
+   A batch file has been provided : BATTLE.CMD which will create the
+   files to run the demonstration.  The batch file will produce files for
+   animation or for direct execution.
+
+   To run the demonstration, start BATTLEL on the machine that has
+   configuration profile APPCBATL.CFG active.
+
+   If there are no problems with the connection, a message on the remote
+   machine should appear instructing the operator to begin a transaction
+   program called BATTLE.
+
+   This message is your prompt to start BATTLER on the remote machine.
+
+   If a conversation is established, the two programs should start to
+   communicate with each other and the BATTLESHIPS game should start.
+
+   If any errors occur, the program will stop and the error codes, together
+   with the verb operation code will be displayed.  Refer to the APPC
+   Reference Manual for information on error codes. Additional information
+   is provided by the error log, which can be accessed from the Problem
+   Determination menu of the Advanced features pull down menu. This provides
+   information in the form of error codes which reference cause/diagnosis
+   text in the Problem Determination for Communications manual - it will
+   also report what area of communications the problem occured in.
+
+   Unless you change the programs, the most likely cause of any problems
+   that may occur will be due to problems in the configuration file.  The
+   configurations provided are model profiles.  This means that you may have
+   to amend some fields in the profile which suit the particular setup you
+   have.  For example the LAN Adapter Type profile has been configured as an
+   IBM Token-Ring Network Adapter /A card which is generally used by IBM
+   PS/2 machines.  If you are using a different machine you will likely have
+   to change the profile to configure a different type of card.  Also it is
+   possible to have two adapter cards installed in a machine. The primary
+   adapter card is known as Adapter 0 and the secondary as Adapter 1.  The
+   configurations assume only one card is installed which define Adapter 0.
+   If you have two cards, you may have to alter the profile to reflect this.
+
+
+   User Instructions
+   -----------------
+
+   Before the game starts, both players should agree on how many ships that
+   are going to take part and how many of each type of ship.  There are four
+   types of ships: Aircraft Carrier, Battleship, Frigate and Gun-Boat,
+   denoted by the letters: A,B,F and G respectively. There is no limit to
+   the numbers of ships, nor of each type.  The only requirement is that
+   different ships of the same type are not placed in adjacent locations to
+   one another.
+
+   The game starts for player 1. Player 1 selects a grid coordinate where he
+   thinks an opponent ship is located. Coordinates are specified in column
+   row order (eg. F2).  After a while, player 1 will receive a damage report
+   of the earlier attempt this will be either a hit, a miss or a sinking.
+   If a part of an opponent's ship has been hit, the grid location is
+   colored red, a miss it is colored cyan and a sink, the whole ship is
+   marked in black.  After this player 2 has his turn. The player who sinks
+   all of his opponent's ships first wins the game.
+
+   The game can be stopped by entering a grid location of Q.  This will
+   send a message to the opponent to quit.

Microsoft COBOL v45/DEMO/APPCDEMO/BATTAPPC.CBL

@@ -0,0 +1,646 @@
+      $set mf ans85 noosvs
+      *******************************************************************
+      *                                                                 *
+      *                                                                 *
+      *                  (C) Micro Focus Ltd. 1990                      *
+      *                                                                 *
+      *                         BATTAPPC.CBL                            *
+      *                                                                 *
+      *      COBOL Advanced Program to Program (APPC) Demonstration     *
+      *                                                                 *
+      *                         Battleships                             *
+      *                    communications module                        *
+      *                                                                 *
+      *******************************************************************
+
+      *******************************************************************
+      *        BATTAPPC - links two battleships games using APPC        *
+      *                                                                 *
+      *  This program is called by BATTLEL & BATTLER to communicate     *
+      *  between one another.                                           *
+      *                                                                 *
+      *  The communications that take place are:                        *
+      *        - to bring up a link between the two programs            *
+      *        - to take down a link                                    *
+      *        - to send coordinates to a program                       *
+      *        - to receive coordinates from a program                  *
+      *        - to send a damage report to a program                   *
+      *        - to receive a damage report from a program              *
+      *                                                                 *
+      *  The method of communication is entirey transparent to the      *
+      *  users of the game.  So long as the same interface is used,     *
+      *  this module could be replaced by one which used a different    *
+      *  communications protocol.                                       *
+      *                                                                 *
+      *  The interface consists of two parameters.  The first parameter *
+      *  is the operation code - indicating which function to perform.  *
+      *  The second parameter is a buffer area which is used to pass    *
+      *  information between the communicating programs.                *
+      *                                                                 *
+      *  The result of any operation is returned to the calling program *
+      *  in the RETURN-CODE system variable.  A zero value indicates    *
+      *  success and a non-zero value indicates some error  - In this   *
+      *  example program, the error handling is very simple - in that   *
+      *  the programs will stop if any error is received.  You may,     *
+      *  however, decide to provide more intelligent error handling, in *
+      *  which the user of the game may be given alternative courses of *
+      *  action when such an error occurs.                              *
+      *                                                                 *
+      *******************************************************************
+       Special-names.
+           call-convention 3 is api.
+
+       Working-Storage Section.
+       copy "appc.cpy".
+       copy "acssvc.cpy".
+
+      *-----------------------------------------------------------------
+      * Working variables
+      *-----------------------------------------------------------------
+       01  tp-name                     pic x(64) value spaces.
+       78  tp-name-len                 value 64.
+       01  tp-id                       pic x(8) value spaces.
+       01  lu-alias                    pic x(8) value spaces.
+       01  plu-alias                   pic x(8) value spaces.
+       01  conv-id                     pic x(4) value spaces.
+       01  mode-name                   pic x(8) value spaces.
+       78  mode-name-len               value 8.
+
+       01  what-received               pic 9(4) comp-x.
+       01  request-to-send-received    pic 9(2) comp-x.
+       01  state-flag                  pic 9(2) comp-x.
+           88 Sending-State            value 1.
+           88 Receiving-State          value 0.
+
+       01  data-buffer-length          pic 9(4) comp-5.
+       01  data-buffer-ptr             usage pointer.
+       01  data-buffer-address
+           redefines data-buffer-ptr.
+           03 data-buffer-offset       pic 9(4) comp-5.
+           03 data-buffer-selector     pic 9(4) comp-5.
+       01  alloc-flags                 pic 9(4) comp-5 value 1.
+       01  key-char pic x.
+
+
+      *-----------------------------------------------------------------
+      * following items used for constructing error message
+      *-----------------------------------------------------------------
+       01  bin-dword.
+           03 bin-dword-msw            pic 9(4) comp-x.
+           03 bin-dword-lsw            pic 9(4) comp-x.
+       01  bin-val.
+           03 bin-val-1                pic 9(2) comp-x.
+           03 bin-val-2                pic 9(2) comp-x.
+
+       01  hex-idx-1                   pic 9(2) comp-x.
+       01  hex-idx-2                   pic 9(2) comp-x.
+       01  hex-disp                    pic x(4).
+       01  hex-string                  pic x(16)
+                                      value "0123456789ABCDEF".
+       01  clear-char                  pic x value " ".
+       01  clear-attr                  pic 9(2) comp-x value 7.
+       01  screen-pos                  pic 9(4) comp-x value h"0100".
+       01  error-msg.
+           03 filler                   pic x(25)
+                                      value 'APPC/ACSSVC Error Verb=x"'.
+           03 error-1                  pic x(4).
+           03 filler                   pic x(17)
+                                      value '" Primary Code=x"'.
+           03 error-2                  pic x(4).
+           03 filler                   pic x(19)
+                                      value '" Secondary Code=x"'.
+           03 error-3                  pic x(4).
+           03 error-4                  pic x(4).
+           03 filler                   pic x value '"'.
+
+      *-----------------------------------------------------------------
+      *  interface paramters
+       LINKAGE SECTION.
+      *-----------------------------------------------------------------
+       01 Comm-Code                    Pic 9(2) Comp.
+       01 Comm-Buffer                  Pic x(12).
+
+      *-----------------------------------------------------------------
+       01 Shared-Segment-Buffer        Pic x(12).
+      *    This is a special linkage item - not used as a parameter -
+      *    but as a buffer whose address is set to a shared unnamed
+      *    segment, allocated later on.  This type of memory is
+      *    required by some APPC verbs - see later for details
+      *
+      *-----------------------------------------------------------------
+
+
+      *=================================================================
+      *
+      *---------------------Call Interface------------------------------
+       PROCEDURE DIVISION using
+                                   by value Comm-Code
+                                   by reference Comm-Buffer.
+      *-----------------------------------------------------------------
+      *=================================================================
+
+
+      *-----------------------------------------------------------------
+       Evaluate-Operation.
+      *    work out which high level operation to perform
+      *
+      *-----------------------------------------------------------------
+           Evaluate Comm-Code
+               When 1      Perform Bring-Up-Link
+               When 2      Perform Take-Down-Link
+               When 3      Perform Send-Coords
+               When 4      Perform Receive-Coords
+               When 5      Perform Send-Report
+               When 6      Perform Receive-Report
+               When other  move 1 to Return-Code
+           End-Evaluate
+           move 0 to Return-Code
+           Exit Program.
+
+      *-----------------------------------------------------------------
+       Error-Exit.
+      *  quick exit in case of error during APPC
+      *
+      *-----------------------------------------------------------------
+           move 1 to Return-Code
+           Exit Program.
+
+      *-----------------------------------------------------------------
+       Bring-Up-Link.
+      *    High level function to initiate a communication between
+      *    two transaction programs playing the game.
+      *
+      *    The verbs issued to start a conversation are  different
+      *    for each program - only one end may start the communication
+      *    with a MC-ALLOCATE verb - this is received at the other end
+      *    by a RECEIVE-ALLOCATE verb.
+      *
+      *    The LU-ALIAS, partner LU-ALIAS, MODE-NAME and TP-NAME which
+      *    are defined in the configuration profile for this
+      *    communication are placed in variables for various verbs to
+      *    use.  These names must match up with those defined in the
+      *    configuration currently active - switch to the
+      *    communications Manager session and check to see that the
+      *    correct profile is loaded.
+      *
+      *    Some fields passed in the Verb Control Block have to be
+      *    defined in EBCDIC - all of these fields are converted from
+      *    ASCII using a special utility routine provided as part
+      *    of the Communications Manager software (ie. ACSSVC.DLL)  -
+      *    this is done initially and the converted fields are saved in
+      *    temporary variables for later use.
+      *
+      *    The other verbs (seen in capitals) are used to request
+      *    resources of APPC before a conversation starts (TP-STARTED)
+      *    and is only required on the MC-ALLOCATE side.  The other
+      *    verb (ie MC-FLUSH) causes the allocation request to be sent
+      *    to the remote machine immediately - this is because send
+      *    buffers are not normally sent off until a buffer becomes
+      *    full - so as to minimise on transmissions.  The MC-FLUSH
+      *    verb is useful in this situation if you want a remote
+      *    program to connect immediately.
+      *
+      *    Comm-buffer is used to tell this module which program is
+      *    calling it - so that it can decide which set of verbs to
+      *    issue.
+      *
+      *-----------------------------------------------------------------
+           If Comm-Buffer = "PLAYER1"
+      *            local end
+      *            initialise configuration names
+               move 'DEMOPLU1' to plu-alias
+               move 'DEMOLU1 ' to lu-alias
+               move 'DEMOMODE' to mode-name
+               move 'BATTLE  ' to tp-name
+      *            convert to EBCDIC
+               Perform Convert-Tp-Name
+               Perform Convert-Mode-Name
+      *            issue APPC verbs to request resources and send
+      *            immediate an allocation request to the remote machine
+               Perform TP-STARTED
+               Perform MC-ALLOCATE
+               Perform MC-FLUSH
+           Else
+      *            remote end
+      *            initialise configuration name
+               move 'BATTLE  ' to Tp-Name
+      *            convert to EBCDIC
+               Perform Convert-Tp-Name
+      *            issue APPC verb to receive allocation request
+               Perform RECEIVE-ALLOCATE
+           End-If
+      *       allocate a buffer to be used by send and receive verbs
+           Perform Allocate-Shared-Memory.
+
+      *-----------------------------------------------------------------
+       Allocate-Shared-Memory.
+      *    Send and receive verbs: MC-SEND-DATA and MC-RECEIVE-AND-WAIT
+      *    require the data buffer used as one of their parameters to
+      *    be an unnamed shared segment - this is allocated with
+      *    the DosAllocSeg api call with alloc-flag = 1
+      *
+      *-----------------------------------------------------------------
+           move zero to Data-Buffer-Offset
+           move Length of Comm-Buffer to Data-Buffer-Length
+           move 1 to Alloc-Flags
+      *        for COBOL/2 Toolset, do next statement
+      *        call "cobolapi"
+           call "__DosAllocSeg" using
+                           by value Alloc-Flags
+                           by reference Data-Buffer-Selector
+                           by value Data-Buffer-Length
+           If RETURN-CODE not = zero
+               Go to Error-Exit
+           End-If.
+
+
+      *-----------------------------------------------------------------
+       Take-Down-Link.
+      *    This high level routine stops a conversation and releases
+      *    resources used by the conversation.
+      *
+      *    The conversation is stopped at the sending end, ie the
+      *    machine at which the last send verb was issued,  with
+      *    the verb MC-DEALLOCATE.
+      *
+      *    The MC-DEALLOCATE verb is issued with type FLUSH which
+      *    performs the same function as MC-FLUSH before the
+      *    deallocation is sent - causing any unsent buffers to be
+      *    transmitted.
+      *
+      *    The MC-RECEIVE-AND-WAIT is the verb issued at the receiving
+      *    end, ie the machine at which the last receive verb was
+      *    issued.  This verb waits until the deallocation signal
+      *    arrives from the sending end.
+      *
+      *    The TP-ENDED verb is used to release resources at both
+      *    ends of the terminated conversation.
+      *
+      *-----------------------------------------------------------------
+           If Sending-State
+               Perform MC-DEALLOCATE
+           Else
+               Perform MC-RECEIVE-AND-WAIT
+           End-If
+           Perform TP-ENDED.
+
+
+      *-----------------------------------------------------------------
+       Send-Coords.
+      *    This high level operation sends coordinates contained in
+      *    the buffer to be sent to the remote machine and then makes
+      *    ready to receive a damage report from it.
+      *
+      *    MC-SEND-DATA causes the contents of the buffer to be sent
+      *    to the particular LU defined.
+      *
+      *    After successful completion of MC-SEND-DATA , the
+      *    conversation is placed in receive state by the
+      *    MC-PREPARE-TO-RECEIVE verb - this is in readiness to receive
+      *    the damage report of the coordinates specified.
+      *
+      *    The MC-PREPARE-TO-RECEIVE also flushes the send buffer so
+      *    that nothing is left before any receive verbs take place.
+      *
+      *-----------------------------------------------------------------
+           set address of Shared-Segment-Buffer to Data-Buffer-Ptr
+           move Comm-Buffer to Shared-Segment-Buffer
+           Perform MC-SEND-DATA
+           Perform MC-PREPARE-TO-RECEIVE.
+
+      *-----------------------------------------------------------------
+       Receive-Report.
+      *    The damage report is received using the verb
+      *    MC-RECEIVE-AND-WAIT.  This verb waits indefinitely for the
+      *    remote machine to send data.  When something is received
+      *    a check is made that the data received is complete - if you
+      *    are sending large amounts of information, data may be
+      *    contained in several buffers and the 'what-received' verb
+      *    contains a code to indicate if the buffer is complete or
+      *    not.  This routine performs a loop issuing the verb until
+      *    the last buffer arrives.
+      *
+      *-----------------------------------------------------------------
+           move zero to what-received
+           perform until what-received = ap-data-complete
+               Perform MC-RECEIVE-AND-WAIT
+           end-perform
+           set address of Shared-Segment-Buffer to Data-Buffer-Ptr
+           move Shared-Segment-Buffer to Comm-Buffer.
+
+
+      *-----------------------------------------------------------------
+       Receive-Coords.
+      *    The coordinates are received using the MC-RECEIVE-AND-WAIT
+      *    verb.  The buffer is received followed by a signal from the
+      *    remote machine that it is ready to receive - so that the
+      *    local end can send the damage report.  The signal passed to
+      *    the MC-RECEIVE-AND-WAIT verb is contained in the
+      *    'what-received' field.
+      *
+      *-----------------------------------------------------------------
+           move zero to what-received
+           perform until what-received = ap-send
+               Perform MC-RECEIVE-AND-WAIT
+           end-perform
+           set address of Shared-Segment-Buffer to Data-Buffer-Ptr
+           move Shared-Segment-Buffer to Comm-Buffer.
+
+
+      *-----------------------------------------------------------------
+       Send-Report.
+      *    This sends the buffer using an MC-SEND-DATA verb followed
+      *    by MC-FLUSH to transmit the buffer.
+      *
+      *-----------------------------------------------------------------
+           set address of Shared-Segment-Buffer to Data-Buffer-Ptr
+           move Comm-Buffer to Shared-Segment-Buffer
+           Perform MC-SEND-DATA
+           Perform MC-FLUSH.
+
+
+      *=================================================================
+      *=================================================================
+      *-----------------------------------------------------------------
+      *    The conversion routines below use a service utility called
+      *    the Common Services Programming Interface.  It provides:
+      *       -  ASCII/EBCDIC conversion in both directions
+      *       -  traces API verbs and data
+      *       -  provides translation tables for specified code pages
+      *       -  records messages in CM message log
+      *       -  sends network management messages to a network
+      *            management service
+      *
+      *    Here we only use it for ASCII-EBCDIC using the CONVERT verb
+      *
+      *-----------------------------------------------------------------
+      * ASCII-EBCDIC conversion routines
+
+       Convert-Mode-Name.
+           move all x"00" to VCB
+           move sv-convert to opcode-cvt
+           move sv-ascii-to-ebcdic to direction-cvt
+           move sv-a to char-set-cvt
+           move mode-name-len to len-cvt
+           set src-ptr-cvt to address of mode-name
+           set targ-ptr-cvt to address of mode-name
+           perform Execute-Acssvc-Verb
+           perform Check-Error.
+
+       Convert-Tp-Name.
+           move all x"00" to VCB
+           move sv-convert to opcode-cvt
+           move sv-ascii-to-ebcdic to direction-cvt
+           move sv-ae to char-set-cvt
+           move tp-name-len to len-cvt
+           set src-ptr-cvt to address of tp-name
+           set targ-ptr-cvt to address of tp-name
+           perform Execute-Acssvc-Verb
+           perform Check-Error.
+
+      *-----------------------------------------------------------------
+      *
+      * The following routines define the call interfaces to the
+      * various APPC verbs required above
+      *
+      *
+      *-----------------------------------------------------------------
+
+      *-----------------------------------------------------------------
+       Receive-Allocate.
+      *    wait receipt of allocation request from local machine
+      *    and then start a new transaction program
+      *
+      *    The VCB should always be initialized with low values before
+      *    any fields are loaded.  The verb returns a tp-id and a
+      *    conv-id which are to be used by subsequent verbs during the
+      *    conversation.
+      *
+      *    LU-Alias, PLU-Alias and mode name of the session are also
+      *    returned.
+      *
+      *    A check on the return codes should always be made after
+      *    issuing a verb.  In this case an error causes an immediate
+      *    return to the calling program to occur.
+      *
+      *-----------------------------------------------------------------
+           move all x"00" to VCB
+           move ap-receive-allocate to opcode-ral
+           move tp-name to tp-name-ral
+           set Receiving-State to True
+           perform Execute-Appc-Verb
+           perform Check-Error
+           move tp-id-ral to tp-id
+           move conv-id-ral to conv-id
+           move lu-alias-ral to lu-alias
+           move plu-alias-ral to plu-alias
+           move mode-name-ral to mode-name.
+
+      *-----------------------------------------------------------------
+       MC-Receive-and-Wait.
+      *    wait for data or signal to be sent.  The 'what-received'
+      *    field is returned by this call and indicates the type of
+      *    information sent eg. data buffer or a signal to start
+      *    sending data.
+      *
+      *    The buffer that the data is sent to MUST be a shared,
+      *    unnamed segment of memory.  This is allocated using the
+      *    DosAllocSeg function call (with flags=1).
+      *
+      *-----------------------------------------------------------------
+           set Receiving-State to True
+           move all x"00" to VCB
+           move ap-m-receive-and-wait to opcode-mrw
+           move ap-mapped-conversation to opext-mrw
+           move tp-id to tp-id-mrw
+           move conv-id to conv-id-mrw
+           set dptr-mrw to Data-Buffer-Ptr
+           move Data-Buffer-Length to max-len-mrw
+           perform Execute-Appc-Verb
+           If prim-rc-mda not = h"0009"
+      *            if primary return code = h"0009"
+      *              don't treat as error - returned when receiving
+      *              deallocation signal from MC-DEALLOCATE verb
+               perform check-error
+           End-If
+           move what-rcvd-mrw to what-received
+           move rts-rcvd-mrw to request-to-send-received.
+
+
+      *-----------------------------------------------------------------
+       MC-Allocate.
+      *    send an allocaton request to a remote machine to start a
+      *    conversation.  This verbs requires certain names defined in
+      *    the configuration profile.
+      *
+      *-----------------------------------------------------------------
+           move all x"00" to VCB
+           move ap-m-allocate to opcode-mal
+           move ap-mapped-conversation to opext-mal
+           move 1 to opext-mal
+           move tp-id to tp-id-mal
+           move ap-confirm-sync-level to sync-lvl-mal
+           move ap-when-session-allocated to rtn-ctl-mal
+           move plu-alias to plu-alias-mal
+           move mode-name to mode-name-mal
+           move tp-name to tp-name-mal
+           move ap-none to security-mal
+           set Sending-State to True
+           perform Execute-Appc-Verb
+           perform Check-Error
+           move conv-id-mal to conv-id.
+
+      *-----------------------------------------------------------------
+       MC-Send-Data.
+      *    send a buffer to the remote machine.  The buffer MUST be
+      *    a shared unnamed segment of memory.  This is allocated using
+      *    the DosAllocSeg function call (with flags=1).
+      *
+      *-----------------------------------------------------------------
+           set Sending-State to True
+           move all x"00" to VCB
+           move ap-m-send-data to opcode-msd
+           move ap-mapped-conversation to opext-msd
+           move tp-id to tp-id-msd
+           move conv-id to conv-id-msd
+           move data-buffer-length to dlen-msd
+           set dptr-msd to data-buffer-ptr
+           perform Execute-Appc-Verb
+           perform Check-Error
+           move rts-rcvd-msd to request-to-send-received.
+
+      *-----------------------------------------------------------------
+       MC-Deallocate.
+      *    close a conversation
+      *
+      *-----------------------------------------------------------------
+           set Sending-State to True
+           move all x"00" to VCB
+           move ap-m-deallocate to opcode-mda
+           move ap-mapped-conversation to opext-mda
+           move tp-id to tp-id-mda
+           move conv-id to conv-id-mda
+           move ap-flush to dealloc-type-mda
+           perform Execute-Appc-Verb
+           perform Check-Error.
+
+      *-----------------------------------------------------------------
+       MC-Flush.
+      *    cause any unsent data to be transmitted immediately
+      *
+      *-----------------------------------------------------------------
+           move all x"00" to VCB
+           move ap-m-flush to opcode-fls
+           move ap-mapped-conversation to opext-fls
+           move tp-id to tp-id-fls
+           move conv-id to conv-id-fls
+           perform Execute-Appc-Verb
+           perform Check-Error.
+
+      *-----------------------------------------------------------------
+       MC-Prepare-To-Receive.
+      *    cause a change of conversation state from send to receive -
+      *    this must be done before a MC-SEND-DATA verb can be issued
+      *    by the remote end - when it is in receive state.  This verb
+      *    causes the local end to go into receive state.
+      *
+      *-----------------------------------------------------------------
+           set Receiving-State to True
+           move all x"00" to VCB
+           move ap-m-prepare-to-receive to opcode-ptr
+           move ap-mapped-conversation to opext-ptr
+           move tp-id to tp-id-ptr
+           move conv-id to conv-id-ptr
+           move ap-flush to ptr-type-ptr
+           perform Execute-Appc-Verb
+           perform Check-Error.
+
+      *-----------------------------------------------------------------
+       TP-Started.
+      *    allocate resources for conversation
+      *
+      *-----------------------------------------------------------------
+           move all x"00" to VCB
+           move ap-tp-started to opcode-tps
+           move lu-alias to lu-alias-tps
+           move tp-name to tp-name-tps
+           perform Execute-Appc-Verb
+           perform Check-Error
+           move tp-id-tps to tp-id.
+
+      *-----------------------------------------------------------------
+       TP-Ended.
+      *    release resources used by earlier conversation
+      *
+      *-----------------------------------------------------------------
+           move all x"00" to VCB
+           move ap-tp-ended to opcode-tpe
+           move tp-id to tp-id-tpe
+           perform Execute-Appc-Verb.
+
+      *-----------------------------------------------------------------
+       Execute-Appc-Verb.
+      *    interface to appc/acssvc uses load-time dynamic linking
+      *    two methods may be employed:
+      *        - to specify IMPORTS statements in .DEF file
+      *        - to use ACS.LIB link library
+      *
+      *    (both methods are used in BATTLE.CMD)
+      *
+      *-----------------------------------------------------------------
+           call "__APPC" using by reference vcb.
+
+      *-----------------------------------------------------------------
+       Execute-Acssvc-Verb.
+      *
+      *-----------------------------------------------------------------
+           call "__ACSSVC" using by reference vcb.
+
+      *-----------------------------------------------------------------
+       Check-Error.
+      *    if any error on the primary return code - convert error
+      *    to hex display, display error, wait for key and exit program
+      *
+      *-----------------------------------------------------------------
+           if prim-rc-vcb not = 0
+               move opcode-vcb to bin-val
+               perform bin-to-hexdisp
+               move hex-disp to error-1
+               move prim-rc-vcb to bin-val
+               perform bin-to-hexdisp
+               move hex-disp to error-2
+               move sec-rc-vcb to bin-dword
+               move bin-dword-msw to bin-val
+               perform bin-to-hexdisp
+               move hex-disp to error-3
+               move bin-dword-lsw to bin-val
+               perform bin-to-hexdisp
+               move hex-disp to error-4
+               call "cbl_clear_scr"
+                   using clear-char
+                         clear-attr
+               call "cbl_set_csr_pos" using screen-pos
+               display error-msg
+               display "press any key to continue"
+               call "cbl_read_kbd_char"
+                   using key-char
+               go to Error-Exit
+           end-if.
+
+      *-----------------------------------------------------------------
+       Bin-to-Hexdisp.
+      *    converts bin-val - a binary word value into a displayable
+      *    hex value that can be inserted into the error message string
+      *
+      *-----------------------------------------------------------------
+           divide bin-val-1 by 16
+               giving hex-idx-1 remainder hex-idx-2
+           add 1 to hex-idx-1 hex-idx-2
+           move hex-string(hex-idx-1:1) to hex-disp(1:1)
+           move hex-string(hex-idx-2:1) to hex-disp(2:1)
+           divide bin-val-2 by 16
+               giving hex-idx-1 remainder hex-idx-2
+           add 1 to hex-idx-1 hex-idx-2
+           move hex-string(hex-idx-1:1) to hex-disp(3:1)
+           move hex-string(hex-idx-2:1) to hex-disp(4:1).
+

Microsoft COBOL v45/DEMO/APPCDEMO/BATTLE.CMD

@@ -0,0 +1,177 @@
+@echo off
+cls
+echo        COBOL Advanced Program to Program (APPC) Demonstration
+echo        ------------------------------------------------------
+echo                        Battleships game
+echo                        ----------------
+if %1. == . goto noparam
+if %1 == shared set appcmd=shared & goto okparam
+if %1 == SHARED set appcmd=shared & goto okparam
+if %1 == static set appcmd=static & goto okparam
+if %1 == STATIC set appcmd=static & goto okparam
+if %1 == animate set appcmd=animate & goto okparam
+if %1 == ANIMATE set appcmd=animate & goto okparam
+:noparam
+echo     usage: 
+echo           BATTLE ANIMATE   - create run files ready for ANIMATION
+echo           BATTLE STATIC    - create run files by linking with STATIC          
+echo                              run-time support (LCOBOL.LIB)
+echo           BATTLE SHARED    - create run files by linking with SHARED
+echo                              run-time support (COBLIB.LIB)
+goto end
+
+:okparam
+echo ------------------------------------------------------------------------
+echo Copying ADIS modules:
+copy \cobol\lib\ADIS*.OBJ
+copy \cobol\lib\ADIS.DEF
+if not exist ADIS.OBJ goto noadis
+if not exist ADISINIT.OBJ goto noadis
+if not exist ADISKEY.OBJ goto noadis
+if not exist ADISDYNA.OBJ goto noadis
+if not exist ADIS.DEF goto noadis
+echo ADIS+ADISINIT+ADISKEY+ADISDYNA >ADIS.LNK
+if %appcmd% == shared goto shared
+
+echo LIBRARY INITINSTANCE   >BATTAPPC.DEF
+echo PROTMODE              >>BATTAPPC.DEF
+echo DATA NONSHARED        >>BATTAPPC.DEF
+echo EXPORTS BATTAPPC @1   >>BATTAPPC.DEF
+echo IMPORTS APPC.APPC     >>BATTAPPC.DEF
+echo IMPORTS ACSSVC.ACSSVC >>BATTAPPC.DEF
+goto %appcmd%
+
+:ANIMATE
+echo Creating run files for Animation...
+echo ------------------------------------------------------------------------
+echo Compiling...
+echo cobol battlel anim;
+cobol battlel anim;
+if not exist battlel.gnt goto compilerr
+echo - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+echo cobol battler anim;
+cobol battler anim;
+if not exist battler.gnt goto compilerr
+echo - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+echo cobol battappc anim opt(0);
+cobol battappc anim omf(obj) opt(0);
+if not exist battappc.obj goto compilerr
+if exist battappc.int erase battappc.int
+link battappc,,,coblib+os2,battappc.def;
+echo Compiling finished.
+echo ------------------------------------------------------------------------
+echo Copy following files to remote machine:
+echo   BATTLER.*
+echo   BATTAPPC.*
+echo To run on local machine enter:  ANIMATE BATTLEL
+echo To run on remote machine enter: ANIMATE BATTLER
+goto end
+
+:STATIC
+echo Creating run files with static run time system...
+echo ------------------------------------------------------------------------
+echo Compiling...
+echo cobol battlel;
+cobol battlel;
+if not exist battlel.obj goto compilerr
+echo - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+echo cobol battler;
+cobol battler;
+if not exist battler.obj goto compilerr
+echo - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+echo cobol battappc;
+cobol battappc;
+if not exist battappc.obj goto compilerr
+echo Compiling finished.
+echo ------------------------------------------------------------------------
+
+echo Linking...
+: In this example, the sub program battappc.obj is linked on its
+: own into a dll program.  You could, if you prefer link this object
+: in directly with the main program to create one executable - this is
+: what has been done for the example of linking with a shared run time below.
+: Same point applies to the ADIS sub program modules.
+
+echo link battlel /stack:3500,,,lcobol+os2;
+link battlel /stack:3500,,,lcobol+os2;
+if not exist battlel.exe goto linkerr
+echo - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+echo link battler /stack:3500,,,lcobol+os2;
+link battler /stack:3500,,,lcobol+os2;
+if not exist battler.exe goto linkerr
+echo - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+echo link battappc,,,lcobol+os2,battappc.def;
+link battappc,,,lcobol+os2,battappc.def;
+if not exist battappc.dll goto linkerr
+echo - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+echo link @adis.lnk,,,lcobol+os2,adis.def;
+link @adis.lnk,,,lcobol+os2,adis.def;
+if not exist adis.dll goto linkerr
+echo Linking finished.
+echo ------------------------------------------------------------------------
+
+echo Copy following files to remote machine:
+echo   BATTLER.EXE
+echo   BATTAPPC.DLL
+echo   ADIS.DLL
+echo To run on local machine enter:  BATTLEL
+echo To run on remote machine enter: BATTLER
+echo Ensure directories containing .DLL files are on LIBPATH
+goto end
+
+:SHARED
+echo Creating run files with shared run time system...
+echo ------------------------------------------------------------------------
+echo Compiling...
+echo cobol battlel;
+cobol battlel;
+if not exist battlel.obj goto compilerr
+echo - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+echo cobol battler;
+cobol battler;
+if not exist battler.obj goto compilerr
+echo - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+echo cobol battappc;
+cobol battappc;
+if not exist battappc.obj goto compilerr
+echo Compiling finished
+echo ------------------------------------------------------------------------
+
+echo Linking...
+echo link battlel+battappc+@adis.lnk,,,coblib+os2+acs.lib;
+link battlel+battappc+@adis.lnk,,,coblib+os2+c:\cmlib\acs.lib;
+if not exist battlel.exe goto linkerr
+echo - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+echo link battler+battappc+@adis.lnk,,,coblib+os2+acs.lib;
+link battler+battappc+@adis.lnk,,,coblib+os2+c:\cmlib\acs.lib;
+if not exist battler.exe goto linkerr
+echo Linking finished
+echo ------------------------------------------------------------------------
+
+echo Copy following file to remote machine:
+echo   BATTLER.EXE
+
+echo To run on local machine enter:  BATTLEL
+echo To run on remote machine enter: BATTLER
+goto end
+
+:linkerr
+echo Linking error.  Batch aborted.
+goto end
+
+:compilerr
+echo Compliation error.  Batch aborted.
+goto end
+
+:noadis
+echo ADIS Modules not found...  compilation aborted.
+echo copy from your COBDIR directory:
+echo       ADIS.OBJ, ADISKEY.OBJ, ADISINIT.OBJ, ADISDYNA.OBJ and ADIS.DEF
+
+:end
+if exist *.obj erase *.obj
+if exist *.lnk erase *.lnk
+if exist *.def erase *.def
+if exist *.map erase *.map
+set appcmd=
+

Microsoft COBOL v45/DEMO/APPCDEMO/BATTLE.CPY

@@ -0,0 +1,409 @@
+      *******************************************************************
+      *                                                                 *
+      *                                                                 *
+      *                  (C) Micro Focus Ltd. 1990                      *
+      *                                                                 *
+      *                         BATTLE.CPY                              *
+      *                                                                 *
+      *    Common procedure division code for both player programs      *
+      *                                                                 *
+      *******************************************************************
+
+       Battle-Ships.
+           Perform Start-Ships
+           Perform Play-Ships
+           Perform End-Ships
+           STOP RUN.
+
+       Start-Ships.
+           Move all "01" to Grid-Att-Table
+      *-----------------------------------------------------------------
+      *    the following procedures calls have been commented to show
+      *    possible enhancements you may like to make to allow players
+      *    to define grids dynamically and validate grids.
+      *
+      *-----------------------------------------------------------------
+      *    Perform Setup-Grid-Coords
+      *    Perform Validate-Grid-Coords
+           Display Battle-Screen
+           Perform Connect-Opponent.
+
+       Play-Ships.
+      *-----------------------------------------------------------------
+      *    Battleship is played by taking turns.  Player 1 always starts
+      *    first.  So while player 1 has its turn,  player 2 is
+      *    servicing player 1's turn eg. receiving coordinates,
+      *    assessing damage and reporting back.
+      *    When it is player 2's turn, the roles are reversed, such
+      *    that player 2 is now sending coordinates and player 1 is
+      *    servicing player 2.  This continues until one of the players
+      *    has sunk all the ships of the other player.
+      *
+      *-----------------------------------------------------------------
+           Perform Until Game-Over
+               If Player-Id = "PLAYER1"
+                   Perform Local-Turn
+                   If not Game-Over
+                       Perform Remote-Turn
+                   End-If
+               Else
+                   Perform Remote-Turn
+                   If not Game-Over
+                       Perform Local-Turn
+                   End-If
+               End-If
+           End-Perform.
+
+       End-Ships.
+           Perform Disconnect-Opponent
+           Perform Display-Game-Outcome
+           Perform Get-Keystroke.
+
+      *-----------------------------------------------------------------
+      *    Each turn consists of getting grid coordinates, sending the
+      *    coordinates to the opponent, waiting for a damage report and
+      *    assessing that damage.  The opponents turn acts in reverse
+      *    to your turn - so while you send grid coordinates it is
+      *    waiting to receive them at the remote end and when you wait
+      *    for a damage report it is assessing the damage caused and
+      *    then it sends the damage report to you etc.
+      *
+      *-----------------------------------------------------------------
+       Local-Turn.
+           Perform Get-Coords
+           Perform Send-Grid-Coords
+           Perform Receive-Opponent-Damage
+           Perform Assess-Opponent-Damage
+           Display Battle-Damage
+           Display Battle-Field.
+
+      *-----------------------------------------------------------------
+      *    The remote turn consists of receiving grid coordinates from
+      *    the opponent, assessing the damage caused and returning a
+      *    damage report to the opponent.  While this procedure is
+      *    running on this machine, the remote machine is running the
+      *    Local-Turn procedure.
+      *
+      *-----------------------------------------------------------------
+       Remote-Turn.
+           Perform Opponents-Turn
+           Perform Receive-Grid-Coords
+           Perform Assess-Own-Damage
+           Display Battle-Damage
+           Display Battle-Field
+           Perform Send-Own-Damage.
+
+
+       Get-Coords.
+           Move "YOUR TURN" to Screen-Msg-1
+           Display Battle-Turn
+           Move spaces to Grid-Coordinates
+           Accept Battle-Coords
+           If Not (Grid-1 = "Q" OR Grid-1 = "q")
+               Perform until (Grid-1 >="A" AND Grid-1 <= "M" AND
+                              Grid-2 >="1" AND Grid-2 <= "9")
+                   If Grid-1 >= 'a' AND Grid-1 <= 'z'
+      *                fold to upper case
+                       Subtract 32 from Grid-1-Asc
+                   Else
+                       Move "Invalid Coordinates" to Screen-Msg-4
+                       Display Battle-Msg
+                       Accept Battle-Coords
+                       Move spaces to Screen-Msg-4
+                       Display Battle-Msg
+                   End-If
+               End-Perform
+           End-if
+           Move "AWAITING REPORT" to Screen-Msg-1
+           Move spaces to Screen-Msg-2
+           Display Battle-Msg-1-2.
+
+       Opponents-Turn.
+           Move "OPPONENTS TURN" to Screen-Msg-1
+           Display Battle-Turn.
+
+       Assess-Opponent-Damage.
+           Perform Evaluate-Grid-Position
+           Evaluate Damage-Msg
+               When "MISS"  Perform Miss-Ship
+               When "HIT"   Perform Hit-Ship
+               When "SINK"  Perform Sink-Ship
+               When "WIN"   Perform Win-Battle
+           End-Evaluate.
+
+       Miss-Ship.
+           Move 3 to Grid-Att-Array(Grid-Row,Grid-Col)
+           Move "YOU MISSED" to Screen-Msg-2.
+       Hit-Ship.
+           Move 4 to Grid-Att-Array(Grid-Row,Grid-Col)
+           Move "YOU HIT SHIP" to Screen-Msg-2.
+       Sink-Ship.
+           Perform Display-Sunk-Ship
+           Move "YOU SUNK SHIP" to Screen-Msg-2.
+       Win-Battle.
+           Perform Display-Sunk-Ship
+           Move "YOU SUNK SHIPS" to Screen-Msg-2
+           Set Win-Game to True.
+
+       Display-Sunk-Ship.
+           Move Sink-Coords to Sunk-Ship-Locations
+           Perform varying Ship-Sector from 1 by 1 until Ship-Sector > 4
+               Move Sunk-Ship-Row of Sunk-Ship(Ship-Sector) to Temp-Row
+               Move Sunk-Ship-Col of Sunk-Ship(Ship-Sector) to Temp-Col
+               If Temp-Row not = 0 AND Temp-Col not = 0
+                   Move 0 to Grid-Att-Array(Temp-Row,Temp-Col)
+               End-If
+           End-Perform.
+
+       Assess-Own-Damage.
+           Perform Evaluate-Grid-Position
+           Move Grid-Array(Grid-Row,Grid-Col) to Target-Object
+           If Target-Object = space
+      *            a miss
+               Move "MISS" to Damage-Msg
+               Move "OPPONENT MISSED SHIP" to Screen-Msg-2
+           Else
+      *            a hit
+               Move "HIT" to Damage-Msg
+               Move "OPPONENT HIT SHIP" to Screen-Msg-2
+               Evaluate Target-Object
+                   When "B"
+                   When "A"
+                   When "F"
+                   When "G"
+                   When "*"   Perform Check-Ship-Sunk
+                   When other Move "MISS" to Damage-Msg
+                              Move "OPPONENT MISSED SHIP"
+                              to Screen-Msg-2
+               End-Evaluate
+           End-If.
+
+
+       Evaluate-Grid-Position.
+           Move Grid-1 to Grid-Chr
+           Subtract 64 from Grid-Asc
+           Move Grid-Asc to Grid-Col
+           Move Grid-2 to Grid-Chr
+           Subtract 48 from Grid-Asc
+           Move Grid-Asc to Grid-Row.
+
+       Check-Ship-Sunk.
+           Move Grid-Array(Grid-Row,Grid-Col) to Target-Object
+           Move "*" to Grid-Array(Grid-Row,Grid-Col)
+      *        assume sunk unless we can prove otherwise
+           Set Ship-Sunk to True
+           Move low-values to Sunk-Ship-Locations
+           Perform Check-Horizontal-Axis
+           If Ship-Sunk
+               Perform Check-Vertical-Axis
+               If Ship-Sunk
+                   Move "SINK" to Damage-Msg
+                   Move "OPPONENT SUNK SHIP" to Screen-Msg-2
+                   Perform varying Ship-Sector from 1 by 1
+                           until Ship-Sector > 4
+                       Move Sunk-Ship-Row of Sunk-Ship(Ship-Sector)
+                                   to Temp-Row
+                       Move Sunk-Ship-Col of Sunk-Ship(Ship-Sector)
+                                   to Temp-Col
+                       If Temp-Row not = 0 AND Temp-Col not = 0
+                           Move space to Grid-Array(Temp-Row,Temp-Col)
+                       End-If
+                   End-Perform
+                   Move Sunk-Ship-Locations to Sink-Coords
+                   Perform Check-All-Sunk
+               End-If
+           End-If.
+
+       Check-Horizontal-Axis.
+           Set Not-End-of-Ship to true
+      *        go to far left of ship
+           Move Grid-Col to Temp-Col
+           Perform until Temp-Col= 0 OR
+                  (Grid-Array(Grid-Row,Temp-Col) not = "*" AND
+                   Grid-Array(Grid-Row,Temp-Col) not = Target-Object)
+               Subtract 1 from Temp-Col
+           End-Perform
+           Add 1 to Temp-Col
+      *        start scanning right
+           Move 1 to Ship-Sector
+           Perform until End-Of-Ship or Ship-Not-Sunk
+               Evaluate Grid-Array(Grid-Row,Temp-Col)
+                   When Target-Object  Set Ship-Not-Sunk to True
+                   When "*"
+                       Move Temp-Col to Sunk-Ship-Col of
+                                                  Sunk-Ship(Ship-Sector)
+                       If Sunk-Ship-Row of Sunk-Ship(Ship-Sector) = zero
+                           Move Grid-Row to Sunk-Ship-Row of
+                                                  Sunk-Ship(Ship-Sector)
+                       End-If
+                   When other Set End-Of-Ship to true
+               End-Evaluate
+               Add 1 to Ship-Sector
+               If Temp-Col = Max-Col
+                   Set End-Of-Ship to true
+               End-If
+               Add 1 to Temp-Col
+           End-Perform.
+
+       Check-Vertical-Axis.
+           Set Not-End-of-Ship to true
+      *        go to top of ship
+           Move Grid-Row to Temp-Row
+           Perform until Temp-Row = 0 OR
+                  (Grid-Array(Temp-Row,Grid-Col) not = "*" AND
+                   Grid-Array(Temp-Row,Grid-Col) not = Target-Object)
+               Subtract 1 from Temp-Row
+           End-Perform
+           Add 1 to Temp-Row
+      *        start scanning down
+           Move 1 to Ship-Sector
+           Perform until End-Of-Ship or Ship-Not-Sunk
+               Evaluate Grid-Array(Temp-Row,Grid-Col)
+                   When Target-Object  Set Ship-Not-Sunk to True
+                   When "*"
+                       Move Temp-Row to Sunk-Ship-Row(Ship-Sector)
+                       If Sunk-Ship-Col(Ship-Sector) = zero
+                           Move Grid-Col to Sunk-Ship-Col(Ship-Sector)
+                       End-If
+                   When other Set End-Of-Ship to true
+               End-Evaluate
+               Add 1 to Ship-Sector
+               If Temp-Row = Max-Row
+                   Set End-Of-Ship to true
+               End-If
+               Add 1 to Temp-Row
+           End-Perform.
+
+       Check-All-Sunk.
+           If No-Ships-Left
+               Move "OPPONENT SUNK SHIPS" to Screen-Msg-2
+               Move "WIN " to Damage-Msg
+               Set Lose-Game to True
+           End-If.
+
+       Display-Game-Outcome.
+           If Win-Game
+               Move "YOU WIN!   G A M E   O V E R" to Screen-Msg-3
+           Else
+               Move "YOU LOSE!  G A M E   O V E R" to Screen-Msg-3
+           End-If
+           Display Battle-Over.
+
+       Game-Quit.
+           Move "         QUIT GAME          " to Screen-Msg-3
+           Display Battle-Over
+           Stop Run.
+
+       Get-keystroke.
+           Call x"83" using key-char
+           Call x"e4".
+
+
+      *-----------------------------------------------------------------
+      * Routines to communicate with opponent
+      *-----------------------------------------------------------------
+
+      *-----------------------------------------------------------------
+       Connect-Opponent.
+      *    This sets up a conversation with the opponent
+      *
+      *-----------------------------------------------------------------
+           Move Connect-Code to Battle-Op-Code
+           Move Player-Id to Battle-Buffer
+           Perform Communicate-Opponent.
+
+      *-----------------------------------------------------------------
+       Disconnect-Opponent.
+      *    This brings down a conversation with the opponent at the end
+      *    of a game
+      *
+      *-----------------------------------------------------------------
+           Move Disconnect-Code to Battle-Op-Code
+           Perform Communicate-Opponent.
+
+      *-----------------------------------------------------------------
+       Send-Own-Damage.
+      *    Send damage report to opponent - the damage is contained
+      *    in the call parameter Battle-Buffer it contains either:
+      *        "MISS" - indicating opponent missed
+      *        "HIT"  - indicating opponent hit part of a ship
+      *        "SINK" - indicating opponent hit and sunk a ship
+      *        "WIN"  - indicating opponent hit and sunk last remaining
+      *                 ship and has won the game
+      *    the coordinates for a sunk ship are also provided so that
+      *    the opponent can mark the position on their screen.
+      *
+      *    You may like to enhance the program so that more information
+      *    is sent regarding the type of ship that was sunk or hit -
+      *    this information could then be displayed on the opponent's
+      *    screen.
+      *
+      *-----------------------------------------------------------------
+           Move Send-Report-Code to Battle-Op-Code
+           If Ship-Sunk or Lose-Game
+               Move Damage-Msg to Battle-Buffer(1:4)
+               Move Sink-Coords to Battle-Buffer(5:8)
+           Else
+               Move Damage-Msg to Battle-Buffer
+           End-If
+           Perform Communicate-Opponent.
+
+      *-----------------------------------------------------------------
+       Receive-Opponent-Damage.
+      *    The damage report received is the same as that sent above.
+      *
+      *-----------------------------------------------------------------
+           Move Receive-Report-Code to Battle-Op-Code
+           Perform Communicate-Opponent
+           If Battle-Buffer(1:4) = "SINK" or Battle-Buffer(1:4) = "WIN "
+               Move Battle-Buffer(1:4) to Damage-Msg
+               Move Battle-Buffer(5:8) to Sink-Coords
+           Else
+               Move Battle-Buffer to Damage-Msg
+           End-If.
+
+      *-----------------------------------------------------------------
+       Send-Grid-Coords.
+      *    Send coordinates in Battle-Buffer to opponent
+      *
+      *-----------------------------------------------------------------
+           Move Send-Coords-Code to Battle-Op-Code
+           Move Grid-Coordinates to Battle-Buffer
+           Perform Communicate-Opponent
+           If Battle-Buffer(1:1) = "Q" or Battle-Buffer(1:1) = "q"
+               Perform Game-Quit
+           End-If.
+
+      *-----------------------------------------------------------------
+       Receive-Grid-Coords.
+      *    receive coordinates in Battle-Buffer from opponent
+      *
+      *-----------------------------------------------------------------
+           Move Receive-Coords-Code to Battle-Op-Code
+           Perform Communicate-Opponent
+           If Battle-Buffer(1:1) = "Q" or Battle-Buffer(1:1) = "q"
+               Perform Game-Quit
+           End-If.
+           Move Battle-Buffer to Grid-Coordinates.
+
+      *-----------------------------------------------------------------
+       Communicate-Opponent.
+      *    Call communications module.
+      *    The communications module is treated as a black box - this
+      *    program is not concerned with how the communication is
+      *    achieved - It only understands several high level
+      *    operations that can be called to talk between itself and the
+      *    remote program.  You could conceivably change the
+      *    communications module to use some other protocol - this
+      *    program should not have to change.
+      *
+      *-----------------------------------------------------------------
+           Call "BATTAPPC" using
+                                by value Battle-Op-Code
+                                by reference Battle-Buffer
+           If Return-Code > 0
+      *            Error handling here is very simple.
+      *            You may like to enhance this area by implementing
+      *            some sort of recovery routine
+               STOP RUN
+           End-If.

Microsoft COBOL v45/DEMO/APPCDEMO/BATTLE.SS

@@ -0,0 +1,357 @@
+      *******************************************************************
+      *                                                                 *
+      *                                                                 *
+      *                  (C) Micro Focus Ltd. 1990                      *
+      *                                                                 *
+      *                         BATTLE.SS                               *
+      *                                                                 *
+      *      COBOL Advanced Program to Program (APPC) Demonstration     *
+      *                                                                 *
+      *      Screen Section copy file                                   *
+      *      This code was produced by the Screens Utility and then     *
+      *      amended to use dynamic screen attributes                   *
+      *                                                                 *
+      *******************************************************************
+
+       01 Battle-Screen.
+         02 LINE 1 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT
+       VALUE "                                              ".
+         02 COL 47 BACKGROUND-COLOR 1 FOREGROUND-COLOR 3 HIGHLIGHT VALUE
+       "Micro Focus".
+         02 COL 58 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       "                       ".
+         02 LINE 2 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT
+       VALUE "                                       ".
+         02 COL 40 BACKGROUND-COLOR 1 FOREGROUND-COLOR 3 HIGHLIGHT VALUE
+       "B A T T L E    S H I P S".
+         02 COL 64 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       "                 ".
+         02 LINE 3 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT
+       VALUE "
+      -"                      ".
+         02 LINE 4 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT
+       VALUE "                          A   B   C   D   E   F   G   H
+      -"I   J   K   L   M     ".
+         02 LINE 5 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT
+       VALUE "                        ÉÍÍÍÑÍÍÍÑÍÍÍÑÍÍÍÑÍÍÍÑÍÍÍÑÍÍÍÑÍÍÍÑÍ
+      -"ÍÍÑÍÍÍÑÍÍÍÑÍÍÍÑÍÍÍ»   ".
+         02 LINE 6 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT
+       VALUE " ".
+         02 COL 22 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " 1 º ".
+         02 COL 28 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 32 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 36 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 40 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 44 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 48 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 52 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 56 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 60 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 64 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 68 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 72 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 76 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " º 1 ".
+         02 LINE 7 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT
+       VALUE "                        ÇÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄ
+      -"ÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄĶ   ".
+         02 LINE 8 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT
+       VALUE "                      2 º ".
+         02 COL 28 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 32 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 36 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 40 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 44 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 48 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 52 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 56 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 60 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 64 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 68 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 72 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 76 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " º 2 ".
+         02 LINE 9 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT
+       VALUE " Grid Coordinates:      ÇÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄ
+      -"ÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄĶ   ".
+         02 LINE 10 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 3
+       HIGHLIGHT VALUE " ".
+         02 COL 4 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       "                   3 º".
+         02 COL 26 BACKGROUND-COLOR 1 HIGHLIGHT VALUE " ".
+         02 COL 28 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 32 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 36 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 40 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 44 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 48 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 52 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 56 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 60 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 64 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 68 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 72 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 76 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " º 3 ".
+         02 LINE 11 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6
+       HIGHLIGHT VALUE "                        ÇÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄ
+      -"ÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄĶ   ".
+         02 LINE 12 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6
+       HIGHLIGHT VALUE " Damage Report:       4 º ".
+         02 COL 28 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 32 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 36 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 40 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 44 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 48 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 52 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 56 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 60 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 64 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 68 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 72 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 76 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " º 4 ".
+         02 LINE 13 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6
+       HIGHLIGHT VALUE " ".
+         02 COL 22 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       "   ÇÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄĶ   ".
+         02 LINE 14 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6
+       HIGHLIGHT VALUE "                      5 º ".
+         02 COL 28 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 32 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 36 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 40 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 44 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 48 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 52 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 56 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 60 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 64 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 68 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 72 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 76 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " º 5 ".
+         02 LINE 15 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6
+       HIGHLIGHT VALUE " key:                   ÇÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄ
+      -"ÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄĶ   ".
+         02 LINE 16 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6
+       HIGHLIGHT VALUE "  A Aircraft Carrier  6 º ".
+         02 COL 28 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 32 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 36 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 40 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 44 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 48 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 52 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 56 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 60 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 64 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 68 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 72 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 76 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " º 6 ".
+         02 LINE 17 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6
+       HIGHLIGHT VALUE "  B Battleship          ÇÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄ
+      -"ÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄĶ   ".
+         02 LINE 18 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6
+       HIGHLIGHT VALUE "  F Frigate           7 º ".
+         02 COL 28 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 32 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 36 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 40 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 44 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 48 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 52 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 56 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 60 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 64 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 68 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 72 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 76 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " º 7 ".
+         02 LINE 19 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6
+       HIGHLIGHT VALUE "  G Gun Boat            ÇÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄ
+      -"ÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄĶ   ".
+         02 LINE 20 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6
+       HIGHLIGHT VALUE "  * Damaged Ship      8 º ".
+         02 COL 28 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 32 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 36 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 40 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 44 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 48 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 52 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 56 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 60 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 64 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 68 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 72 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 76 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " º 8 ".
+         02 LINE 21 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6
+       HIGHLIGHT VALUE " ".
+         02 COL 2 BACKGROUND-COLOR 4 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       "  ".
+         02 COL 4 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " hit                 ÇÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄÄÅÄÄ
+      -"ÄÅÄÄÄÅÄÄĶ   ".
+
+         02 LINE 22 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6
+       HIGHLIGHT VALUE " ".
+         02 COL 2 BACKGROUND-COLOR 0 FOREGROUND-COLOR 0 HIGHLIGHT VALUE
+       "  ".
+         02 COL 4 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " sink              9 º ".
+         02 COL 28 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 32 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 36 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 40 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 44 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 48 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 52 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 56 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 60 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 64 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 68 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 72 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " ³ ".
+         02 COL 76 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " º 9 ".
+         02 LINE 23 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6
+       HIGHLIGHT VALUE " ".
+         02 COL 2 BACKGROUND-COLOR 3 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       "  ".
+         02 COL 4 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT VALUE
+       " miss                ÈÍÍÍÏÍÍÍÏÍÍÍÏÍÍÍÏÍÍÍÏÍÍÍÏÍÍÍÏÍÍÍÏÍÍÍÏÍÍÍÏÍÍ
+      -"ÍÏÍÍÍÏÍÍͼ   ".
+        02 LINE 24 COL 1 BACKGROUND-COLOR 1 FOREGROUND-COLOR 6 HIGHLIGHT
+       VALUE "                          A   B   C   D   E   F   G   H
+      -"I   J   K   L   M     ".
+         02 LINE 6 COL 27.
+         02 Battle-Field.
+          03 OCCURS 9.
+           04 OCCURS 13.
+            05 BACKGROUND-COLOR Grid-Att-Array
+            FOREGROUND-COLOR 6 HIGHLIGHT PIC X FROM Grid-Array.
+            05 COL + 4.
+           04 LINE + 2 COL - 52.
+         02 Battle-Coords LINE 10 COL 2 BACKGROUND-COLOR 1 HIGHLIGHT
+        PIC XX USING Grid-Coordinates.
+         02 Battle-Msg LINE 11 COL 2 BACKGROUND-COLOR 1 HIGHLIGHT
+        PIC X(20) USING Screen-Msg-4.
+         02 Battle-Msg-1-2.
+           03 Battle-Turn LINE 6 COL 2 BACKGROUND-COLOR 1 HIGHLIGHT
+       PIC X(20) FROM Screen-Msg-1.
+           03 Battle-Damage LINE 13 COL 2 BACKGROUND-COLOR 1 HIGHLIGHT
+        PIC X(20) FROM Screen-Msg-2.
+         02 Battle-Over LINE 25 COL 35 BACKGROUND-COLOR 0 BLINK
+        HIGHLIGHT PIC X(33) FROM Screen-Msg-3.

Microsoft COBOL v45/DEMO/APPCDEMO/BATTLE.WKS

@@ -0,0 +1,139 @@
+      *******************************************************************
+      *                                                                 *
+      *                                                                 *
+      *                  (C) Micro Focus Ltd. 1990                      *
+      *                                                                 *
+      *                         BATTLEL.WKS                             *
+      *                                                                 *
+      *      COBOL Advanced Program to Program (APPC) Demonstration     *
+      *                                                                 *
+      *      working-storage copy file                                  *
+      *                                                                 *
+      *******************************************************************
+
+      *-----------------------------------------------------------------
+      *    Grid-Table - contains locations of ships
+      *-----------------------------------------------------------------
+       01 Grid-Table redefines Battle-Grid.
+          03 filler                        Occurs 9.
+              05 Grid-Array                Pic X Occurs 13.
+
+      *-----------------------------------------------------------------
+      *    Grid-Att-Table - contains opponent damage locations as
+      *                     different attributes eg hit=red, miss=cyan
+      *-----------------------------------------------------------------
+       01 Grid-Att-Table.
+          03 filler                        Occurs 9.
+              05 Grid-Att-Array            Pic 9(2) Occurs 13.
+
+      *-----------------------------------------------------------------
+      *    Grid-Coordinates - coordinates in form eg. 'G9'
+      *-----------------------------------------------------------------
+       01 Grid-Coordinates.
+          03 Grid-1                        Pic X.
+          03 Grid-1-Asc redefines Grid-1   Pic 9(2) Comp-X.
+          03 Grid-2                        Pic X.
+
+      *-----------------------------------------------------------------
+      *    Grid-Asc - ascii value of Grid-Chr used for decoding
+      *               coordinate
+      *-----------------------------------------------------------------
+       01 Grid-Chr                         Pic X.
+       01 Grid-Asc redefines Grid-Chr      Pic 9(2) Comp-X.
+
+      *-----------------------------------------------------------------
+      *    Grid-Row,Grid-Col - decoded x and y offsets into Grid-Table
+      *-----------------------------------------------------------------
+       01 Grid-Pos.
+          03 Grid-Row                      Pic 9(2) Comp-X.
+          03 Grid-Col                      Pic 9(2) Comp-X.
+
+      *-----------------------------------------------------------------
+      *    Temp-Row,Temp-Col - temporary data used by various routines
+      *-----------------------------------------------------------------
+       01 Temp-Row                         Pic 9(2) Comp-X.
+       01 Temp-Col                         Pic 9(2) Comp-X.
+
+      *-----------------------------------------------------------------
+      *    Max-Row,Max-Col - upper limits of grid
+      *-----------------------------------------------------------------
+       01 Max-Row                          Pic 9(2) Comp-X Value 9.
+       01 Max-Col                          Pic 9(2) Comp-X Value 13.
+
+      *-----------------------------------------------------------------
+      *    Sunk-Ship-Locations - grid positions of a sunk ship to be
+      *                          provided to opponent
+      *-----------------------------------------------------------------
+       01 Sunk-Ship-Locations.
+          03 Sunk-Ship                     Occurs 4.
+             05 Sunk-Ship-Row              Pic 9(2) Comp-X.
+             05 Sunk-Ship-Col              Pic 9(2) Comp-X.
+      *-----------------------------------------------------------------
+      *    Ship-Sector - sub-division of a ship across several locations
+      *-----------------------------------------------------------------
+       01  Ship-Sector                     Pic 9(2) Comp-X.
+
+      *-----------------------------------------------------------------
+      *    Key-Char - contains a keyboard response character
+      *-----------------------------------------------------------------
+       01  Key-Char                        Pic X.
+
+      *-----------------------------------------------------------------
+      *    Damage-Msg - contains damage report to be sent/received
+      *                 to/from opponent eg 'HIT','MISS''SINK' etc.
+      *-----------------------------------------------------------------
+       01  Damage-Msg                       Pic X(4).
+
+      *-----------------------------------------------------------------
+      *    Sink-Coords - temporary store for holding sunk ship locations
+      *-----------------------------------------------------------------
+       01  Sink-Coords                      Pic X(8).
+
+      *-----------------------------------------------------------------
+      *    Target-Object - contains character found at grid location
+      *-----------------------------------------------------------------
+       01  Target-Object                    Pic X.
+
+      *-----------------------------------------------------------------
+      *    operation codes used to interface to communication module
+      *-----------------------------------------------------------------
+       78 Connect-Code                     Value 1.
+       78 Disconnect-Code                  Value 2.
+       78 Send-Coords-Code                 Value 3.
+       78 Receive-Coords-Code              Value 4.
+       78 Send-Report-Code                 Value 5.
+       78 Receive-Report-Code              Value 6.
+
+      *-----------------------------------------------------------------
+      *    Screen-Msgs - Different messages that may appear on screen
+      *-----------------------------------------------------------------
+       01  Screen-Msgs.
+           03 Screen-Msg-1                 Pic X(25).
+           03 Screen-Msg-2                 Pic X(20).
+           03 Screen-Msg-3                 Pic X(30).
+           03 Screen-Msg-4                 Pic X(20).
+
+
+      *-----------------------------------------------------------------
+      *    Flags - defines various conditions
+      *-----------------------------------------------------------------
+       01 Flags.
+          03 filler                        Pic 9(2) Comp Value 0.
+             88 Win-Game                   Value 1.
+             88 Lose-Game                  Value 2.
+             88 Game-Over                  Value 1,2.
+          03 filler                        Pic 9(2) Comp.
+             88 Ship-Not-Sunk              Value 0.
+             88 Ship-Sunk                  Value 1.
+          03 filler                        Pic 9(2) Comp Value 0.
+             88 End-Of-Ship                Value 1.
+             88 Not-End-Of-Ship            Value 0.
+
+
+      *-----------------------------------------------------------------
+      *    Battle-Buffer
+      *    Battle-Op-Code
+      *        - are call parameters to communications module
+      *-----------------------------------------------------------------
+       01  Battle-Buffer                   Pic x(12).
+       01  Battle-Op-Code                  Pic 9(2) Comp-X.

Microsoft COBOL v45/DEMO/APPCDEMO/BATTLEL.CBL

@@ -0,0 +1,88 @@
+      $set mf ans85 noosvs
+      *******************************************************************
+      *                                                                 *
+      *                                                                 *
+      *                  (C) Micro Focus Ltd. 1990                      *
+      *                                                                 *
+      *                         BATTLEL.CBL                             *
+      *                                                                 *
+      *      COBOL Advanced Program to Program (APPC) Demonstration     *
+      *                                                                 *
+      *                         Battleships                             *
+      *                          player  1                              *
+      *                                                                 *
+      *******************************************************************
+
+       WORKING-STORAGE SECTION.
+
+       01 Player-Id            Pic x(7) value 'PLAYER1'.
+
+      *-----------------------------------------------------------------
+      *    Battle-Grid defines the grid positions of different ships
+      *    on this side.  It is up to each player to specify these
+      *    positions and follow certain requirements of the game.
+      *
+      *    The requirements are:
+      *        - ships are identified by the following letters:
+      *                 A for Aircraft Carrier
+      *                 B for Battleship
+      *                 F for Frigate
+      *                 G for Gun Boat
+      *
+      *        - ships can be any length - it is up to the players to
+      *          decide how long each ship is
+      *
+      *        - ships must not be located in adjacent grid locations
+      *
+      *        - ships can only be aligned vertically or horizontally
+      *
+      *    There is no verification done on the setup you choose - so
+      *    it is quite possible to cheat.  You must also recompile this
+      *    program when you want to change the battle grid.
+      *
+      *    A possible enhancement which you may like to make yourself
+      *    would be to provide code which allows each player to define
+      *    his/her own grid details and validate the grid dynamically -
+      *    thus removing the need to recompile every time.
+      *
+      *-----------------------------------------------------------------
+
+       01 Battle-Grid.
+       88 No-Ships-Left        value spaces.
+          03 filler            pic x(13) value 'BBB          '.
+          03 filler            pic x(13) value '    AAAA     '.
+          03 filler            pic x(13) value '             '.
+          03 filler            pic x(13) value ' B  G   F    '.
+          03 filler            pic x(13) value ' B      F    '.
+          03 filler            pic x(13) value ' B          G'.
+          03 filler            pic x(13) value '    G        '.
+          03 filler            pic x(13) value '             '.
+          03 filler            pic x(13) value '          FF '.
+
+
+      *-----------------------------------------------------------------
+       COPY "BATTLE.WKS".
+      *    BATTLE.WKS is a copy file that contains common
+      *    working-storage section items for PLAYER1 and PLAYER2
+      *
+      *-----------------------------------------------------------------
+
+       SCREEN SECTION.
+      *-----------------------------------------------------------------
+       COPY "BATTLE.SS".
+      *    BATTLE.SS is a copy file containing a screen section for
+      *    displaying the battle field.  The screen section was designed
+      *    using the SCREENS utility.
+      *
+      *-----------------------------------------------------------------
+
+       PROCEDURE DIVISION.
+      *-----------------------------------------------------------------
+       COPY "BATTLE.CPY".
+      *    BATTLE.CPY is a copy file containing the common procedure
+      *    division code for both players
+      *
+      *-----------------------------------------------------------------
+
+
+

Microsoft COBOL v45/DEMO/APPCDEMO/BATTLER.CBL

@@ -0,0 +1,84 @@
+      $set mf ans85 noosvs
+      *******************************************************************
+      *                                                                 *
+      *                                                                 *
+      *                  (C) Micro Focus Ltd. 1990                      *
+      *                                                                 *
+      *                         BATTLER.CBL                             *
+      *                                                                 *
+      *      COBOL Advanced Program to Program (APPC) Demonstration     *
+      *                                                                 *
+      *                         Battleships                             *
+      *                          player  2                              *
+      *                                                                 *
+      *******************************************************************
+
+       WORKING-STORAGE SECTION.
+
+       01 Player-Id            pic x(7) value 'PLAYER2'.
+      *-----------------------------------------------------------------
+      *    Battle-Grid defines the grid positions of different ships
+      *    on this side.  It is up to each player to specify these
+      *    positions and follow certain requirements of the game.
+      *
+      *    The requirements are:
+      *        - ships are identified by the following letters:
+      *                 A for Aircraft Carrier
+      *                 B for Battleship
+      *                 F for Frigate
+      *                 G for Gun Boat
+      *
+      *        - ships can be any length - it is up to the players to
+      *          decide how long each ship is
+      *
+      *        - ships must not be located in adjacent grid locations
+      *
+      *        - ships can only be aligned vertically or horizontally
+      *
+      *    There is no verification done on the setup you choose - so
+      *    it is quite possible to cheat.  You must also recompile this
+      *    program when you want to change the battle grid.
+      *
+      *    A possible enhancement which you may like to make yourself
+      *    would be to provide code which allows each player to define
+      *    his/her own grid details and validate the grid dynamically -
+      *    thus removing the need to recompile every time.
+      *
+      *-----------------------------------------------------------------
+
+       01 Battle-Grid.
+       88 No-Ships-Left        value spaces.
+          03 filler            pic x(13) value 'G            '.
+          03 filler            pic x(13) value '  FF     BBB '.
+          03 filler            pic x(13) value '             '.
+          03 filler            pic x(13) value ' A      G    '.
+          03 filler            pic x(13) value ' A           '.
+          03 filler            pic x(13) value ' A           '.
+          03 filler            pic x(13) value ' A  G     F  '.
+          03 filler            pic x(13) value '          F  '.
+          03 filler            pic x(13) value '   BBB       '.
+
+      *-----------------------------------------------------------------
+       COPY "BATTLE.WKS".
+      *    BATTLE.WKS is a copy file that contains common
+      *    working-storage section items for PLAYER1 and PLAYER2
+      *
+      *-----------------------------------------------------------------
+
+       SCREEN SECTION.
+      *-----------------------------------------------------------------
+       COPY "BATTLE.SS".
+      *    BATTLE.SS is a copy file containing a screen section for
+      *    displaying the battle field.  The screen section was designed
+      *    using the SCREENS utility.
+      *
+      *-----------------------------------------------------------------
+
+       PROCEDURE DIVISION.
+      *-----------------------------------------------------------------
+       COPY "BATTLE.CPY".
+      *    BATTLE.CPY is a copy file containing the common procedure
+      *    division code for both players
+      *
+      *-----------------------------------------------------------------
+

Microsoft COBOL v45/DEMO/ASMDEMO/ADD.CBL

@@ -0,0 +1,51 @@
+      $set mf ans85 noosvs
+      *******************************************************************
+      *                                                                 *
+      *                                                                 *
+      *                  (C) Micro Focus Ltd. 1989                      *
+      *                                                                 *
+      *                            ADD.CBL                              *
+      *                                                                 *
+      * This program shows how to call the assembler routine ADDEM.ASM. *
+      * It can be called dynamically as a .EXE or .DLL file, or         *
+      * statically linked.                                              *
+      *                                                                 *
+      * To statically link you must compile this program with the       *
+      * LITLINK directive (or change the call below to call "__addem"). *
+      *                                                                 *
+      * To dynamically link, compile the program as it is without the   *
+      * LITLINK directive. On OS/2 you must create a .DLL from          *
+      * ADDEM.OBJ using the .DEF file supplied, and place the .DLL file *
+      * in a directory on your LIBPATH.                                 *
+      *                                                                 *
+      * The assembler routine gets the value of the first parameter,    *
+      * adds it to the value of second-param and returns the result     *
+      * in res-ult.                                                     *
+      *                                                                 *
+      *******************************************************************
+
+       working-storage section.
+       01 comp-fields.
+           03 first-param      pic 99 comp value 3.
+           03 second-param     pic 99 comp value 5.
+           03 res-ult          pic 99 comp.
+
+       01 display-first-param  pic Z9.
+       01 display-second-param pic Z9.
+       01 display-res-ult      pic Z9.
+
+       procedure division.
+
+      * call to assembler routine
+           call "addem" using first-param, second-param, res-ult.
+
+      *set up display fields
+           move first-param  to display-first-param.
+           move second-param to display-second-param.
+           move res-ult      to display-res-ult.
+
+      * display results of the call
+           display display-first-param " + "
+                   display-second-param " = "
+                   display-res-ult.
+       stop run.

Microsoft COBOL v45/DEMO/ASMDEMO/ADDEM.ASM

@@ -0,0 +1,59 @@
+;
+;                   (C) Micro Focus Ltd, 1989
+;
+;	This routine is called by the cobol program ADD.CBL
+;	To assemble and link the routine to a .EXE file simply type:
+;
+;			MASM ADDEM;
+;			LINK ADDEM;
+;
+public 	addem			;module id
+
+cseg 	segment para public 'CODE'
+assume 	cs:cseg
+
+first_param  equ dword ptr [bp+6]       ;pointer to first parameter
+second_param equ dword ptr [bp+10]      ;pointer to second parameter
+res_ult      equ dword ptr [bp+14]      ;pointer to third parameter
+
+addem proc far
+ 	push 	bp     		;preserve bp
+	mov 	bp,sp  		;put current stack pointer in bp
+ 	push 	ds     		;preserve ds,si,di,flags
+ 	push 	si
+ 	push 	di
+ 	pushf
+
+	mov 	ax,dseg		;initialize ds
+	mov 	ds,ax
+
+	;      THE NEXT 6 STATEMENTS ARE THE VARIABLE PART
+	;      OF THIS ROUTINE.  MOST EVERYTHING ELSE IS NEEDED
+	;      FOR EVERY ASSEMBLER ROUTINE CALLED BY COBOL.
+	les  	di,first_param	;get address of first parameter
+	mov 	al,es:[di]	;get value of first parameter
+	les 	di,second_param	;get address of second parameter
+	add 	al,es:[di]	;add value of 2nd param to first
+
+	les 	di,res_ult	;get address of res_ult
+	stosb			;return result to cobol program
+
+	xor	ax,ax		;set return code, 0 in ax = success
+
+ 	popf			;restore registers
+ 	pop di
+ 	pop si
+ 	pop ds
+ 	pop bp
+
+	ret			;far return
+addem	endp
+cseg	ends
+
+dseg 	segment para public 'DATA'
+	your_data	db	'data'
+	;	INCLUDE YOUR DATA HERE
+dseg 	ends
+
+end
+

Microsoft COBOL v45/DEMO/ASMDEMO/ADDEM.DEF

@@ -0,0 +1,4 @@
+; module definition file for ADDEM under OS/2
+LIBRARY INITINSTANCE    ; ADIS is a DLL
+CODE LOADONCALL         ; load when needed
+EXPORTS ADDEM @1        ; entry is ADDEM

Microsoft COBOL v45/DEMO/CALC.CBL

@@ -0,0 +1,175 @@
+      $SET WARNING(3) NOOSVS ANS85 mf
+       SPECIAL-NAMES.
+           crt status is key-status.
+       WORKING-STORAGE SECTION.
+       78  Return-key                      value X"3030".
+       78  Equals-key                      value X"333D".
+       01  key-status.
+           03  key-type                    pic x.
+               88  function-key            value "1".
+               88  data-key                value "3".
+           03  key-code-1                  pic 99  comp-x.
+           03  key-code-1-x redefines
+               key-code-1                  pic x.
+               88  Operator-entered        value "*" "-" "/" "+".
+               88  CLear-key               value "C" "c".
+           03  key-code-2                  pic x.
+       01  redefines key-status.
+           03                              pic xx.
+               88  escape-key-pressed      value X"3100".
+      * Answer needed "=" or <CR>
+               88  answer-needed           value Return-key Equals-key.
+           03                              pic x.
+       01  set-bit-pairs                   pic 99  comp-x  value 1.
+       01  data-key-control.
+           03  data-key-setting            pic 99  comp-x.
+               88  key-is-disabled                         value zero.
+               88  act-as-a-function-key   value 1.
+               88  character-into-field    value 2.
+           03                              pic x  value "3".
+           03  first-data-key              pic x.
+           03  number-of-data-keys         pic 99  comp-x  value 1.
+       01  user-key-control.
+           03  User-key-setting            pic 99  comp-x  value 1.
+           03                              pic x           value "1".
+           03  first-user-key              pic 99  comp-x  value 0.
+           03  number-of-keys              pic 99  comp-x  value 1.
+       78  No-of-data-keys                 value 7.
+       01  keys-to-enable                  pic x(no-of-data-keys)
+           value "/*-+Cc=".
+       01  redefines keys-to-enable.
+           03  key-to-enable occurs no-of-data-keys times
+               indexed by key-enable-index pic x.
+       01  Entered-Value                   PIC S9(11)V9(7) BINARY.
+       01  Saved-Value                     PIC S9(11)V9(7) BINARY.
+       01  saved-operator                  pic x.
+       01  is-there-a-key-waiting          pic x   comp-x.
+           88  no-key-waiting              value zero.
+           88  key-waiting                 value 1 thru 255.
+       01                                  pic 99  comp-x.
+           88  calculation-ok              value zero.
+           88  numeric-overflow            value 1.
+       SCREEN SECTION.
+       01  Calculator-screen.
+           05  BLANK SCREEN.
+           05  LINE 1  COL 1 VALUE "ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»".
+           05  LINE 2  COL 1 VALUE "º ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ» º".
+           05  LINE 3  COL 1 VALUE "º º                      º º".
+           05  LINE 4  COL 1 VALUE "º ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ º".
+           05  LINE 5  COL 1 VALUE "º   ÚÄÄÄ¿ÚÄÄÄ¿ÚÄÄÄ¿ÚÄÄÄ¿   º".
+           05  LINE 6  COL 1 VALUE "º   ³   ³³   ³³   ³³   ³   º".
+           05  LINE 7  COL 1 VALUE "º   ÀÄÄÄÙÀÄÄÄÙÀÄÄÄÙÀÄÄÄÙ   º".
+           05  LINE 8  COL 1 VALUE "º   ÚÄÄÄ¿ÚÄÄÄ¿ÚÄÄÄ¿ÚÄÄÄ¿   º".
+           05  LINE 9  COL 1 VALUE "º   ³   ³³   ³³   ³³   ³   º".
+           05  LINE 10 COL 1 VALUE "º   ÀÄÄÄÙÀÄÄÄÙÀÄÄÄÙ³   ³   º".
+           05  LINE 11 COL 1 VALUE "º   ÚÄÄÄ¿ÚÄÄÄ¿ÚÄÄÄ¿³   ³   º".
+           05  LINE 12 COL 1 VALUE "º   ³   ³³   ³³   ³³   ³   º".
+           05  LINE 13 COL 1 VALUE "º   ÀÄÄÄÙÀÄÄÄÙÀÄÄÄÙÀÄÄÄÙ   º".
+           05  LINE 14 COL 1 VALUE "º   ÚÄÄÄ¿ÚÄÄÄ¿ÚÄÄÄ¿ÚÄÄÄ¿   º".
+           05  LINE 15 COL 1 VALUE "º   ³   ³³   ³³   ³³   ³   º".
+           05  LINE 16 COL 1 VALUE "º   ÀÄÄÄÙÀÄÄÄÙÀÄÄÄÙ³   ³   º".
+           05  LINE 17 COL 1 VALUE "º   ÚÄÄÄÄÄÄÄÄ¿ÚÄÄÄ¿³   ³   º".
+           05  LINE 18 COL 1 VALUE "º   ³        ³³   ³³   ³   º".
+           05  LINE 19 COL 1 VALUE "º   ÀÄÄÄÄÄÄÄÄÙÀÄÄÄÙÀÄÄÄÙ   º".
+           05  LINE 20 COL 1 VALUE "ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ".
+           05 HIGHLIGHT.
+               10  entry-field.
+                   15  LINE 3  COL 5 PIC -(11)9.9(7)
+                       USING Entered-Value PROMPT spaces.
+               10 LINE 6  COL 7  VALUE "C".
+               10         COL 12 VALUE "/".
+               10         COL 17 VALUE "*".
+               10         COL 22 VALUE "-".
+               10 LINE 9  COL 7  VALUE "7".
+               10         COL 12 VALUE "8".
+               10         COL 17 VALUE "9".
+               10 LINE 10 COL 22 VALUE "+".
+               10 LINE 12 COL 7  VALUE "4".
+               10         COL 12 VALUE "8".
+               10         COL 17 VALUE "6".
+               10 LINE 15 COL 7  VALUE "1".
+               10         COL 12 VALUE "2".
+               10         COL 17 VALUE "3".
+               10 LINE 16 COL 22 VALUE "=".
+               10 LINE 18 COL 9  VALUE "0".
+               10         COL 17 VALUE ".".
+       PROCEDURE DIVISION.
+       main-1.
+           perform initialization-routines
+           DISPLAY Calculator-screen
+           perform with test after until escape-key-pressed
+               if operator-entered or numeric-overflow
+      *    Position the cursor at the first integer position of the
+      *    entry field which waiting for a character to be pressed
+                   if numeric-overflow
+                       display low-values at 0321
+                   else
+                       display low-values at 0316
+                   end-if
+      *    Leave the previous value in th field until a value is
+      *    entered
+                   set no-key-waiting to true
+                   perform with test after until key-waiting
+                       call X"D9" using is-there-a-key-waiting
+                   end-perform
+                   move zero to entered-value
+               end-if
+               display Entry-field
+               ACCEPT Calculator-screen
+               if data-key or answer-needed
+                   perform data-key-terminated-accept
+               end-if
+           end-perform
+           exit program
+           STOP RUN.
+       data-key-terminated-accept.
+           evaluate true
+               when Operator-entered
+                   if saved-operator not = spaces
+                       perform calculate-answer
+      *    Display current intermediate result  whilst waiting for next
+      *    keystoke which will require the field to be cleared
+                       display Entry-field
+                   end-if
+                   move key-code-1-x to saved-operator
+                   move entered-value to saved-value
+               when CLear-key
+                   move zero to entered-value saved-value
+                   move spaces to saved-operator
+               when answer-needed
+                   perform calculate-answer
+                   move spaces to saved-operator
+           end-evaluate.
+       calculate-answer.
+           set calculation-ok to true
+           evaluate saved-operator
+               when "*"
+                   compute entered-value = saved-value * entered-value
+                       on size error perform size-error-action
+               when "-"
+                   compute entered-value = saved-value - entered-value
+                       on size error perform size-error-action
+               when "+"
+                   compute entered-value = saved-value + entered-value
+                       on size error perform size-error-action
+               when "/"
+                   compute entered-value = saved-value / entered-value
+                       on size error perform size-error-action
+           end-evaluate.
+       size-error-action.
+           move zero to entered-value saved-value
+           move spaces to saved-operator
+           display "Numeric Overflow    " at 0305 with highlight
+           set numeric-overflow to true.
+       initialization-routines.
+      *    activate "*" "/" "-" "+" "C" "c" and "="
+      *    to terminate an accept.
+           set act-as-a-function-key to true
+           perform varying key-enable-index from 1 by 1
+                   until key-enable-index > No-of-data-keys
+               move key-to-enable(key-enable-index) to first-data-key
+               call X"AF" using set-bit-pairs data-key-control
+           end-perform
+           move zero to entered-value saved-value
+      *    Enable function key zero - The Escape key.
+           call X"AF" using set-bit-pairs user-key-control.

Microsoft COBOL v45/DEMO/CALENDAR.CBL

@@ -0,0 +1,158 @@
+      $SET ans85 noosvs noqual noalter nobell warning(3) noseg align(1)
+       WORKING-STORAGE SECTION.
+       01  wrk-date.
+           03  yymmdd-yy                   PIC 99.
+           03  yymmdd-mm                   PIC 99.
+           03  yymmdd-dd                   PIC 99.
+       01  date-year                       PIC 99  COMP-X.
+       01  date-lyear                      PIC 99  COMP-X.
+           88  leap-year                   VALUE 1.
+       01  am-pm-fld                       PIC XX.
+       01  hh-fld                          PIC 99.
+       01  month-values.
+           03  FILLER                      PIC X(9)  VALUE " JANUARY ".
+           03  FILLER                      PIC X(9)  VALUE " FEBUARY ".
+           03  FILLER                      PIC X(9)  VALUE "  MARCH  ".
+           03  FILLER                      PIC X(9)  VALUE "  APRIL  ".
+           03  FILLER                      PIC X(9)  VALUE "   MAY   ".
+           03  FILLER                      PIC X(9)  VALUE "  JUNE   ".
+           03  FILLER                      PIC X(9)  VALUE "  JULY   ".
+           03  FILLER                      PIC X(9)  VALUE " AUGUST  ".
+           03  FILLER                      PIC X(9)  VALUE "SEPTEMBER".
+           03  FILLER                      PIC X(9)  VALUE " OCTOBER ".
+           03  FILLER                      PIC X(9)  VALUE "NOVEMBER ".
+           03  FILLER                      PIC X(9)  VALUE "DECEMBER ".
+       01  month-value REDEFINES month-values OCCURS 12 PIC X(9).
+       01  no-of-days-in-month-table       PIC X(24)
+           VALUE "312831303130313130313031".
+       01  no-of-days-in-month REDEFINES
+           no-of-days-in-month-table
+           OCCURS 12                       PIC 99.
+       01  day-flds.
+           03  OCCURS 5.
+               05  OCCURS 7.
+                   07  scr-day-fld         PIC 99      COMP-X.
+           03  day-36                      PIC 99      COMP-X.
+           03  day-37                      PIC 99      COMP-X.
+       01  FILLER REDEFINES day-flds.
+           03  day-fld OCCURS 37           PIC 99      COMP-X.
+       01  hi-flds.
+           03  OCCURS 5.
+               05  OCCURS 7.
+                   07  scr-hi-fld          PIC X(80).
+           03  hi-36                       PIC X(80).
+           03  hi-37                       PIC X(80).
+       01  FILLER REDEFINES hi-flds.
+           03  hi-fld OCCURS 37           PIC X(80).
+               88  highlight-fld          VALUE "HIGHLIGHT".
+       01  day-of-year-group.
+           03  FILLER                      PIC XX.
+           03  day-of-year                 PIC 999.
+       01  day-of-week-fld                 PIC 99.
+       01  time-fld.
+           03  time-fld-hh                 PIC 99.
+           03  time-fld-mm                 PIC 99.
+           03  FILLER                      PIC X(4).
+       01  day-index                       PIC 99      COMP-X.
+       01  count-fld                       PIC 99      COMP-X.
+       01  century-fld                     PIC 99      COMP-X.
+       01  non-full-week-days              PIC 99      COMP-X.
+       01  day-of-month-day-1              PIC 99      COMP-X.
+       01  no-of-full-weeks-in-month       PIC 99      COMP-X.
+       01  current-day-scr-fld-index       PIC 99      COMP-X.
+      /
+       Screen SECTION.
+       01  calender-screen.
+           03  BLANK screen.
+           03  LINE 3 COL 64 PIC Z9 FROM hh-fld.
+           03         COL 67 PIC 99 FROM time-fld-mm.
+           03         COL 70 PIC XX FROM am-pm-fld.
+           03  LINE 5 COL 53 PIC 99 FROM century-fld.
+           03         COL 55 PIC 99 FROM yymmdd-yy.
+           03         COL 60 PIC X(9) FROM month-value(yymmdd-mm).
+           03         COL 72 PIC 99 FROM century-fld.
+           03         COL 74 PIC 99 FROM yymmdd-yy.
+           03  LINE 7 COL 51.
+           03  OCCURS 5.
+               05  OCCURS 7.
+                   07  PIC ZZ FROM scr-day-fld BLANK WHEN ZERO
+                           CONTROL IS scr-hi-fld.
+                   07  COL + 3.
+               05  LINE + 1 COL - 28.
+           03  LINE 12.
+           03  COL 51 PIC ZZ FROM day-fld(36) BLANK WHEN ZERO
+               CONTROL IS hi-fld(36).
+           03  COL 55 PIC ZZ FROM day-fld(37) BLANK WHEN ZERO
+               CONTROL IS hi-fld(37).
+           03  COL 74 PIC 999 FROM day-of-year.
+           03  LINE 3 COL 57 VALUE "Time:".
+           03  LINE 3 COL 66 VALUE ":".
+           03  LINE 6 COL 52 VALUE "S   M   T   W   T   F   S".
+           03  LINE 12 COL 61 VALUE "Day of Year:".
+      /
+       PROCEDURE DIVISION.
+       Calender-Main SECTION.
+           PERFORM Init-Date-Manipulation.
+           DISPLAY calender-screen.
+       Program-Exit.
+           EXIT PROGRAM.
+           STOP RUN.
+       Init-Date-Manipulation.
+           INITIALIZE day-flds hi-flds
+           ACCEPT wrk-date             FROM DATE
+           ACCEPT time-fld             FROM TIME
+           ACCEPT day-of-week-fld      FROM DAY-OF-WEEK
+           ACCEPT day-of-year-group    FROM DAY
+           PERFORM Find-Day-1-Of-Month
+           PERFORM Set-Time
+           PERFORM Set-Century
+           PERFORM Set-Day-Flds.
+      /
+       Find-Day-1-Of-Month.
+           DIVIDE yymmdd-dd BY 7 GIVING no-of-full-weeks-in-month
+                  REMAINDER non-full-week-days
+           IF day-of-week-fld < (non-full-week-days - 1)
+               ADD 7 TO day-of-week-fld
+           END-IF
+           COMPUTE day-of-month-day-1 = day-of-week-fld -
+                                        (non-full-week-days - 2)
+           IF day-of-month-day-1 > 7
+               SUBTRACT 7 FROM day-of-month-day-1
+           END-IF.
+       Set-Time.
+           IF time-fld-hh > 12
+               SUBTRACT 12 FROM time-fld-hh GIVING hh-fld
+               MOVE "PM" TO am-pm-fld
+           ELSE
+               MOVE "AM" TO am-pm-fld
+               MOVE time-fld-hh TO hh-fld
+           END-IF.
+       Set-Century.
+           IF yymmdd-yy < 88
+               MOVE "20" TO century-fld
+           ELSE
+               MOVE "19" TO century-fld
+           END-IF.
+       Set-Day-Flds.
+           MOVE ZERO TO count-fld
+           IF yymmdd-mm = 2
+               COMPUTE date-lyear = yymmdd-yy / 4
+               COMPUTE date-lyear = date-lyear * 4
+               COMPUTE date-year = date-lyear - yymmdd-yy
+               COMPUTE date-year = date-year / 4
+               IF leap-year
+                   ADD 1 to no-of-days-in-month(yymmdd-mm)
+               END-IF
+           END-IF
+           PERFORM VARYING DAY-INDEX FROM 1 BY 1 UNTIL DAY-INDEX > 37
+               IF day-index >= day-of-month-day-1 and
+                  < (day-of-month-day-1 +
+                    no-of-days-in-month(yymmdd-mm))
+                   ADD 1 TO count-fld
+                   MOVE count-fld TO day-fld(day-index)
+               ELSE
+                   MOVE ZERO TO day-fld(day-index)
+           END-PERFORM
+           COMPUTE yymmdd-dd = yymmdd-dd + day-of-month-day-1 - 1
+           SET highlight-fld(yymmdd-dd) TO TRUE.
+

Microsoft COBOL v45/DEMO/DECLARE.CBL

@@ -0,0 +1,55 @@
+      $set ans85 mf noosvs
+      ************************************************************
+      *                                                          *
+      *              (C) Micro Focus Ltd. 1989                   *
+      *                                                          *
+      *                     DECLARE.CBL                          *
+      *                                                          *
+      *    This program demonstrates how to use declaratives.    *
+      *                                                          *
+      ************************************************************
+
+       select input-file   assign to file-name
+                           organization sequential
+                           file status is file-stat.
+
+       data division.
+       file section.
+
+       fd  input-file.
+       01  input-rec       pic x(80).
+
+       working-storage section.
+       01  file-stat.
+           03  f-stat-1    pic x.
+           03  f-stat-2    pic x.
+           03  f-stat-2-bin redefines f-stat-2
+                           pic 9(2) comp-x.
+       01  stat-disp.
+           03  disp1       pic x.
+           03  filler      pic x.
+           03  disp2       pic 9(3).
+
+       procedure division.
+       declaratives.
+       dec-laratives section.
+       use after standard error procedure on input-file.
+           move f-stat-1 to disp1
+           if f-stat-1 = "9"
+               move f-stat-2-bin to disp2
+           else
+               move f-stat-2 to disp2
+           end-if
+           display "file status :" at 1029
+           display stat-disp       at 1049
+           stop run.
+       end declaratives.
+
+       main section.
+       sta-rt.
+           display spaces upon crt
+           display "enter a non-existant file name :" at 0810
+           accept file-name at 0849
+           open input input-file
+           display "Open worked. Try a different filename."
+           stop run.

Microsoft COBOL v45/DEMO/DIOPHANT.CBL

@@ -0,0 +1,143 @@
+      $set ans85 noosvs mf
+
+        PROGRAM-ID. DIOPHANT.
+      ******************************************************************
+      *
+      *              (C) Micro Focus Ltd. 1989
+      *
+      *                     DIOPHANT.CBL
+      *
+      * DIOPHANTINE - solve linear equation Ax + By = C
+      *                 for integers x and y.
+      *
+      * Method:
+      *         if A > B
+      *             swap A and B
+      *         fi
+      *
+      *         when A = 0
+      *             set x = 0, y = C/B as solution, and fail if non-integer
+      *         when A = 1
+      *             set x = C, y = 0 as solution
+      *         otherwise
+      *             let D = largest integer < (B/A)
+      *             let E = largets integer < (C/A)
+      *             let F = B - A*D
+      *             let G = C - A*E
+      *             then Ax + By = C becomes
+      *                 Ax + (F + A*D)y = (G + A*E)
+      *             so   x + (F/A + D)y = (G/A + E)
+      *             and (F/A)y + v = G/A   (since everything else is integral)
+      *             so solve
+      *                 Fy + Av = G for integers y and v
+      *
+      *             in COBOL terms:
+      *
+      *             divide B by A giving D remainder F
+      *             divide C by A giving E remainder G
+      *             solve Av + Fw = G for integers v and w
+      *             set x = E - Dw + v, y = w as solution
+      *
+      *         if swapped
+      *             swap x and y
+      *         fi
+      *
+      *
+      ******************************************************************
+        WORKING-STORAGE SECTION.
+        01  InitA   PIC s9(9) comp-5.
+        01  InitB   PIC s9(9) comp-5.
+        01  InitC   PIC s9(9) comp-5.
+        01  SolvX   PIC s9(9) comp-5.
+        01  SolvY   PIC s9(9) comp-5.
+        01  FailFg  PIC X.
+            88      OK  VALUE 'Y'.
+            88      BAD VALUE 'N'.
+            88      TRY VALUE '?'.
+        LOCAL-STORAGE SECTION.
+        01  D       PIC s9(9) comp-5.
+        01  E       PIC s9(9) comp-5.
+        01  F       PIC s9(9) comp-5.
+        01  G       PIC s9(9) comp-5.
+        01  V       PIC s9(9) comp-5.
+        01  TEMP    PIC s9(9) comp-5.
+        LINKAGE SECTION.
+        01  A       PIC s9(9) comp-5.
+        01  B       PIC s9(9) comp-5.
+        01  C       PIC s9(9) comp-5.
+        01  X       PIC s9(9) comp-5.
+        01  Y       PIC s9(9) comp-5.
+        PROCEDURE DIVISION.
+        MAIN SECTION.
+            DISPLAY "Solve Ax + By = C for integers x and y"
+            DISPLAY "Enter value for A: " with no advancing
+            ACCEPT InitA
+            DISPLAY "Enter value for B: " with no advancing
+            ACCEPT InitB
+            DISPLAY "Enter value for C: " with no advancing
+            ACCEPT InitC
+            SET TRY TO TRUE
+            CALL 'SOLVE' USING BY VALUE InitA InitB InitC
+                               BY REFERENCE SolvX SolvY
+
+            IF OK
+                DISPLAY "Solution is: x = " SolvX ", y = " SolvY
+            ELSE
+                DISPLAY "No Solution exists."
+            END-IF
+            STOP RUN.
+
+        SOLVE-DIOPHANTINE SECTION.
+        ENTRY 'SOLVE' USING BY VALUE A B C BY REFERENCE X Y.
+
+            IF A > B
+      *     Use TEMP as a flag to indicate swapped or not.
+                MOVE 1 TO TEMP
+                CALL 'SWAP2' USING A B
+            ELSE
+                MOVE 0 TO TEMP
+            END-IF
+
+            EVALUATE A
+                WHEN 0
+                    DIVIDE C BY B GIVING D REMAINDER E
+                    IF E = 0
+                        MOVE 0 TO X
+                        MOVE D TO Y
+                        SET OK TO TRUE
+                    ELSE
+      *     No solution exists.
+                        SET BAD TO TRUE
+                        MOVE 0 TO X, Y
+                    END-IF
+
+                WHEN 1
+                    MOVE C TO X
+                    MOVE 0 TO Y
+                    SET OK TO TRUE
+
+                WHEN OTHER
+      *     We must delve deeper to find a solution.
+                    DIVIDE B BY A GIVING D REMAINDER F
+                    DIVIDE C BY A GIVING E REMAINDER G
+
+                    CALL 'SOLVE' USING BY VALUE A F G BY REFERENCE v Y
+
+                    COMPUTE X = E - ( D * Y ) + v
+
+            END-EVALUATE
+
+            IF TEMP = 1
+                CALL 'SWAP2' USING X Y
+            END-IF
+
+            EXIT PROGRAM.
+
+
+      * Second level program to swap 2 variables using local temp variable.
+        SWAPPER SECTION.
+        ENTRY 'SWAP2' USING X Y.
+            MOVE X    TO TEMP
+            MOVE Y    TO X
+            MOVE TEMP TO Y
+            EXIT PROGRAM.

Microsoft COBOL v45/DEMO/EXPAND.CBL

@@ -0,0 +1,41 @@
+      $set ans85 mf noosvs
+      ************************************************************
+      *                                                          *
+      *              (C) Micro Focus Ltd. 1989                   *
+      *                                                          *
+      *                     EXPAND.CBL                           *
+      *                                                          *
+      *    This program demonstrates a special expanding accept. *
+      *    It uses the SIZE IS clause of the SCREEN SECTION to   *
+      *    dynamically alter the size of the data item being     *
+      *    accepted.                                             *
+      *                                                          *
+      *    The program repeats the same ACCEPT twenty times      *
+      *    each time increasing the size of the data item by 1.  *
+      *                                                          *
+      ************************************************************
+       special-names.
+           cursor is cursor-pos.
+       working-storage section.
+       01 buffer pic x(20).
+       01 buf-size pic 99.
+       01 cursor-pos.
+          02 line-p pic 99.
+          02 col-p  pic 99.
+       screen section.
+       01 screen-1.
+         02  value "Expanding accept (" line 1 column 1.
+         02  pic x(20) using buffer SIZE IS buf-size line 1 column + 1
+              auto.
+         02  value ")" line 1 column + 1.
+       procedure division.
+       main-para.
+            display space upon crt.
+            move 1 to buf-size, line-p, col-p.
+            perform with test after until buf-size = 20
+                display screen-1
+                accept  screen-1
+                add 1 to buf-size, col-p
+            end-perform.
+            stop run.
+

Microsoft COBOL v45/DEMO/EXTFILE.CBL

@@ -0,0 +1,152 @@
+      $set ans85 mf noosvs
+      ************************************************************
+      *                                                          *
+      *              (C) Micro Focus Ltd. 1989                   *
+      *                                                          *
+      *                     EXTFILE.CBL                          *
+      *                                                          *
+      *    This program demonstrates how to use EXTERNAL files.  *
+      *    It calls WRITEFIL to write some records to a data     *
+      *    file and READFILE to read the same records back       *
+      *    (without opening or closing the file between calls).  *
+      *    READFILE displays the output.                         *
+      *                                                          *
+      ************************************************************
+       identification division.
+       program-id. extfile.
+       environment division.
+       input-output section.
+       file-control.
+           select finfile assign to "isamfil.dat"
+               organization is indexed
+               record key is fd-tran-date
+               access mode is dynamic.
+
+       file section.
+       fd finfile
+          is external
+          record contains 50 characters.
+       01 fd-finfile-record.
+           05 fd-tran-date     pic x(4).
+           05 fd-with-or-dep   pic x(2).
+           05 fd-amount        pic 9(5)v99.
+
+
+       procedure division.
+       main-line.
+           perform open-file
+           perform write-to-the-file
+           perform start-file
+           perform read-the-file
+           perform close-file
+           stop run.
+
+       open-file.
+           open i-o finfile.
+
+       start-file.
+           move 1111 to fd-tran-date
+           start finfile key = fd-tran-date.
+
+       write-to-the-file.
+           call "writefil".
+
+       read-the-file.
+           call "readfile".
+
+       close-file.
+           close finfile.
+       end program extfile.
+      ************************************************************
+       identification division.
+       program-id. readfile.
+       environment division.
+       input-output section.
+       file-control.
+           select finfile assign to "isamfil.dat"
+               organization is indexed
+               record key is fd-tran-date
+               access mode is dynamic.
+
+       file section.
+       fd finfile
+          is external
+          record contains 50 characters.
+       01 fd-finfile-record.
+           05 fd-tran-date     pic x(4).
+           05 fd-with-or-dep   pic x(2).
+           05 fd-amount        pic 9(5)v99.
+
+       working-storage section.
+       01 ws-end-of-file       pic 9       value 0.
+       01 ws-subtotal          pic s9(5)v99 value 0.
+       01 ws-total             pic -(4)9.99.
+
+       procedure division.
+       main-line.
+           perform read-the-file.
+           perform until ws-end-of-file = 1
+               perform calculate-totals
+               perform read-the-file
+           end-perform.
+           perform display-output.
+           exit program.
+           stop run.
+
+       read-the-file.
+           read finfile next record at end move 1 to ws-end-of-file.
+
+       calculate-totals.
+           evaluate fd-with-or-dep
+             when "WI"
+                 subtract fd-amount from ws-subtotal
+             when "DE"
+                 add fd-amount to ws-subtotal
+           end-evaluate.
+
+       display-output.
+           move ws-subtotal to ws-total
+           display "account balance = ", ws-total.
+
+       end program readfile.
+      ************************************************************
+       identification division.
+       program-id. writefil.
+       environment division.
+       input-output section.
+       file-control.
+           select finfile assign to "isamfil.dat"
+               organization is indexed
+               record key is fd-tran-date
+               access mode is dynamic.
+
+       file section.
+       fd finfile
+          is external
+          record contains 50 characters.
+       01 fd-finfile-record.
+           05 fd-tran-date     pic x(4).
+           05 fd-with-or-dep   pic x(2).
+           05 fd-amount        pic 9(5)v99.
+
+       procedure division.
+       main-line.
+           perform write-records
+           exit program
+           stop run.
+
+       write-records.
+
+      * write a WIthdrawal record
+           move 1111 to fd-tran-date.
+           move 'WI' to fd-with-or-dep.
+           move 23.55 to fd-amount.
+           write fd-finfile-record.
+
+      * write a DEposit record
+           move 2222 to fd-tran-date.
+           move 'DE' to fd-with-or-dep.
+           move 123.55 to fd-amount.
+           write fd-finfile-record.
+
+       end program writefil.

Microsoft COBOL v45/DEMO/FUNKEY.CBL

@@ -0,0 +1,54 @@
+      $set noosvs mf ans85
+      ************************************************************
+      *                                                          *
+      *              (C) Micro Focus Ltd. 1991                   *
+      *                                                          *
+      *                      FUNKEY.CBL                          *
+      *                                                          *
+      *    This program demonstrates how to decode function keys *
+      *    using the x"af" call.                                 *
+      *                                                          *
+      ************************************************************
+       special-names.
+           crt status is key-status.
+
+       working-storage section.
+       01 flag                   pic 9(2) comp-x value 1.
+       01 user-key-control.
+          05 enable-fn-keys      pic 9(2) comp-x value 1.
+          05 filler              pic x           value "1".
+          05 first-user-key      pic 9(2) comp-x value 1.
+          05 number-of-keys      pic 9(2) comp-x value 10.
+
+       01 key-status.
+          05 key-type            pic x.
+          05 key-code-1          pic 9(2) comp-x.
+          05 filler              pic x.
+       01 any-data               pic x.
+       01 key-code-1-display     pic z9.
+
+       procedure division.
+           perform enable-keys
+           perform accept-function-key
+           perform tell-which-key-was-pressed
+           perform stop-run.
+
+       enable-keys.
+           call x"af" using flag user-key-control.
+
+       accept-function-key.
+           display spaces upon crt
+           display "Press a function key: F1 to F10" at 0505
+           accept any-data at 0540.
+
+       tell-which-key-was-pressed.
+           evaluate key-type
+              when 0 display "You pressed <Enter>" at 0705
+              when 1
+                   move key-code-1 to key-code-1-display
+                   display "You pressed function key" at 0705
+                   display key-code-1-display         at 0730
+           end-evaluate.
+
+       stop-run.
+           stop run.

Microsoft COBOL v45/DEMO/LOGOPER.CBL

@@ -0,0 +1,208 @@
+      $set ans85 noosvs mf
+      *******************************************************************
+      *                                                                 *
+      *                (C) Micro Focus Ltd. 1990                        *
+      *                                                                 *
+      *                      LOGOPER.CBL                                *
+      *                                                                 *
+      * This program gives an example of how to use the logical         *
+      * call-by-name routines. It uses three, namely                    *
+      *                                                                 *
+      *    "CBL_OR"                                                     *
+      *    "CBL_AND"                                                    *
+      *    "CBL_XOR"                                                    *
+      *                                                                 *
+      * The program also uses a selection of other call-by-name         *
+      * routines, mainly for screen handling.                           *
+      *                                                                 *
+      * The program puts a string of characters on the screen with      *
+      * various attributes. These attributes are then manipulated       *
+      * via the logical call-by-name routines - according to which      *
+      * key has been pressed on the keyboard.                           *
+      *                                                                 *
+      * The program tends to use values in Hex, where their             *
+      * significance is bitwise.                                        *
+      *                                                                 *
+      * The layout of a screen attribute byte is given below to         *
+      * illustrate the effect that the logical call-by-names are        *
+      * having.                                                         *
+      *                                                                 *
+      *                    Attribute Byte                               *
+      *                    --------------                               *
+      *    Bit    7     6     5     4     3     2     1     0           *
+      *          BL    BR    BG    BB    FI    FR    FG    FB           *
+      *                                                                 *
+      *    where:                                                       *
+      *        BL  -   make the foreground blink                        *
+      *        BR, BG, BB  -   The RGB colour value for the background  *
+      *        FI  -   make the foreground colour high intensity        *
+      *        FR, FG, FB  -   The RGB colour value for the foreground  *
+      *                                                                 *
+      *    The RGB table is:                                            *
+      *         R  G  B   Colour    High Intensity Colour               *
+      *         0  0  0   Black     Grey                                *
+      *         0  0  1   Blue      Light Blue                          *
+      *         0  1  0   Green     Light Green                         *
+      *         0  1  1   Cyan      Light Cyan                          *
+      *         1  0  0   Red       Light Red                           *
+      *         1  0  1   Magenta   Light Magenta                       *
+      *         1  1  0   Brown     Yellow                              *
+      *         1  1  1   White     Bright White                        *
+      *                                                                 *
+      *******************************************************************
+       working-storage section.
+       01  clr-char            pic x value space.
+       01  clr-attr            pic x value x"0f".
+
+       78  text-start          value 29.
+       78  text-len            value 23.
+       78  text-end            value 51.
+
+       01  text-scr-pos.
+           03  text-row        pic 9(2) comp-x value 12.
+           03  text-col        pic 9(2) comp-x value text-start.
+       01  text-char-buffer    pic x(text-len)
+                               value "Text-in-various-colours".
+       01  text-attr-buffer.
+           03  first-word      pic x(4) value all x"0f".
+           03  second-word     pic x(4) value all x"2c".
+           03  third-word      pic x(7) value all x"14".
+           03  third-space     pic x value x"30".
+           03  fourth-word     pic x(7) value all x"59".
+       01  text-length         pic 9(4) comp-x value text-len.
+
+       01  char-read           pic x.
+       01  char-length         pic 9(9) comp-5 value 1.
+
+       01  quit-flag           pic 9 comp-x.
+           88 not-ready-to-quit    value 0.
+           88 ready-to-quit        value 1.
+
+       01  csr-pos.
+           03  csr-row         pic 9(2) comp-x value 12.
+           03  csr-col         pic 9(2) comp-x value 39.
+       01  csr-attr            pic x.
+       01  csr-length          pic 9(4) comp-x value 1.
+
+       01  blink-mask          pic x value x"80".
+       01  steady-mask         pic x value x"7f".
+
+       01  invert-mask         pic x(text-len) value all x"7f".
+
+       78  instr-len           value 41.
+       01  instr-length        pic 9(4) comp-x value instr-len.
+       01  instr               pic x(instr-len)
+               value "Press (L)eft, (R)ight, (I)nvert or (Q)uit".
+       01  instr-pos.
+           03  instr-row       pic 9(2) comp-x value 8.
+           03  instr-col       pic 9(2) comp-x value 19.
+
+       procedure division.
+
+       main section.
+           perform init-screen
+           set not-ready-to-quit to true
+           perform until ready-to-quit
+               perform read-keyboard
+               evaluate char-read
+                   when "L"
+                       perform csr-move-left
+                   when "R"
+                       perform csr-move-right
+                   when "I"
+                       perform invert-text
+                   when "Q"
+                       set ready-to-quit to true
+               end-evaluate
+           end-perform
+           stop run
+           .
+
+       init-screen section.
+           call "cbl_clear_scr" using clr-char
+                                      clr-attr
+           call "cbl_write_scr_chars" using instr-pos
+                                            instr
+                                            instr-length
+           call "cbl_write_scr_chars" using text-scr-pos
+                                            text-char-buffer
+                                            text-length
+           perform put-attrs-on-screen
+           perform blink-cursor
+           .
+
+       read-keyboard section.
+           call "cbl_read_kbd_char" using char-read
+           call "cbl_toupper" using char-read
+                                    by value char-length
+           .
+
+
+       csr-move-left section.
+           perform steady-cursor
+           subtract 1 from csr-col
+           if csr-col < text-start
+               move text-end to csr-col
+           end-if
+           perform blink-cursor
+           .
+
+       csr-move-right section.
+           perform steady-cursor
+           add 1 to csr-col
+           if csr-col > text-end
+               move text-start to csr-col
+           end-if
+           perform blink-cursor
+           .
+
+
+       blink-cursor section.
+      *
+      * Turn on the blink bit at the current attribute.
+      *
+           call "cbl_read_scr_attrs" using csr-pos
+                                           csr-attr
+                                           csr-length
+           call "cbl_or" using blink-mask
+                               csr-attr
+                               by value 1
+           call "cbl_write_scr_attrs" using csr-pos
+                                            csr-attr
+                                            csr-length
+           .
+
+       steady-cursor section.
+      *
+      * Turn off the blink bit at the current attribute.
+      *
+           call "cbl_read_scr_attrs" using csr-pos
+                                           csr-attr
+                                           csr-length
+           call "cbl_and" using steady-mask
+                                csr-attr
+                                by value 1
+           call "cbl_write_scr_attrs" using csr-pos
+                                            csr-attr
+                                            csr-length
+           .
+
+       invert-text section.
+      *
+      * invert the bits that set the foreground colour, the background
+      * colour, and the intensity bits, but leave the blink bit alone.
+      *
+           call "cbl_read_scr_attrs" using text-scr-pos
+                                           text-attr-buffer
+                                           text-length
+           call "cbl_xor" using invert-mask
+                                text-attr-buffer
+                                by value text-len
+           perform put-attrs-on-screen
+           .
+
+       put-attrs-on-screen section.
+           call "cbl_write_scr_attrs" using text-scr-pos
+                                            text-attr-buffer
+                                            text-length
+           .

Microsoft COBOL v45/DEMO/MUDEMO/MUDEMO.CBL

@@ -0,0 +1,143 @@
+      $set ans85 noosvs mf
+      ************************************************************
+      *                                                          *
+      *              (C) Micro Focus Ltd. 1989                   *
+      *                                                          *
+      *                      MUDEMO.CBL                          *
+      *                                                          *
+      *                      MULTI-USER                          *
+      *                      ==========                          *
+      *                 DEMONSTRATION PROGRAM                    *
+      *                 =====================                    *
+      *                                                          *
+      *  This program demonstrates the file and record locking   *
+      *  facilities of this COBOL system.   This is the          *
+      *  main program in a suite of programs that demonstrate    *
+      *  how to use this COBOL in a multi-user environment.      *
+      *                                                          *
+      ************************************************************
+
+       configuration section.
+       special-names.
+          console is crt.
+
+       data division.
+
+       working-storage section.
+       01  mudemo01-00   .
+           03 filler           pic x(0407).
+           03 mudemo01-00-0608 pic x(0060) value "This is a demonstratio
+      -    "n program for use with COBOL.        ".
+           03 FILLER           PIC X(0100).
+           03 MUDEMO01-00-0808 PIC X(0058) VALUE "This program demonstra
+      -    "tes how multi-user COBOL can        ".
+           03 filler           pic x(0102).
+           03 mudemo01-00-1008 pic x(0028) value "lock both records and
+      -    "files.".
+           03 FILLER           PIC X(0212).
+           03 MUDEMO01-00-1308 PIC X(0062) VALUE "the program allows an
+      -    "indexed file to be opened in a number of".
+           03 filler           pic x(0098).
+           03 mudemo01-00-1508 pic x(0046) value "modes, which demonstra
+      -    "te the locking facility.".
+           03 FILLER           PIC X(0114).
+           03 MUDEMO01-00-1708 PIC X(0063) VALUE "for more information o
+      -    "n locking refer to the Operating Guide.  ".
+           03 filler           pic x(0097).
+           03 mudemo01-00-1908 pic x(0007) value "       ".
+           03 filler           pic x(0146).
+           03 mudemo01-00-2101 pic x(0080) value "----------------------
+      -    "----------------------------------------------------------".
+
+       01  options.
+           03  filler                   pic x(02).
+           03  option-1                 pic x(07)
+                   value "1.Input".
+           03  filler                   pic x(02).
+           03  option-2                 pic x(25)
+                   value "2.I-O Lock Mode Automatic".
+           03  filler                   pic x(02).
+           03  option-3                 pic x(22)
+                   value "3.I-O Lock Mode Manual".
+           03  filler                   pic x(02).
+           03  option-4                 pic x(08)
+                   value "4.Output".
+           03  filler                   pic x(02).
+           03  option-5                 pic x(06)
+                   value "5.Exit".
+
+
+       01  date-to-day.
+           03  days                     pic 99.
+           03  filler                   pic x.
+           03  month                    pic 99.
+           03  filler                   pic x.
+           03  year                     pic 99.
+
+       01  up-to-date-time.
+           03  hours                    pic 99.
+           03  filler                   pic x.
+           03  mins                     pic 99.
+
+       01  temp-date.
+           03  temp-year                pic xx.
+           03  temp-month               pic xx.
+           03  temp-day                 pic xx.
+       01  temp-time.
+           03  temp-hours               pic 99.
+           03  temp-mins                pic 99.
+           03  temp-rest                pic 9999.
+
+       01  choice                       pic 9 value 0.
+
+      **********************************************************
+      * Main Program                                           *
+      **********************************************************
+
+       procedure division.
+       ent-ry.
+           display space
+           display mudemo01-00
+           perform display-date
+           perform display-time
+           display options at 2201
+           display "INPUT CHOICE [ ]" at 2431 upon crt-under.
+
+       re-enter-choice.
+           accept choice at 2445.
+           evaluate choice
+             when 1        call "STOCKIN"
+                           cancel "STOCKIN"
+             when 2        call "STOCKIOA"
+                           cancel "STOCKIOA"
+             when 3        call "STOCKIOM"
+                           cancel "STOCKIOM"
+             when 4        call "STOCKOUT"
+                           cancel "STOCKOUT"
+             when 5        go to endit
+             when other    go to re-enter-choice
+           end-evaluate.
+           go to ent-ry.
+
+       endit.
+           stop run.
+
+
+      ***********************************************************
+      * Date and Time Routines                                  *
+      ***********************************************************
+
+       display-date.
+          accept temp-date from date.
+          move   temp-day to days.
+          move   temp-month to month.
+          move   temp-year to year.
+          display "Date   /  /" at 0164.
+          display date-to-day at 0169.
+
+       display-time.
+          accept temp-time from time.
+          move   temp-hours to hours.
+          move   temp-mins to mins.
+          display "Time   :" at 0264.
+          display up-to-date-time at 0269.

Microsoft COBOL v45/DEMO/MUDEMO/STOCKIN.CBL

@@ -0,0 +1,392 @@
+      $set ans85 mf noosvs
+      ************************************************************
+      *                                                          *
+      *              (C) Micro Focus Ltd. 1989                   *
+      *                                                          *
+      *                     STOCKIN.CBL                          *
+      *                                                          *
+      *                      MULTI-USER                          *
+      *                      ==========                          *
+      *                DEMONSTRATION PROGRAM                     *
+      *                =====================                     *
+      *                                                          *
+      *  This program demonstrates the file and record locking   *
+      *         facilities of this MULTI-USER.  This             *
+      *   subprogram, which is called by MUDEMO, acquires no     *
+      *          locks because it OPENs for INPUT only.          *
+      *                                                          *
+      ************************************************************
+       special-names.
+          console is crt.
+       input-output section.
+       file-control.
+           select stock-file assign "MUSTOCK.DAT"
+                organization indexed
+                access dynamic
+                record key stock-key
+                status file-status
+                lock mode automatic.
+      /
+       data division.
+
+      ***********************************************************
+      * File Definition                                         *
+      ***********************************************************
+
+       file section.
+       fd  stock-file.
+       01  stock-record.
+           03  stock-key                        pic 9(06).
+           03  stock-data.
+               05  stock-description-1          pic x(53).
+               05  stock-description-2          pic x(53).
+               05  stock-description-3          pic x(53).
+               05  stock-held                   pic 9(06).
+               05  stock-cost                   pic 9(06)v99.
+      /
+       working-storage section.
+       01     stock-00   .
+           03    stock-00-0101 pic x(0080) value "----------------------
+      -    "----------------------------------------------------------".
+           03    stock-00-0201 pic x(0001) value "|".
+           03 filler           pic x(0078).
+           03    stock-00-0280 pic x(0001) value "|".
+           03    stock-00-0301 pic x(0001) value "|".
+           03 filler           pic x(0031).
+           03    stock-00-0333 pic x(0011) value " Acme Inc. ".
+           03 filler           pic x(0020).
+           03    stock-00-0364 pic x(0017) value "Date   /  /     |".
+           03    stock-00-0401 pic x(0001) value "|".
+           03 filler           pic x(0031).
+           03    stock-00-0433 pic x(0011) value "===========".
+           03 filler           pic x(0020).
+           03    stock-00-0464 pic x(0017) value "Time   :        |".
+           03    stock-00-0501 pic x(0001) value "|".
+           03 filler           pic x(0027).
+           03    stock-00-0529 pic x(0020) value "Stock Control System".
+           03 filler           pic x(0031).
+           03    stock-00-0580 pic x(0001) value "|".
+           03    stock-00-0601 pic x(0001) value "|".
+           03 filler           pic x(0027).
+           03    stock-00-0629 pic x(0020) value "====================".
+           03 filler           pic x(0031).
+           03    stock-00-0680 pic x(0001) value "|".
+           03    stock-00-0701 pic x(0001) value "|".
+           03 filler           pic x(0078).
+           03    stock-00-0780 pic x(0001) value "|".
+           03    stock-00-0801 pic x(0001) value "|".
+           03 filler           pic x(0078).
+           03    stock-00-0880 pic x(0001) value "|".
+           03    stock-00-0901 pic x(0025) value "|  Stock Code    [
+      -    "  ]".
+           03 filler           pic x(0054).
+           03    stock-00-0980 pic x(0001) value "|".
+           03    stock-00-1001 pic x(0001) value "|".
+           03 filler           pic x(0078).
+           03    stock-00-1080 pic x(0001) value "|".
+           03    stock-00-1101 pic x(0022) value "|  Stock Description [
+      -    "".
+           03 FILLER           PIC X(0053).
+           03    STOCK-00-1176 PIC X(0005) VALUE "]   |".
+           03    stock-00-1201 pic x(0001) value "|".
+           03 filler           pic x(0020).
+           03    stock-00-1222 pic x(0001) value "[".
+           03 filler           pic x(0053).
+           03    stock-00-1276 pic x(0005) value "]   |".
+           03    stock-00-1301 pic x(0001) value "|".
+           03 filler           pic x(0020).
+           03    stock-00-1322 pic x(0001) value "[".
+           03 filler           pic x(0053).
+           03    stock-00-1376 pic x(0005) value "]   |".
+           03    stock-00-1401 pic x(0001) value "|".
+           03 filler           pic x(0078).
+           03    stock-00-1480 pic x(0001) value "|".
+           03    stock-00-1501 pic x(0025) value "|  Stock Held    [
+      -    "  ]".
+           03 filler           pic x(0054).
+           03    stock-00-1580 pic x(0001) value "|".
+           03    stock-00-1601 pic x(0001) value "|".
+           03 filler           pic x(0078).
+           03    stock-00-1680 pic x(0001) value "|".
+           03    stock-00-1701 pic x(0028) value "|  Cost per Unit [
+      -    "     ]".
+           03 filler           pic x(0051).
+           03    stock-00-1780 pic x(0001) value "|".
+           03    stock-00-1801 pic x(0001) value "|".
+           03 filler           pic x(0078).
+           03    stock-00-1880 pic x(0001) value "|".
+           03    stock-00-1901 pic x(0001) value "|".
+           03 filler           pic x(0078).
+           03    stock-00-1980 pic x(0001) value "|".
+           03    stock-00-2101 pic x(0080) value "----------------------
+      -    "----------------------------------------------------------".
+           03    stock-00-2201 pic x(0040)
+                 value "-----Open Mode----Lock Mode--Last Operat".
+           03    stock-00-2241 pic x(0040)
+                 value "ion-----------Outcome------File Status--".
+           03 filler           pic x(1037).
+
+       01     stock-01    redefines    stock-00   .
+           03 filler           pic x(0658).
+           03   stock-01-code           pic 9(0006).
+           03 filler           pic x(0158).
+           03   stock-01-description-1  pic x(0053).
+           03 filler           pic x(0027).
+           03   stock-01-description-2  pic x(0053).
+           03 filler           pic x(0027).
+           03   stock-01-description-3  pic x(0053).
+           03 filler           pic x(0103).
+           03   stock-01-held           pic 9(0006).
+           03 filler           pic x(0154).
+           03   stock-01-cost           pic $$$$$9.99.
+           03 filler           pic x(0579).
+           03   choice                  pic 9.
+
+      ***********************************************************
+      * File Status Variables                                   *
+      ***********************************************************
+
+       01  file-status.
+           03  status-1                 pic x.
+           03  status-2                 pic x.
+
+       01  binary-status redefines file-status pic 9(04) comp.
+      ***********************************************************
+      * Date and Time Variables                                 *
+      ***********************************************************
+
+       01  date-to-day.
+           03  days                     pic 99.
+           03  filler                   pic x.
+           03  month                    pic 99.
+           03  filler                   pic x.
+           03  year                     pic 99.
+
+       01  up-to-date-time.
+           03  hours                    pic 99.
+           03  filler                   pic x.
+           03  mins                     pic 99.
+
+       01  temp-date.
+           03  temp-year                pic xx.
+           03  temp-month               pic xx.
+           03  temp-day                 pic xx.
+       01  temp-time.
+           03  temp-hours               pic 99.
+           03  temp-mins                pic 99.
+           03  temp-rest                pic 9999.
+
+      ***********************************************************
+      * Information Line Declaration                            *
+      ***********************************************************
+
+       01  status-line.
+           03  filler                   pic x(02).
+           03  open-mode                pic x(14).
+           03  filler                   pic x(02).
+           03  lock-mode                pic x(09)
+                   value "---------".
+           03  filler                   pic x(03).
+           03  last-operation           pic x(11).
+           03  filler                   pic x(03).
+           03  was-it-successful        pic x(20).
+           03  filler                   pic x(08).
+           03  error-code.
+               05 stat-1                pic x.
+               05 filler                pic x.
+               05 stat-2                pic 9(03).
+
+       01  hyphen-line                  pic x(80)
+               value all "-".
+
+       01  yesno                        pic x.
+
+       01    inpopt.
+           03   filler         pic x(10).
+           03   inpopt-00      pic x(0056) value "1. Read on Key   2. Re
+      -    "ad next   3. start not <   4. exit".
+
+      ***********************************************************
+      * Program for input only                                  *
+      ***********************************************************
+
+       procedure division.
+       main.
+           initialize choice
+                      stock-01.
+           display space.
+           display stock-00.
+           display inpopt at 2301.
+           display "Input Choice [ ]" at 2433 upon crt-under.
+           open input stock-file.
+           move "----Open Input" to open-mode.
+           move "-Open Input" to last-operation.
+           perform status-check.
+           if was-it-successful not = "----------Successful"
+               move "----Closed----" to open-mode
+               display hyphen-line at 2201 upon crt-under
+               display status-line at 2201 upon crt-under
+               go to endit.
+
+      ***********************************************************
+      * Main Loop                                               *
+      ***********************************************************
+
+       ent-ry.
+           perform display-date.
+           perform display-time.
+           display hyphen-line at 2201 upon crt-under
+           display status-line at 2201 upon crt-under
+           accept stock-01.
+           evaluate choice
+                when 1 perform read-on-key
+                when 2 perform read-next
+                when 3 perform start-not-less-than
+                when 4 go to wrap-up
+           end-evaluate.
+           go to ent-ry.
+
+      ***********************************************************
+      * Closing-Down Paragraphs                                 *
+      ***********************************************************
+
+       wrap-up.
+           close stock-file.
+           move "----Closed----" to open-mode.
+           move "------Closed" to last-operation.
+           perform status-check.
+           display hyphen-line at 2201 upon crt-under.
+           display status-line at 2201 upon crt-under.
+
+       endit.
+           display "Do you wish to restart (Y/N) [ ]"
+               at 2424 upon crt-under.
+           accept yesno at 2454.
+           if yesno = "Y" or "y"
+              go to main
+           else if yesno = "N" or "n"
+                   exit program
+                else
+                   go to endit
+           end-if.
+
+
+      ***********************************************************
+      * File-Handling Paragraphs                                *
+      ***********************************************************
+
+       read-on-key.
+           move "Read on key" to last-operation.
+           perform move-key-from-screen-to-rec.
+           read stock-file.
+           perform status-check.
+           perform move-from-rec-to-screen.
+           display stock-01.
+
+       read-next.
+           move "--Read Next" to last-operation.
+           read stock-file next.
+           perform status-check.
+           perform move-from-rec-to-screen.
+           display stock-01.
+
+       start-not-less-than.
+           move "Start not <" to last-operation.
+           perform move-key-from-screen-to-rec.
+           start stock-file key not less than stock-key.
+           perform status-check.
+
+      ***********************************************************
+      *    File Status Checking Routines.                       *
+      ***********************************************************
+
+       status-check.
+            move status-1 to stat-1
+            move status-2 to stat-2
+            evaluate status-1
+               when "0"
+                  move "----------Successful" to was-it-successful
+               when "1"
+                  move "---------End of file" to was-it-successful
+               when "2"
+                  move "---------Invalid Key" to was-it-successful
+               when "9"
+                  perform look-up-error thru error-end
+            end-evaluate.
+
+      ***********************************************************
+      *     Look Up Error Number                                *
+      ***********************************************************
+
+       look-up-error.
+           move low-values to status-1.
+           move binary-status to stat-2.
+           evaluate stat-2
+             when 002
+               move "-------File not open" to was-it-successful
+             when 007
+               move "Disk space exhausted" to was-it-successful
+             when 013
+               move "------File not found" to was-it-successful
+             when 024
+               move "----------Disk error" to was-it-successful
+             when 041
+               move "---Corrupt ISAM file" to was-it-successful
+             when 065
+               move "---------File locked" to was-it-successful
+             when 068
+               move "-------Record locked" to was-it-successful
+             when 139
+               move "Record inconsistency" to was-it-successful
+             when 146
+               move "---No current record" to was-it-successful
+             when 180
+               move "------File malformed" to was-it-successful
+             when 208
+               move "-------Network error" to was-it-successful
+             when 213
+               move "------Too many locks" to was-it-successful
+           end-evaluate.
+       error-end.
+           exit.
+
+
+      ***********************************************************
+      *     Subroutines for moving Data to and from the Screen  *
+      ***********************************************************
+
+       move-key-from-screen-to-rec.
+          move stock-01-code to stock-key.
+
+       move-from-screen-to-rec.
+          move stock-01-code to stock-key.
+          move stock-01-description-1 to stock-description-1.
+          move stock-01-description-2 to stock-description-2.
+          move stock-01-description-3 to stock-description-3.
+          move stock-01-held to stock-held.
+          move stock-01-cost to stock-cost.
+
+       move-from-rec-to-screen.
+          move stock-key to stock-01-code.
+          move stock-description-1 to stock-01-description-1.
+          move stock-description-2 to stock-01-description-2.
+          move stock-description-3 to stock-01-description-3.
+          move stock-held to stock-01-held.
+          move stock-cost to stock-01-cost.
+
+      ***********************************************************
+      * Date and Time Routines.                                 *
+      ***********************************************************
+
+       display-date.
+          accept temp-date from date.
+          move temp-day to days.
+          move temp-month to month.
+          move temp-year to year.
+          display date-to-day at 0369.
+
+       display-time.
+          accept temp-time from time.
+          move temp-hours to hours.
+          move temp-mins to mins.
+          display up-to-date-time at 0469.

Microsoft COBOL v45/DEMO/MUDEMO/STOCKIOA.CBL

@@ -0,0 +1,416 @@
+      $set ans85 noosvs mf
+      ************************************************************
+      *                                                          *
+      *              (C) Micro Focus Ltd. 1989                   *
+      *                                                          *
+      *                     STOCKIOA.CBL                         *
+      *                                                          *
+      *                      MULTI-USER                          *
+      *                      ==========                          *
+      *                DEMONSTRATION PROGRAM                     *
+      *                =====================                     *
+      *                                                          *
+      *  This program demonstrates the file and record locking   *
+      *     facilities of this MULTI-USER COBOL. This            *
+      *   subprogram, which is called by MUDEMO, locks single    *
+      *  records automatically. This is the default locking in   *
+      *          this COBOL multi-user environment.              *
+      *                                                          *
+      ************************************************************
+
+       configuration section.
+       special-names.
+          console is crt.
+       input-output section.
+       file-control.
+           select stock-file assign "MUSTOCK.DAT"
+                organization indexed
+                access dynamic
+                record key stock-key
+                status file-status
+                lock mode automatic.
+      /
+       data division.
+
+      ***********************************************************
+      * File Definition                                         *
+      ***********************************************************
+
+       file section.
+       fd  stock-file.
+       01  stock-record.
+           03  stock-key                        pic 9(06).
+           03  stock-data.
+               05  stock-description-1          pic x(53).
+               05  stock-description-2          pic x(53).
+               05  stock-description-3          pic x(53).
+               05  stock-held                   pic 9(06).
+               05  stock-cost                   pic 9(06)v99.
+      /
+       working-storage section.
+       01     stock-00   .
+           03    stock-00-0101 pic x(0080) value "----------------------
+      -    "----------------------------------------------------------".
+           03    stock-00-0201 pic x(0001) value "|".
+           03 filler           pic x(0078).
+           03    stock-00-0280 pic x(0001) value "|".
+           03    stock-00-0301 pic x(0001) value "|".
+           03 filler           pic x(0031).
+           03    stock-00-0333 pic x(0011) value " Acme Inc. ".
+           03 filler           pic x(0020).
+           03    stock-00-0364 pic x(0017) value "Date   /  /     |".
+           03    stock-00-0401 pic x(0001) value "|".
+           03 filler           pic x(0031).
+           03    stock-00-0433 pic x(0011) value "===========".
+           03 filler           pic x(0020).
+           03    stock-00-0464 pic x(0017) value "Time   :        |".
+           03    stock-00-0501 pic x(0001) value "|".
+           03 filler           pic x(0027).
+           03    stock-00-0529 pic x(0020) value "Stock Control System".
+           03 filler           pic x(0031).
+           03    stock-00-0580 pic x(0001) value "|".
+           03    stock-00-0601 pic x(0001) value "|".
+           03 filler           pic x(0027).
+           03    stock-00-0629 pic x(0020) value "====================".
+           03 filler           pic x(0031).
+           03    stock-00-0680 pic x(0001) value "|".
+           03    stock-00-0701 pic x(0001) value "|".
+           03 filler           pic x(0078).
+           03    stock-00-0780 pic x(0001) value "|".
+           03    stock-00-0801 pic x(0001) value "|".
+           03 filler           pic x(0078).
+           03    stock-00-0880 pic x(0001) value "|".
+           03    stock-00-0901 pic x(0025) value "|  Stock Code    [
+      -    "  ]".
+           03 filler           pic x(0054).
+           03    stock-00-0980 pic x(0001) value "|".
+           03    stock-00-1001 pic x(0001) value "|".
+           03 filler           pic x(0078).
+           03    stock-00-1080 pic x(0001) value "|".
+           03    stock-00-1101 pic x(0022) value "|  Stock Description [
+      -    "".
+           03 FILLER           PIC X(0053).
+           03    STOCK-00-1176 PIC X(0005) VALUE "]   |".
+           03    stock-00-1201 pic x(0001) value "|".
+           03 filler           pic x(0020).
+           03    stock-00-1222 pic x(0001) value "[".
+           03 filler           pic x(0053).
+           03    stock-00-1276 pic x(0005) value "]   |".
+           03    stock-00-1301 pic x(0001) value "|".
+           03 filler           pic x(0020).
+           03    stock-00-1322 pic x(0001) value "[".
+           03 filler           pic x(0053).
+           03    stock-00-1376 pic x(0005) value "]   |".
+           03    stock-00-1401 pic x(0001) value "|".
+           03 filler           pic x(0078).
+           03    stock-00-1480 pic x(0001) value "|".
+           03    stock-00-1501 pic x(0025) value "|  Stock Held    [
+      -    "  ]".
+           03 filler           pic x(0054).
+           03    stock-00-1580 pic x(0001) value "|".
+           03    stock-00-1601 pic x(0001) value "|".
+           03 filler           pic x(0078).
+           03    stock-00-1680 pic x(0001) value "|".
+           03    stock-00-1701 pic x(0028) value "|  Cost per Unit [
+      -    "     ]".
+           03 filler           pic x(0051).
+           03    stock-00-1780 pic x(0001) value "|".
+           03    stock-00-1801 pic x(0001) value "|".
+           03 filler           pic x(0078).
+           03    stock-00-1880 pic x(0001) value "|".
+           03    stock-00-1901 pic x(0001) value "|".
+           03 filler           pic x(0078).
+           03    stock-00-1980 pic x(0001) value "|".
+           03    stock-00-2101 pic x(0080) value "----------------------
+      -    "----------------------------------------------------------".
+           03    stock-00-2201 pic x(0040)
+                 value "-----Open Mode----Lock Mode--Last Operat".
+           03    stock-00-2241 pic x(0040)
+                 value "ion-----------Outcome------File Status--".
+           03 filler           pic x(1037).
+
+       01     stock-01    redefines    stock-00   .
+           03 filler           pic x(0658).
+           03   stock-01-code           pic 9(0006).
+           03 filler           pic x(0158).
+           03   stock-01-description-1  pic x(0053).
+           03 filler           pic x(0027).
+           03   stock-01-description-2  pic x(0053).
+           03 filler           pic x(0027).
+           03   stock-01-description-3  pic x(0053).
+           03 filler           pic x(0103).
+           03   stock-01-held           pic 9(0006).
+           03 filler           pic x(0154).
+           03   stock-01-cost           pic $$$$$9.99.
+           03 filler           pic x(0579).
+           03   choice                  pic 9.
+
+      ***********************************************************
+      * File Status Variables                                   *
+      ***********************************************************
+
+       01  file-status.
+           03  status-1                 pic x.
+           03  status-2                 pic x.
+
+       01  binary-status redefines file-status pic 9(04) comp.
+
+      ***********************************************************
+      * Date and Time Variables                                 *
+      ***********************************************************
+
+       01  date-to-day.
+           03  days                     pic 99.
+           03  filler                   pic x.
+           03  month                    pic 99.
+           03  filler                   pic x.
+           03  year                     pic 99.
+
+       01  up-to-date-time.
+           03  hours                    pic 99.
+           03  filler                   pic x.
+           03  mins                     pic 99.
+
+       01  temp-date.
+           03  temp-year                pic xx.
+           03  temp-month               pic xx.
+           03  temp-day                 pic xx.
+       01  temp-time.
+           03  temp-hours               pic 99.
+           03  temp-mins                pic 99.
+           03  temp-rest                pic 9999.
+
+      ***********************************************************
+      * Information Line                                        *
+      ***********************************************************
+
+       01  status-line.
+           03  filler                   pic x(02).
+           03  open-mode                pic x(14).
+           03  filler                   pic x(02).
+           03  lock-mode                pic x(09)
+                   value "Automatic".
+           03  filler                   pic x(03).
+           03  last-operation           pic x(11).
+           03  filler                   pic x(03).
+           03  was-it-successful        pic x(20).
+           03  filler                   pic x(08).
+           03  error-code.
+               05 stat-1                pic x.
+               05 filler                pic x.
+               05 stat-2                pic 9(03).
+
+       01  hyphen-line                  pic x(80)
+               value all "-".
+
+       01  yesno                        pic x.
+
+       01    inpopt.
+           03   inpopt-00      pic x(0040)
+                 value "1.Read on Key  2.Read next  3.Start not ".
+           03   inpopt-01      pic x(0040)
+                 value "<  4.Write  5.Rewrite  6.Delete  7.Exit".
+
+      **********************************************************
+      * Program for locking single records automatically       *
+      **********************************************************
+
+       procedure division.
+       main.
+           initialize choice
+                      stock-01.
+           display space.
+           display stock-00.
+           display inpopt at 2301.
+           display "Input Choice [ ]" at 2433 upon crt-under.
+           open i-o stock-file.
+           move "---Open I-O---" to open-mode.
+           move "-Open I-O--" to last-operation.
+           perform status-check.
+           if was-it-successful not = "----------Successful"
+               move "----Closed----" to open-mode
+               display hyphen-line at 2201 upon crt-under
+               display status-line at 2201 upon crt-under
+               go to endit.
+
+      ***********************************************************
+      * MAIN LOOP                                               *
+      ***********************************************************
+
+       ent-ry.
+           accept temp-date from date.
+           perform display-date.
+           accept temp-time from time.
+           perform display-time.
+           display hyphen-line at 2201 upon crt-under
+           display status-line at 2201 upon crt-under
+           accept stock-01.
+           evaluate choice
+               when    1 perform read-on-key
+               when    2 perform read-next
+               when    3 perform start-not-less-than
+               when    4 perform write-record
+               when    5 perform rewrite-record
+               when    6 perform delete-record
+               when    7 go to wrap-up
+           end-evaluate.
+           go to ent-ry.
+
+      ***********************************************************
+      * Close down paragraphs                                   *
+      ***********************************************************
+
+       wrap-up.
+           close stock-file.
+           move "----Closed----" to open-mode.
+           move "------Closed" to last-operation.
+           perform status-check.
+           display hyphen-line at 2201 upon crt-under.
+           display status-line at 2201 upon crt-under.
+
+       endit.
+           display "Do you wish to restart (Y/N) [ ]"
+               at 2424 upon crt-under.
+           accept yesno at 2454.
+           evaluate yesno
+                       when "Y"      go to main
+                       when "y"      go to main
+                       when "N"      exit program
+                       when "n"      exit program
+                       when other    go to endit
+           end-evaluate.
+
+      ***********************************************************
+      * File Handling Routines                                  *
+      ***********************************************************
+
+       read-on-key.
+           move "Read on key" to last-operation.
+           perform move-key-from-screen-to-rec.
+           read stock-file.
+           perform status-check.
+           perform move-from-rec-to-screen.
+           display stock-01.
+
+       read-next.
+           move "--Read Next" to last-operation.
+           read stock-file next.
+           perform status-check.
+           perform move-from-rec-to-screen.
+           display stock-01.
+
+       start-not-less-than.
+           move "Start not <" to last-operation.
+           perform move-key-from-screen-to-rec.
+           start stock-file key not less than stock-key.
+           perform status-check.
+
+       write-record.
+           move "---Write---" to last-operation.
+           perform move-from-screen-to-rec.
+           write stock-record.
+           perform status-check.
+
+       rewrite-record.
+           move "--Rewrite--" to last-operation.
+           perform move-from-screen-to-rec.
+           rewrite stock-record.
+           perform status-check.
+
+       delete-record.
+           move "--Delete---" to last-operation.
+           perform move-key-from-screen-to-rec.
+           delete stock-file.
+           perform status-check.
+
+      ***********************************************************
+      *    File Status Checking Routines.                       *
+      ***********************************************************
+
+       status-check.
+               move status-1 to stat-1
+               move status-2 to stat-2
+           evaluate status-1
+                  when   "0"
+               move "----------Successful" to was-it-successful
+                  when   "1"
+               move "---------End of file" to was-it-successful
+                  when   "2"
+               move "---------Invalid Key" to was-it-successful
+                  when   "9"
+               perform look-up-error thru error-end
+           end-evaluate.
+      ***********************************************************
+      *     Look up error number                                *
+      ***********************************************************
+
+       look-up-error.
+           move low-values to status-1.
+           move binary-status to stat-2.
+           evaluate stat-2
+                 when  002
+               move "-------File not open" to was-it-successful
+                 when  007
+               move "Disk space exhausted" to was-it-successful
+                 when  013
+               move "------File not found" to was-it-successful
+                 when  024
+               move "----------Disk error" to was-it-successful
+                 when  041
+               move "---Corrupt ISAM file" to was-it-successful
+                 when  065
+               move "---------File locked" to was-it-successful
+                 when  068
+               move "-------Record locked" to was-it-successful
+                 when  139
+               move "Record inconsistency" to was-it-successful
+                 when  146
+               move "---No current record" to was-it-successful
+                 when  180
+               move "------File malformed" to was-it-successful
+                 when  208
+               move "-------Network error" to was-it-successful
+                 when  213
+               move "------Too many locks" to was-it-successful
+           end-evaluate.
+       error-end.
+           exit.
+
+
+      ***********************************************************
+      *     Move data to and from the screen                    *
+      ***********************************************************
+
+       move-key-from-screen-to-rec.
+          move stock-01-code to stock-key.
+
+       move-from-screen-to-rec.
+          move stock-01-code to stock-key.
+          move stock-01-description-1 to stock-description-1.
+          move stock-01-description-2 to stock-description-2.
+          move stock-01-description-3 to stock-description-3.
+          move stock-01-held to stock-held.
+          move stock-01-cost to stock-cost.
+
+       move-from-rec-to-screen.
+          move stock-key to stock-01-code.
+          move stock-description-1 to stock-01-description-1.
+          move stock-description-2 to stock-01-description-2.
+          move stock-description-3 to stock-01-description-3.
+          move stock-held to stock-01-held.
+          move stock-cost to stock-01-cost.
+
+      ***********************************************************
+      * Date and Time Routines                                  *
+      ***********************************************************
+
+       display-date.
+          move temp-day to days.
+          move temp-month to month.
+          move temp-year to year.
+          display date-to-day at 0369.
+
+       display-time.
+          move temp-hours to hours.
+          move temp-mins to mins.
+          display up-to-date-time at 0469.

Microsoft COBOL v45/DEMO/MUDEMO/STOCKIOM.CBL

@@ -0,0 +1,440 @@
+      $set ans85 noosvs mf
+      ************************************************************
+      *                                                          *
+      *              (C) Micro Focus Ltd. 1989                   *
+      *                                                          *
+      *                     STOCKIOM.CBL                         *
+      *                                                          *
+      *                      MULTI-USER                          *
+      *                      ==========                          *
+      *                DEMONSTRATION PROGRAM                     *
+      *                =====================                     *
+      *                                                          *
+      *  This program demonstrates the file and record locking   *
+      *       facilities of this MULTI-USER COBOL. This          *
+      *        subprogram, which is called by MUDEMO, locks      *
+      *  multiple records. The records must be locked manually.  *
+      *                                                          *
+      ************************************************************
+
+       special-names.
+          console is crt.
+       input-output section.
+       file-control.
+           select stock-file assign "MUSTOCK.DAT"
+                organization indexed
+                access dynamic
+                record key stock-key
+
+      ***********************************************************
+      * Extra syntax for locking                                *
+      ***********************************************************
+
+                lock mode manual
+                with lock on multiple records
+                status file-status.
+      /
+       data division.
+
+      ***********************************************************
+      * File Definition                                         *
+      ***********************************************************
+
+       file section.
+       fd  stock-file.
+       01  stock-record.
+           03  stock-key                        pic 9(06).
+           03  stock-data.
+               05  stock-description-1          pic x(53).
+               05  stock-description-2          pic x(53).
+               05  stock-description-3          pic x(53).
+               05  stock-held                   pic 9(06).
+               05  stock-cost                   pic 9(06)v99.
+      /
+       working-storage section.
+       01     stock-00   .
+           03    stock-00-0101 pic x(0080) value "----------------------
+      -    "----------------------------------------------------------".
+           03    stock-00-0201 pic x(0001) value "|".
+           03 filler           pic x(0078).
+           03    stock-00-0280 pic x(0001) value "|".
+           03    stock-00-0301 pic x(0001) value "|".
+           03 filler           pic x(0031).
+           03    stock-00-0333 pic x(0011) value " Acme Inc. ".
+           03 filler           pic x(0020).
+           03    stock-00-0364 pic x(0017) value "Date   /  /     |".
+           03    stock-00-0401 pic x(0001) value "|".
+           03 filler           pic x(0031).
+           03    stock-00-0433 pic x(0011) value "===========".
+           03 filler           pic x(0020).
+           03    stock-00-0464 pic x(0017) value "Time   :        |".
+           03    stock-00-0501 pic x(0001) value "|".
+           03 filler           pic x(0027).
+           03    stock-00-0529 pic x(0020) value "Stock Control System".
+           03 filler           pic x(0031).
+           03    stock-00-0580 pic x(0001) value "|".
+           03    stock-00-0601 pic x(0001) value "|".
+           03 filler           pic x(0027).
+           03    stock-00-0629 pic x(0020) value "====================".
+           03 filler           pic x(0031).
+           03    stock-00-0680 pic x(0001) value "|".
+           03    stock-00-0701 pic x(0001) value "|".
+           03 filler           pic x(0078).
+           03    stock-00-0780 pic x(0001) value "|".
+           03    stock-00-0801 pic x(0001) value "|".
+           03 filler           pic x(0078).
+           03    stock-00-0880 pic x(0001) value "|".
+           03    stock-00-0901 pic x(0025) value "|  Stock Code    [
+      -    "  ]".
+           03 filler           pic x(0054).
+           03    stock-00-0980 pic x(0001) value "|".
+           03    stock-00-1001 pic x(0001) value "|".
+           03 filler           pic x(0078).
+           03    stock-00-1080 pic x(0001) value "|".
+           03    stock-00-1101 pic x(0022) value "|  Stock Description [
+      -    "".
+           03 FILLER           PIC X(0053).
+           03    STOCK-00-1176 PIC X(0005) VALUE "]   |".
+           03    stock-00-1201 pic x(0001) value "|".
+           03 filler           pic x(0020).
+           03    stock-00-1222 pic x(0001) value "[".
+           03 filler           pic x(0053).
+           03    stock-00-1276 pic x(0005) value "]   |".
+           03    stock-00-1301 pic x(0001) value "|".
+           03 filler           pic x(0020).
+           03    stock-00-1322 pic x(0001) value "[".
+           03 filler           pic x(0053).
+           03    stock-00-1376 pic x(0005) value "]   |".
+           03    stock-00-1401 pic x(0001) value "|".
+           03 filler           pic x(0078).
+           03    stock-00-1480 pic x(0001) value "|".
+           03    stock-00-1501 pic x(0025) value "|  Stock Held    [
+      -    "  ]".
+           03 filler           pic x(0054).
+           03    stock-00-1580 pic x(0001) value "|".
+           03    stock-00-1601 pic x(0001) value "|".
+           03 filler           pic x(0078).
+           03    stock-00-1680 pic x(0001) value "|".
+           03    stock-00-1701 pic x(0028) value "|  Cost per Unit [
+      -    "     ]".
+           03 filler           pic x(0051).
+           03    stock-00-1780 pic x(0001) value "|".
+           03    stock-00-1801 pic x(0001) value "|".
+           03 filler           pic x(0078).
+           03    stock-00-1880 pic x(0001) value "|".
+           03    stock-00-2101 pic x(0080) value "----------------------
+      -    "----------------------------------------------------------".
+           03    stock-00-2201 pic x(0040)
+                 value "-----Open Mode----Lock Mode--Last Operat".
+           03    stock-00-2241 pic x(0040)
+                 value "ion-----------Outcome------File Status--".
+           03 filler           pic x(1117).
+
+       01     stock-01    redefines    stock-00   .
+           03 filler           pic x(0658).
+           03   stock-01-code           pic 9(0006).
+           03 filler           pic x(0158).
+           03   stock-01-description-1  pic x(0053).
+           03 filler           pic x(0027).
+           03   stock-01-description-2  pic x(0053).
+           03 filler           pic x(0027).
+           03   stock-01-description-3  pic x(0053).
+           03 filler           pic x(0103).
+           03   stock-01-held           pic 9(0006).
+           03 filler           pic x(0154).
+           03   stock-01-cost           pic $$$$$9.99.
+           03 filler           pic x(0579).
+           03   choice                  pic 9.
+
+      ***********************************************************
+      * File Status Variables                                   *
+      ***********************************************************
+
+       01  file-status.
+           03  status-1                 pic x.
+           03  status-2                 pic x.
+
+       01  binary-status redefines file-status pic 9(04) comp.
+
+      ***********************************************************
+      * Date and Time Variables                                 *
+      ***********************************************************
+
+       01  date-to-day.
+           03  days                     pic 99.
+           03  filler                   pic x.
+           03  month                    pic 99.
+           03  filler                   pic x.
+           03  year                     pic 99.
+
+       01  up-to-date-time.
+           03  hours                    pic 99.
+           03  filler                   pic x.
+           03  mins                     pic 99.
+
+       01  temp-date.
+           03  temp-year                pic xx.
+           03  temp-month               pic xx.
+           03  temp-day                 pic xx.
+       01  temp-time.
+           03  temp-hours               pic 99.
+           03  temp-mins                pic 99.
+           03  temp-rest                pic 9999.
+
+
+      ***********************************************************
+      * Information Line                                        *
+      ***********************************************************
+
+       01  status-line.
+           03  filler                   pic x(02).
+           03  open-mode                pic x(14).
+           03  filler                   pic x(02).
+           03  lock-mode                pic x(09)
+                   value "-Manual--".
+           03  filler                   pic x(03).
+           03  last-operation           pic x(11).
+           03  filler                   pic x(03).
+           03  was-it-successful        pic x(20).
+           03  filler                   pic x(08).
+           03  error-code.
+               05 stat-1                pic x.
+               05 filler                pic x.
+               05 stat-2                pic 9(03).
+
+       01  hyphen-line                  pic x(80)
+               value all "-".
+
+       01  yesno                        pic x.
+
+       01    inpopt.
+           03   inpopt-00      pic x(0040)
+                 value "1.Read on Key  2.Read next  3.Read on ke".
+           03   inpopt-01      pic x(0040)
+                 value "y with kept lock  4.Read next kept lock ".
+           03   inpopt-02      pic x(0040)
+                 value "          5.Start not <  6.Write  7.Rewr".
+           03   inpopt-03      pic x(0040)
+                 value "ite  8.Delete  9.Unlock  0.Exit".
+
+      **********************************************************
+      * Program for locking multiple records manually          *
+      **********************************************************
+
+       procedure division.
+       main.
+           initialize choice
+                      stock-01.
+           display space.
+           display stock-00.
+           display inpopt at 2201.
+           display "Input Choice [ ]" at 2433 upon crt-under.
+           open i-o stock-file.
+           move "---Open I-O---" to open-mode.
+           move "-Open I-O--" to last-operation.
+           perform status-check.
+           if was-it-successful not = "----------Successful"
+               move "----Closed----" to open-mode
+               display hyphen-line at 2101 upon crt-under
+               display status-line at 2101 upon crt-under
+               go to endit.
+
+       ent-ry.
+           accept temp-date from date.
+           perform display-date.
+           accept temp-time from time.
+           perform display-time.
+           display hyphen-line at 2101 upon crt-under
+           display status-line at 2101 upon crt-under
+           accept stock-01.
+           evaluate choice
+                when 0     go to wrap-up
+                when 1     perform read-on-key
+                when 2     perform read-next
+                when 3     perform read-with-kept-lock
+                when 4     perform read-next-with-kept-lock
+                when 5     perform start-not-less-than
+                when 6     perform write-record
+                when 7     perform rewrite-record
+                when 8     perform delete-record
+                when 9     perform unlock-file
+                when other go to ent-ry
+           end-evaluate.
+           go to ent-ry.
+
+       wrap-up.
+           close stock-file.
+           move "----Closed----" to open-mode.
+           move "------Closed" to last-operation.
+           perform status-check.
+           display hyphen-line at 2101 upon crt-under.
+           display status-line at 2101 upon crt-under.
+
+       endit.
+           display "Do you wish to restart (Y/N) [ ]"
+               at 2424 upon crt-under.
+           accept yesno at 2454.
+           evaluate yesno
+                    when "Y"      go to main
+                    when "y"      go to main
+                    when "N"      exit program
+                    when "n"      exit program
+                    when other    go to endit
+           end-evaluate.
+
+      ***********************************************************
+      * File Handling Routines                                  *
+      ***********************************************************
+
+       read-on-key.
+           move "Read on key" to last-operation.
+           perform move-key-from-screen-to-rec.
+           read stock-file.
+           perform status-check.
+           perform move-from-rec-to-screen.
+           display stock-01.
+
+       read-next.
+           move "--Read Next" to last-operation.
+           read stock-file next.
+           perform status-check.
+           perform move-from-rec-to-screen.
+           display stock-01.
+
+       read-with-kept-lock.
+           move "Read k lock" to last-operation.
+           perform move-key-from-screen-to-rec.
+           read stock-file with kept lock.
+           perform status-check.
+           perform move-from-rec-to-screen.
+           display stock-01.
+
+       read-next-with-kept-lock.
+           move "Rd next kl-" to last-operation.
+           read stock-file next with kept lock.
+           perform status-check.
+           perform move-from-rec-to-screen.
+           display stock-01.
+
+       start-not-less-than.
+           move "Start not <" to last-operation.
+           perform move-key-from-screen-to-rec.
+           start stock-file key not less than stock-key.
+           perform status-check.
+
+       write-record.
+           move "---Write---" to last-operation.
+           perform move-from-screen-to-rec.
+           write stock-record.
+           perform status-check.
+
+       rewrite-record.
+           move "--Rewrite--" to last-operation.
+           perform move-from-screen-to-rec.
+           rewrite stock-record.
+           perform status-check.
+
+       delete-record.
+           move "--Delete---" to last-operation.
+           perform move-key-from-screen-to-rec.
+           delete stock-file.
+           perform status-check.
+
+       unlock-file.
+           move "00" to file-status.
+           move "--Unlock---" to last-operation.
+           unlock stock-file.
+           perform status-check.
+
+      ***********************************************************
+      *    File Status Checking Routines.                       *
+      ***********************************************************
+
+       status-check.
+           move status-1 to stat-1
+           move status-2 to stat-2
+           evaluate status-1
+               when  "0"
+                  move "----------Successful" to was-it-successful
+               when "1"
+                  move "---------End of file" to was-it-successful
+               when "2"
+                  move "---------Invalid Key" to was-it-successful
+               when "9"
+                  perform look-up-error thru error-end
+           end-evaluate.
+
+      ***********************************************************
+      *     Look Up Error Number                                *
+      ***********************************************************
+
+       look-up-error.
+           move low-values to status-1.
+           move binary-status to stat-2.
+           evaluate stat-2
+           when 002
+               move "-------File not open" to was-it-successful
+           when 007
+               move "Disk space exhausted" to was-it-successful
+           when 013
+               move "------File not found" to was-it-successful
+           when 024
+               move "----------Disk error" to was-it-successful
+           when 041
+               move "---Corrupt ISAM file" to was-it-successful
+           when 065
+               move "---------File locked" to was-it-successful
+           when 068
+               move "-------Record locked" to was-it-successful
+           when 139
+               move "Record inconsistency" to was-it-successful
+           when 146
+               move "---No current record" to was-it-successful
+           when 180
+               move "------File malformed" to was-it-successful
+           when 208
+               move "-------Network error" to was-it-successful
+           when 213
+               move "------Too many locks" to was-it-successful
+           end-evaluate.
+       error-end.
+           exit.
+
+
+      ***********************************************************
+      *     Move data to and from the screen                    *
+      ***********************************************************
+
+       move-key-from-screen-to-rec.
+          move stock-01-code to stock-key.
+
+       move-from-screen-to-rec.
+          move stock-01-code to stock-key.
+          move stock-01-description-1 to stock-description-1.
+          move stock-01-description-2 to stock-description-2.
+          move stock-01-description-3 to stock-description-3.
+          move stock-01-held to stock-held.
+          move stock-01-cost to stock-cost.
+
+       move-from-rec-to-screen.
+          move stock-key to stock-01-code.
+          move stock-description-1 to stock-01-description-1.
+          move stock-description-2 to stock-01-description-2.
+          move stock-description-3 to stock-01-description-3.
+          move stock-held to stock-01-held.
+          move stock-cost to stock-01-cost.
+
+      ***********************************************************
+      * Date and Time Routines                                  *
+      ***********************************************************
+
+       display-date.
+          move temp-day to days.
+          move temp-month to month.
+          move temp-year to year.
+          display date-to-day at 0369.
+
+       display-time.
+          move temp-hours to hours.
+          move temp-mins to mins.
+          display up-to-date-time at 0469.

Microsoft COBOL v45/DEMO/MUDEMO/STOCKOUT.CBL

@@ -0,0 +1,374 @@
+      $set ans85 noosvs mf
+      ************************************************************
+      *                                                          *
+      *              (C) Micro Focus Ltd. 1989                   *
+      *                                                          *
+      *                     STOCKOUT.CBL                         *
+      *                                                          *
+      *                      MULTI-USER                          *
+      *                      ==========                          *
+      *                DEMONSTRATION PROGRAM                     *
+      *                =====================                     *
+      *                                                          *
+      *  This program demonstrates the file and record locking   *
+      *       facilities of this MULTI-USER COBOL.  This       *
+      *    subprogram, which is called from MUDEMO, locks the    *
+      *  whole data file MUSTOCK.DAT, because the access mode    *
+      *                    is output only.                       *
+      *                                                          *
+      ************************************************************
+
+       special-names.
+          console is crt.
+       input-output section.
+       file-control.
+           select stock-file assign "MUSTOCK.DAT"
+                organization indexed
+                access dynamic
+                record key stock-key
+                status file-status
+                lock mode automatic.
+      /
+       data division.
+
+      ***********************************************************
+      * FILE DEFINITION                                         *
+      ***********************************************************
+
+       file section.
+       fd  stock-file.
+       01  stock-record.
+           03  stock-key                        pic 9(06).
+           03  stock-data.
+               05  stock-description-1          pic x(53).
+               05  stock-description-2          pic x(53).
+               05  stock-description-3          pic x(53).
+               05  stock-held                   pic 9(06).
+               05  stock-cost                   pic 9(06)v99.
+      /
+       working-storage section.
+       01     stock-00   .
+           03    stock-00-0101 pic x(0080) value "----------------------
+      -    "----------------------------------------------------------".
+           03    stock-00-0201 pic x(0001) value "|".
+           03 filler           pic x(0078).
+           03    stock-00-0280 pic x(0001) value "|".
+           03    stock-00-0301 pic x(0001) value "|".
+           03 filler           pic x(0031).
+           03    stock-00-0333 pic x(0011) value " Acme Inc. ".
+           03 filler           pic x(0020).
+           03    stock-00-0364 pic x(0017) value "Date   /  /     |".
+           03    stock-00-0401 pic x(0001) value "|".
+           03 filler           pic x(0031).
+           03    stock-00-0433 pic x(0011) value "===========".
+           03 filler           pic x(0020).
+           03    stock-00-0464 pic x(0017) value "Time   :        |".
+           03    stock-00-0501 pic x(0001) value "|".
+           03 filler           pic x(0027).
+           03    stock-00-0529 pic x(0020) value "Stock Control System".
+           03 filler           pic x(0031).
+           03    stock-00-0580 pic x(0001) value "|".
+           03    stock-00-0601 pic x(0001) value "|".
+           03 filler           pic x(0027).
+           03    stock-00-0629 pic x(0020) value "====================".
+           03 filler           pic x(0031).
+           03    stock-00-0680 pic x(0001) value "|".
+           03    stock-00-0701 pic x(0001) value "|".
+           03 filler           pic x(0078).
+           03    stock-00-0780 pic x(0001) value "|".
+           03    stock-00-0801 pic x(0001) value "|".
+           03 filler           pic x(0078).
+           03    stock-00-0880 pic x(0001) value "|".
+           03    stock-00-0901 pic x(0025) value "|  Stock Code    [
+      -    "  ]".
+           03 filler           pic x(0054).
+           03    stock-00-0980 pic x(0001) value "|".
+           03    stock-00-1001 pic x(0001) value "|".
+           03 filler           pic x(0078).
+           03    stock-00-1080 pic x(0001) value "|".
+           03    stock-00-1101 pic x(0022) value "|  Stock Description [
+      -    "".
+           03 FILLER           PIC X(0053).
+           03    STOCK-00-1176 PIC X(0005) VALUE "]   |".
+           03    stock-00-1201 pic x(0001) value "|".
+           03 filler           pic x(0020).
+           03    stock-00-1222 pic x(0001) value "[".
+           03 filler           pic x(0053).
+           03    stock-00-1276 pic x(0005) value "]   |".
+           03    stock-00-1301 pic x(0001) value "|".
+           03 filler           pic x(0020).
+           03    stock-00-1322 pic x(0001) value "[".
+           03 filler           pic x(0053).
+           03    stock-00-1376 pic x(0005) value "]   |".
+           03    stock-00-1401 pic x(0001) value "|".
+           03 filler           pic x(0078).
+           03    stock-00-1480 pic x(0001) value "|".
+           03    stock-00-1501 pic x(0025) value "|  Stock Held    [
+      -    "  ]".
+           03 filler           pic x(0054).
+           03    stock-00-1580 pic x(0001) value "|".
+           03    stock-00-1601 pic x(0001) value "|".
+           03 filler           pic x(0078).
+           03    stock-00-1680 pic x(0001) value "|".
+           03    stock-00-1701 pic x(0028) value "|  Cost per Unit [
+      -    "     ]".
+           03 filler           pic x(0051).
+           03    stock-00-1780 pic x(0001) value "|".
+           03    stock-00-1801 pic x(0001) value "|".
+           03 filler           pic x(0078).
+           03    stock-00-1880 pic x(0001) value "|".
+           03    stock-00-1901 pic x(0001) value "|".
+           03 filler           pic x(0078).
+           03    stock-00-1980 pic x(0001) value "|".
+           03    stock-00-2101 pic x(0080) value "----------------------
+      -    "----------------------------------------------------------".
+           03    stock-00-2201 pic x(0040)
+                 value "-----Open Mode----Lock Mode--Last Operat".
+           03    stock-00-2241 pic x(0040)
+                 value "ion-----------Outcome------File Status--".
+           03 filler           pic x(1037).
+
+       01     stock-01    redefines    stock-00   .
+           03 filler           pic x(0658).
+           03   stock-01-code           pic 9(0006).
+           03 filler           pic x(0158).
+           03   stock-01-description-1  pic x(0053).
+           03 filler           pic x(0027).
+           03   stock-01-description-2  pic x(0053).
+           03 filler           pic x(0027).
+           03   stock-01-description-3  pic x(0053).
+           03 filler           pic x(0103).
+           03   stock-01-held           pic 9(0006).
+           03 filler           pic x(0154).
+           03   stock-01-cost           pic $$$$$9.99.
+           03 filler           pic x(0579).
+           03   choice                  pic 9.
+
+      ***********************************************************
+      * File Status Variables                                   *
+      ***********************************************************
+
+       01  file-status.
+           03  status-1                 pic x.
+           03  status-2                 pic x.
+
+       01  binary-status redefines file-status pic 9(04) comp.
+
+      ***********************************************************
+      * Date and Time Variables                                 *
+      ***********************************************************
+
+       01  date-to-day.
+           03  days                     pic 99.
+           03  filler                   pic x.
+           03  month                    pic 99.
+           03  filler                   pic x.
+           03  year                     pic 99.
+
+       01  up-to-date-time.
+           03  hours                    pic 99.
+           03  filler                   pic x.
+           03  mins                     pic 99.
+
+       01  temp-date.
+           03  temp-year                pic xx.
+           03  temp-month               pic xx.
+           03  temp-day                 pic xx.
+       01  temp-time.
+           03  temp-hours               pic 99.
+           03  temp-mins                pic 99.
+           03  temp-rest                pic 9999.
+
+      ***********************************************************
+      * Information Line                                        *
+      ***********************************************************
+
+       01  status-line.
+           03  filler                   pic x(02).
+           03  open-mode                pic x(14).
+           03  filler                   pic x(02).
+           03  lock-mode                pic x(09)
+                   value "---------".
+           03  filler                   pic x(03).
+           03  last-operation           pic x(11).
+           03  filler                   pic x(03).
+           03  was-it-successful        pic x(20).
+           03  filler                   pic x(08).
+           03  error-code.
+               05 stat-1                pic x.
+               05 filler                pic x.
+               05 stat-2                pic 9(03) value 0.
+
+       01  hyphen-line                  pic x(80)
+               value all "-".
+
+       01  yesno                        pic x.
+
+       01    inpopt.
+           03  filler         pic x(26).
+           03  inpopt-00      pic x(0030)
+               value " 1. Write record  2. Exit".
+
+      **********************************************************
+      * Program for an input-only file                         *
+      **********************************************************
+
+       procedure division.
+       main.
+           initialize choice
+                      stock-01.
+           display space.
+           display stock-00.
+           display inpopt at 2301.
+           display "Input Choice [ ]" at 2433 upon crt-under.
+           open output stock-file.
+           move "---Open Output" to open-mode.
+           move "Open Output" to last-operation.
+           perform status-check.
+           if was-it-successful not = "----------Successful"
+               move "----Closed----" to open-mode
+               display hyphen-line at 2201 upon crt-under
+               display status-line at 2201 upon crt-under
+               go to endit.
+
+      ***********************************************************
+      * MAIN LOOP                                               *
+      ***********************************************************
+
+       ent-ry.
+           accept temp-date from date.
+           perform display-date.
+           accept temp-time from time.
+           perform display-time.
+           display hyphen-line at 2201 upon crt-under
+           display status-line at 2201 upon crt-under
+           accept stock-01.
+           evaluate choice
+                  when 1 perform write-rec
+                  when 2 go to wrap-up
+           end-evaluate.
+           go to ent-ry.
+
+      ***********************************************************
+      * Close down paragraphs                                   *
+      ***********************************************************
+
+       wrap-up.
+           close stock-file.
+           move "----Closed----" to open-mode.
+           move "--Close----" to last-operation.
+           perform status-check.
+           display hyphen-line at 2201 upon crt-under.
+           display status-line at 2201 upon crt-under.
+
+
+       endit.
+           display "Do you wish to restart (Y/N) [ ]"
+               at 2424 upon crt-under.
+           accept yesno at 2454.
+           if yesno = "Y" or "y"
+               go to main
+           else if yesno = "N" or "n"
+                   exit program
+                else
+                   go to endit
+           end-if.
+
+      ***********************************************************
+      * File Handling Routines                                  *
+      ***********************************************************
+
+       write-rec.
+           move "------Write" to last-operation.
+           perform move-from-screen-to-rec.
+           write stock-record.
+           perform status-check.
+
+      ***********************************************************
+      *    File status checking routines.                       *
+      ***********************************************************
+
+       status-check.
+           move status-1 to stat-1
+           move status-2 to stat-2
+           evaluate status-1
+             when "0"
+                  move "----------Successful" to was-it-successful
+             when "1"
+                  move "---------End of file" to was-it-successful
+             when "2"
+                  move "---------Invalid Key" to was-it-successful
+             when "9"
+                  perform look-up-error thru error-end
+           end-evaluate.
+      ***********************************************************
+      *     Look up error number                                *
+      ***********************************************************
+
+       look-up-error.
+           move low-values to status-1.
+           move binary-status to stat-2.
+           evaluate stat-2
+                when   002
+                   move "-------File not open" to was-it-successful
+                when   007
+                   move "Disk space exhausted" to was-it-successful
+                 when  013
+                   move "------File not found" to was-it-successful
+                 when  024
+                   move "----------Disk error" to was-it-successful
+                 when  041
+                   move "---Corrupt ISAM file" to was-it-successful
+                 when  065
+                   move "---------File locked" to was-it-successful
+                 when  068
+                   move "-------Record locked" to was-it-successful
+                 when  139
+                   move "Record inconsistancy" to was-it-successful
+                 when  146
+                   move "---No current record" to was-it-successful
+                 when  180
+                   move "------File malformed" to was-it-successful
+                 when  208
+                   move "-------Network error" to was-it-successful
+                 when  213
+                   move "------Too many locks" to was-it-successful
+           end-evaluate.
+       error-end.
+           exit.
+
+
+      ***********************************************************
+      *     Move data to and from the screen                    *
+      ***********************************************************
+
+       move-from-screen-to-rec.
+          move stock-01-code to stock-key.
+          move stock-01-description-1 to stock-description-1.
+          move stock-01-description-2 to stock-description-2.
+          move stock-01-description-3 to stock-description-3.
+          move stock-01-held to stock-held.
+          move stock-01-cost to stock-cost.
+
+       move-from-rec-to-screen.
+          move stock-key to stock-01-code.
+          move stock-description-1 to stock-01-description-1.
+          move stock-description-2 to stock-01-description-2.
+          move stock-description-3 to stock-01-description-3.
+          move stock-held to stock-01-held.
+          move stock-cost to stock-01-cost.
+
+      ***********************************************************
+      * Date and Time Routines                                  *
+      ***********************************************************
+
+       display-date.
+          move temp-day to days.
+          move temp-month to month.
+          move temp-year to year.
+          display date-to-day at 0369.
+
+       display-time.
+          move temp-hours to hours.
+          move temp-mins to mins.
+          display up-to-date-time at 0469.

Microsoft COBOL v45/DEMO/NESTED.CBL

@@ -0,0 +1,69 @@
+      $set ans85 nestcall noosvs mf
+      *******************************************************************
+      *                                                                 *
+      *                                                                 *
+      *                  (C) Micro Focus Ltd. 1989                      *
+      *                                                                 *
+      *                         NESTED.CBL                              *
+      *                                                                 *
+      *  This demo shows how to structure a nested COBOL program.       *
+      *  There are two nested programs NEST1 and NEST2 each of which    *
+      *  have their own local data. It also demonstrates a simple use   *
+      *  of GLOBAL data.                                                *
+      *                                                                 *
+      *******************************************************************
+       identification division.
+       program-id.   main.
+       working-storage section.
+       01 counter is global            pic 9999.
+       01 local-item                   pic x(20) value all 'a'.
+
+       procedure division.
+           move 1 to counter.
+           display 'in main program, '.
+           display '            value of global counter = ', counter.
+           display '            value of ''local-item'' = ', local-item.
+           display 'calling nest1'.
+           display ' '.
+
+           call 'nest1'.
+           display 'back in main program, '.
+           display '            value of global counter = ', counter.
+           display '            value of ''local-item'' = ', local-item.
+           display ' '.
+
+           display 'calling nest2, '.
+           call 'nest2'.
+           display 'back in main program, '.
+           display '            value of global counter = ', counter.
+           display '            value of ''local-item'' = ', local-item.
+           display ' '.
+           stop run.
+
+      * Here is the first nested program.
+      * Nested programs can access any GLOBAL data and have their own
+      * local data.
+       identification division.
+       program-id.   nest1.
+       working-storage section.
+       01 local-item                   pic x(20) value all 'b'.
+       procedure division.
+           add 1 to counter.
+           display 'in nest1,   adding one to counter '.
+           display '            value of ''local-item'' = ', local-item.
+           display ' '.
+       end program nest1.
+
+      * here is the second nested program
+       identification division.
+       program-id.   nest2.
+       working-storage section.
+       01 local-item                   pic x(20) value all 'c'.
+       procedure division.
+           add 1 to counter.
+           display 'in nest2,   adding one to counter '.
+           display '            value of ''local-item'' = ', local-item.
+           display ' '.
+       end program nest2.
+
+       end program main.