      $SET DEFAULTBYTE"00" DIALECT"MF" CHARSET"ASCII"
      *SET INITCALL"CBL_DEBUGBREAK"
      *>==============================================================
      *> Use directives at least: /CHARSET"ASCII"
      *>                          /DIALECT"MF" /DEFAULTBYTE"00"
      *>==============================================================
      *> FLAM-SUBSYS MF-Subsystem exit for FLAM-subsystem
      *>==============================================================
      *>
      *> Wie im z/os wird der Exit bei den diversen Funktionen auf-.
      *> aufgerufen
      *>
      *> Implementiert sind die Aufrufe
      *>
      *> - dd-alloc-pre
      *> - open
      *> - close
      *> - write sequential
      *> - read sequential
      *>
      *> Historie:
      *> --------
      *>
      *> V1.00        Neues Programm
      *>              9.2010 Eu
      *>***************************************************************
      *> Copyright (c) 2010 by limes datentechnik gmbh
      *>                       Louisenstr. 23
      *>                       61348 Bad Homburg
      *>***************************************************************

      *> Storage sequence:
      *>                  12 34 56 78     MVS COMP
      *>                  78 56 34 21     MF  COMP-5
      *>==============================================================
      *> Note that subsystem exit is always named as MFJYssss, where
      *> ssss is the subssystem name (1st sub-parameter of SUBSYS=)
      *>==============================================================

       identification division.
       program-id. MFJYFLAM.
       environment division.
       data division.
       working-storage section.
       01  ws-ptr          usage is procedure-pointer.
      *--- temp pointer for addressing MVS control blocks
       01  ws-tmpptr                   pointer.
       01  ws-tmpptr-r       redefines ws-tmpptr
                                       pic  x(04) comp-x.
      *
       77  OPERATION       PIC X(6).
       77  ZAHL-DISPLAY    PIC ZZZ,ZZZ,ZZZ,ZZZ,ZZZ,ZZ9.
       77  WERWARS         PIC X(8).
       01  textdisplay.
           05  textdisp    PIC X(8).
           05  filler      PIC X.
      *
       77  flmopn-input    pic s9(8) comp value 0.
       77  flmopn-output   pic s9(8) comp value 1.
      *
       01  SS-FUNCTION.
           05 SS-FC        PIC XX.
           05 FILLER       PIC XX VALUE LOW-VALUE.
      *
      *  to analyse subsystem parameter
      *
       77 sparm-parm       pic x(8) value spaces.
       77 sparm-value      pic x(8) value spaces.
       77 sparm-len        pic 999  value 264.
       77 sparm-ctr        pic 999  value zero.
       77 sparm-delim      pic x.
      *
      *  to identify the flam-fileid
      *
       01 token-table occurs 300 times indexed by sstkn.
          05 sstoken       pic xx    comp-x value ZERO.
          05 flig10        pic x     value space.
             78 flig10-yes value "1". *> ig10 is set
          05 fltag         pic x.
             78 fltag-dd value  "1".  *> use flamddn for flamfile
             78 fltag-ds value  "2".  *> use flamdsn for flamfile
          05 flamid        pic x(4)  value low-values.
          05 flamddn       pic x(8)  value spaces.
          05 flamdsn       pic x(44) value spaces.
      *
      *  used for every flam-call
      *
       77  flam-fileid     pic  x(4).
       77  flam-retcode    pic  s9(8) comp.
           88 flamrc-ok  value  0.
           88 flamrc-eof value  2.
       01  flam-rc-bytes redefines flam-retcode.
           05 flam-rc-b1   pic  x.
              88 dmserror  value high-value.
              88 fioerror  value x'f0'.
           05 flam-rc-b2   pic  x.
           05 flam-rc-b3   pic  x.
           05 flam-rc-b4   pic  x.
              88 file-not-found value x'1f'.
      *
      *  parameter fuer flmopn
      *
       77  lastpar   pic  9(8)  comp value 1.
       77  openmode  pic  9(8)  comp value 0.
       77  statis    pic  9(8)  comp value 0.
       77  ddname    pic  x(8)  value 'FLAMFILE'.
      *
      *    parameter fuer flmopf
      *
       77  version                    pic s9(8) comp.
           88  version-1                  value 100.
           88  version-1-1                value 101.
           88  version-2                  value 200.
           88  version-3                  value 300.
           88  version-4                  value 400.
       77  flamcode                   pic s9(8) comp value 1.
           88  ebc-dic                    value 0.
           88  ascii                      value 1.
       77  compmode                   pic s9(8) comp value 2.
           88  cx8                        value 0.
           88  cx7                        value 1.
           88  vr8                        value 2.
           88  adc                        value 3.
       77  maxbuff                    pic s9(8) comp value 32768.
       77  header                     pic s9(8) comp value 1.
           88  noheader                   value 0.
           88  fileheader                 value 1.
       77  maxrec                     pic s9(8) comp value 255.
       77  blkmode                    pic s9(8) comp value 1.
           88  unblocked                  value 0.
           88  blocked                    value 1.
       77  exk20                      pic x(8)
                                          value spaces.
       77  exd20                      pic x(8)
                                          value spaces.
      *
      *    parameter fuer flmopd
      *
       77  opd-namelen                pic s9(8) comp.
       77  opd-filename               pic x(54).
       77  opd-dsorg                  pic s9(8) comp.
       77  opd-recform                pic s9(8) comp.
       77  opd-maxsize                pic s9(8) comp.
       77  opd-recdelim               pic x(4) value low-values.
       77  opd-blksize                pic s9(8) comp.
       77  opd-closdisp               pic s9(8) comp
                                          value 0.
       77  opd-device                 pic s9(8) comp
                                          value 0.
      *
      *    schluesselbeschreibung der flamfile
      *
       01  keydesc-flamf.
         05  keyflags                 pic s9(8) comp
                                          value 1.
         05  keyparts                 pic s9(8) comp
                                          value 0.
         05  keyentry1.
           10  keypos1                pic s9(8) comp
                                          value 1.
           10  keylen1                pic s9(8)
                                          value 9.
           10  keytype1               pic s9(8)
                                          value 1.
         05  keyentry-2-bis-8    occurs 7 times.
           10  keypos                 pic s9(8) comp.
           10  keylen                 pic s9(8) comp.
           10  keytype                pic s9(8) comp.
      *
      *    parameter fuer flmphd/flmghd
      *
       77  namelen-orig               pic 9(8)  comp.
       77  filename-orig              pic x(54) value spaces.
       77  dsorg-orig                 pic 9(8)  comp value 0.
       77  recform-orig               pic 9(8)  comp value 1.
       77  recsize-orig               pic 9(8)  comp value 80.
       77  recdelim-orig              pic x(4)  value low-value.
       77  blksize-orig               pic 9(8)  comp value 0.
       77  prctrl-orig                pic 9(8)  comp value 0.
           88  no-control-char            value 0.
           88  asa-control-char           value 1.
           88  mach-control-char          value 2.
       77  system-orig                pic x(2)  value x'0108'.
       77  lastpar-phd                pic 9(8)  comp value 0.
           88  last-parameter-phd         value 0.
      *
      *    schluesselbeschreibung der originaldatei
      *
       01  keydesc-orig.
         05  keyflags-orig            pic 9(8)  comp value 0.
         05  keyparts-orig            pic 9(8)  comp value 0.
         05  keyentry1-orig.
           10  keypos1-orig           pic 9(8)  comp value 0.
           10  keylen1-orig           pic 9(8)  comp value 0.
           10  keytype1-orig          pic s9(8) comp value 1.
         05  keyentry-2-bis-8-orig        occurs 7 times
                                          indexed by keydesc-index.
           10  keypos-orig            pic s9(8) comp sync.
           10  keylen-orig            pic s9(8) comp sync.
           10  keytype-orig           pic s9(8) comp sync.
      *
      *  Bereiche fuer flmcls/flmflu (werden nicht ausgewertet)
      *
       77  cputime                    pic 9(8) comp.
       77  orgrecs                    pic 9(8) comp.
       77  cmprecs                    pic 9(8) comp.
       01  bytefeld.
           05  byteofl                pic 9(8) comp.
           05  bytes                  pic 9(8) comp.
       01  bytecnt redefines bytefeld pic s9(18) comp.
       01  cmpbyfeld.
           05  cmpbyofl               pic 9(8) comp.
           05  cmpbytes               pic 9(8) comp.
       01  cmpbycnt redefines cmpbyfeld
                                      pic s9(18) comp.
      *
      *  Bereiche fuer flmput/flmget
      *
       77  datlen                     pic  9(8) comp.
       77  datbufflen                 pic  9(8) comp value 80.
      *
      *  Bereiche fuer MVSGETCT
      *
       01  GETCT-DATA.
       COPY MVSGETCT.CPY REPLACING ==(TAG)== BY ==GETCT==.
      *=============================================================
       linkage section.
       01  fcd.
       copy mvsfcd.cpy  replacing ==(TAG)== by ==fcd==.
       copy mfjdsxit.cpy replacing ==()== by ==sxit==.
       01 subsys-val                  pic x(264).
       01 ss-dsname                   pic x(44).
       01 ls-record                   pic x.
      *=============================================================
       procedure division using by reference sxit.
       flamsub section.
       flamsub-start.
         evaluate sxit-I-event
           when sxit-I-event-dd-alloc-pre
             *>=======================================================
             *> DD is about to be allocated,
             *> SUBSYS parameter are passed
             *>=======================================================
             *> JCL SUBSYS specification as follows:
             *>  //ddname DD SUBSYS=(FLAM,"MO=ADC,FLAMDD=..."),DSN=...
             *>=======================================================
             *> look if we are needed
             set address of ss-dsname to sxit-U-ds-name-ptr
             move low-values to getct-data
             move spaces     to getct-mem-name
                                getct-mvs-dsname
             move zero       to namelen-orig
             inspect ss-dsname tallying
                     namelen-orig for characters before initial x"00"
             move ss-dsname(1:namelen-orig) to getct-mvs-dsname
             call "MVSGETCT" using GETCT-DATA
             *> VSAM KSDS is unsupported, we do nothing
             if GETCT-VSAM-KEYED-88
               move sxit-U-action-continue to sxit-U-action
               move zero to return-code
               exit program
             end-if
      *---------------------------------------------------------------
             *> sequential file is used, go on
             *> Load FLAM-lib
             *> set ws-ptr to entry "flamup.so"
             *> let the subsystem do all by itself
             move sxit-U-action-call-4-all-rel to sxit-U-action
             *> find an empty slot in table
             set sstkn to 1
             search token-table when sstoken(sstkn) = ZERO
             end-search
             *> remind for later use
             move sxit-I-dd-token  to sstoken(sstkn)
             move sxit-I-ddname    to flamddn(sstkn)
             move getct-mvs-dsname to flamdsn(sstkn)
             *> set 'use dsn' first
             move fltag-ds         to fltag(sstkn)
             *> analyse subsystem-parameter, if any
             set address of subsys-val to sxit-U-subsys-ptr
             if  sxit-U-subsys-len > 5
               perform flamsub-analyse
             end-if
      *---------------------------------------------------------------
           when sxit-I-event-dd-activity
             *>=======================================================
             *> I/O activities come here
             *>=======================================================
             set address of fcd to sxit-data-dd-act-subsys-fcd-ptr
             *> get entry in token-table
             set sstkn to 1
             search token-table at end go to flamsub-end
                    when sstoken(sstkn) = sxit-I-dd-token
             end-search
             move flamid(sstkn) to flam-fileid
             move zero          to flam-retcode
             evaluate sxit-data-dd-act-subsys-fcd-fc
               when x'FAF3'
                 *>===================================================
                 *> Write a record
                 *>===================================================
                 move fcd-current-rec-len to datlen
                 set address of ls-record to fcd-record-address
                 call "FLMPUT" using flam-fileid, flam-retcode,
                                     datlen, ls-record
                 if  not flamrc-ok
                  then move "FLMPUT" to operation
                      perform flam-error
                      exit program
                 end-if
                 move zero   to return-code
               when x'FAF5'
                 *>===================================================
                 *> Read a record
                 *>===================================================
                 set address of ls-record  to fcd-record-address
                 move fcd-max-rec-length   to datbufflen
                 call "FLMGET" using flam-fileid, flam-retcode,
                                     datlen, ls-record, datbufflen
                 if flamrc-ok
                  then    move x'30'  to fcd-status-key-1
                          move x'30'  to fcd-status-key-2
                          move datlen to fcd-current-rec-len
                          move zero   to return-code
                  else
                    if flamrc-eof
                     then
                          move x'31' to fcd-status-key-1
                          move x'30' to fcd-status-key-2
                          move zero  to fcd-current-rec-len
                          move zero  to return-code
                     else
                          move "FLMGET" to operation
                          perform flam-error
                          move x'39' to fcd-status-key-1
                          move x'146' to fcd-status-key-2 *>no record
                          move zero  to fcd-current-rec-len
                    end-if
                 end-if
                 move zero  to return-code
               when x'FA01'   *> Open Ouput
                 *>===================================================
                 *> Open Output
                 *>===================================================
                 move flmopn-output  to openmode
                 move 1              to flamcode *> ascii
                 move 2              to compmode *> vr8
                 move 1              to header
                 move 255            to maxrec
                 move 65536          to maxbuff
                 *>
                 perform flam-open
                 *>  fill parameter for flmphd
                 move fcd-recording-mode to recform-orig
                 move fcd-max-rec-length to recsize-orig
                 move zero               to blksize-orig
                 move flamdsn(sstkn)     to filename-orig
                 move zero               to namelen-orig
                 inspect filename-orig tallying
                     namelen-orig for characters before initial " "
                 *>
                 call "FLMPHD" using flam-fileid, flam-retcode,
                                     namelen-orig, filename-orig,
                                     dsorg-orig, recform-orig,
                                     recsize-orig, recdelim-orig,
                                     keydesc-orig, blksize-orig,
                                     prctrl-orig, system-orig,
                                     lastpar-phd
                 move flam-fileid to flamid(sstkn)
                 move zero        to return-code
                 *> fuer Fehlermeldungen FLAMFILE-DSN merken
                 move spaces                      to flamdsn(sstkn)
                 move opd-filename(1:opd-namelen) to flamdsn(sstkn)
               when x'FA00'   *> Open Input
                 *>===================================================
                 *> Open Input
                 *>===================================================
                 move flmopn-input to openmode
                 perform flam-open
                 *> fuer Fehlermeldungen FLAMFILE-DSN merken
                 move spaces                      to flamdsn(sstkn)
                 move opd-filename(1:opd-namelen) to flamdsn(sstkn)
                 *>
                 move 54  to namelen-orig
                 call "FLMGHD" using flam-fileid, flam-retcode,
                                     namelen-orig, filename-orig,
                                     dsorg-orig, recform-orig,
                                     recsize-orig, recdelim-orig,
                                     keydesc-orig, blksize-orig,
                                     prctrl-orig, system-orig,
                                     lastpar-phd
                 move flam-fileid to flamid(sstkn)
                 move zero        to return-code
               when x'FA80'   *> Close
               when x'FA81'   *> Close with Lock
               when x'FA82'   *> Close with No Rewind
               when x'FA84'   *> Close Reel/Unit
               when x'FA85'   *> Close Reel/Unit for Removal
               when x'FA86'   *> Close Reel/Unit with no Rewind
                 *>===================================================
                 *> Close file
                 *>===================================================
                 call "FLMCLS" using flam-fileid flam-retcode cputime
                                     orgrecs bytes byteofl
                                     cmprecs cmpbytes cmpbyofl
                 move low-values  to flamid(sstkn)
                 move ZERO        to sstoken(sstkn)
                                     return-code
                 move x'30'       to fcd-status-key-1
                 move x'30'       to fcd-status-key-2
               when other
                 *>===================================================
                 *> Unsupported Function
                 *>===================================================
                 move sxit-data-dd-act-subsys-fcd-fc to ss-fc
                 call "AUFB" using ss-function textdisplay
                 display 'FLAM-sub. Unsupported function: '
                         textdisplay(1:4) upon console
                 display 'FLAM-sub. DSN: ' flamdsn(sstkn) upon console
                 move 12 to return-code
             end-evaluate
           when sxit-I-event-dd-dealloc-pre
           when other
                 *>===================================================
                 *> Ignore all others
                 *>===================================================
                continue
         end-evaluate.
       flamsub-end.
         goback.

      *================================================================
       flamsub-analyse.
         *>=======================================================
         *> Analyse subsystem-parameterstring.
         *> Beispiel:
         *>  FLAM,MO=ADC,FLAMDD=OTTO,FLAMF(A.B.C),IG10,...
         *>=======================================================
         *> Achtung: nur IG10 und FLAMDDN unterstuetzt
         *>=======================================================
         move 6 to sparm-ctr   *> first parameter start at column 6
         move sxit-U-subsys-len to sparm-len
         perform until sparm-ctr > sparm-len
      *   unstring parmstring delimited by space or "=" or "(" or ","
          unstring subsys-val delimited
                              by "=" or "(" or "," or all low-value
                   into sparm-parm delimiter in sparm-delim
                   with pointer sparm-ctr
          end-unstring
          evaluate sparm-delim
            when ","
            when " "
      *      Stellungs-Parameter
             if sparm-parm = "IG10"
               move flig10-yes to flig10(sstkn)
             end-if
            when other
      *      Schluesselwort-Parameter
              move spaces      to sparm-value
              unstring subsys-val delimited
                                  by all low-value or "," or ")"
                       into sparm-value
                       with pointer sparm-ctr
              end-unstring
              if sparm-parm(1:5) = "FLAMD"
                move sparm-value to flamddn(sstkn)
                move fltag-dd    to fltag(sstkn)
              end-if
          end-evaluate
         end-perform.
       flamsub-analyse-exit.
         exit.
      *================================================================
       flam-open.
           *>==========================================================
           *> do the flam open for input or output
           *>==========================================================
           if fltag(sstkn) = fltag-ds
             move spaces         to ddname
             move flamdsn(sstkn) to opd-filename
           else
             move spaces         to opd-filename
             move flamddn(sstkn)  to ddname
           end-if
           call  "FLMOPN" using flam-fileid, flam-retcode,
                                lastpar, openmode, ddname, statis
           if  not flamrc-ok
              then  move "FLMOPN" to operation
                    perform flam-error
                    move x'39' to fcd-status-key-1
                    move x'02' to fcd-status-key-2  *> not opened
                    exit program
           end-if
           *> statt defaults im c-programm ---------------------
           move 512            to opd-maxsize
           move 4096           to opd-blksize
           move 0              to opd-dsorg
           move 1              to opd-recform
           *>---------------------------------------------------
           move 54             to opd-namelen
           call "FLMOPD" using flam-fileid, flam-retcode,
                               lastpar, opd-namelen, opd-filename,
                               opd-dsorg, opd-recform, opd-maxsize,
                               opd-recdelim, keydesc-flamf, opd-blksize,
                               opd-closdisp, opd-device
           if  not flamrc-ok
             then move "FLMOPD" to operation
                  perform flam-error
                  if fioerror
                    if file-not-found
                    then move x'39' to fcd-status-key-1
                         move x'13' to fcd-status-key-2  *> not found
                    else move x'39' to fcd-status-key-1
                         move x'02' to fcd-status-key-2  *> not opened
                    end-if
                  end-if
                  exit program
           end-if
           call "FLMOPF" using flam-fileid, flam-retcode,
                               version, flamcode, compmode,
                               maxbuff, header, maxrec,
                               keydesc-orig, blkmode,
                               exk20, exd20
           if flamrc-ok
             then move x'30' to fcd-status-key-1
                  move x'30' to fcd-status-key-2
             else move "FLMOPF" to operation
                  perform flam-error
                  move x'39' to fcd-status-key-1
                  move x'02' to fcd-status-key-2  *> not opened
                  exit program
           end-if.
       flam-open-exit.
           exit.
      *================================================================
       flam-error.
           *>==========================================================
           *> FLAM returned an error-code
           *>==========================================================
           if dmserror
             move flam-rc-b3 to fcd-status-key-1
             move flam-rc-b4 to fcd-status-key-2
             move low-value to flam-rc-b1
             move " (MF)"   to werwars
           else
             move " (FLAM)" to werwars
           end-if
           call "AUFB" using flam-retcode textdisplay
           display 'FLAM-sub. Error in operation: ' operation
                   ' RC: ' textdisp werwars upon console
           display 'FLAM-sub. DSN: ' flamdsn(sstkn) upon console.
       flam-error-exit.
           exit.
      *================================================================
