TITLE 'ASMADA9 - READ ADABAS DATA WITH MULTIFETCH'
**********************************************************************
* *
* Description : Reads ADABAS data using multifetch feature *
* *
* Version 8 ACBX and link routine *
* (uses the V8 APLX, ACBX and ABDs) *
* *
* Note ADABDX macro is enhanced version of the one *
* supplied by Software AG. It includes a macro *
* macro parameter TYPE=<buffer_type|EQ> *
* *
***********************************************************************
* *
* RETURN CODES: *
* *
* 0 - SUCCESSFUL *
* 4 - WARNING *
* 8 - ERROR *
* 12 - SERIOUS ERROR *
* 16 - CATASTROPHIC FAILURE *
* *
***********************************************************************
IHASAVER DSECT=YES,SAVER=YES,SAVF4SA=YES,SAVF5SA=YES,TITLE=NO
*
ADACBX DSECT=YES
*
ADABDX TYPE=EQ
*
ADABDX TYPE=FB
ADABDX TYPE=RB
ADABDX TYPE=SB
ADABDX TYPE=VB
ADABDX TYPE=IB
ADABDX TYPE=MB
*
MBDSECT DSECT Multifetch segment as found in MBAREA
MBRECL DS F
MBRESP DS F
MBISN DS F
MBISNQ DS F
*
WORKAREA DSECT
ds Xl(SAVF4SA_LEN)
*
WKSAVSUB DS 18fd Internal routine register save area
*
WKTIMWRK DS 0XL16
WKDBLWRK DS D Doubleword work area
WKDBLWK DS D Doubleword work area
*
WKPRINT DS XL131 Print line
WKTRACE DS CL1 Tracing
DS 0F
WKREENT DS XL256 Reentrant workarea
*
WKEOF DS CL1
DS XL1
DS H
*
DS 0F
OUTDCB DS XL(outfilel) Reentrant DCB and DCBE areas
*
WKWTOPRM WTO TEXT=(R2),MF=L
WKWTOLEN EQU *-WKWTOPRM
*
ADAPAL DS 0F
DS 11F
*
LINKWORK DS XL256 Workarea for ADABAS link routine
APLXLINK DS F Reentrancy token
WKCID DS 0F Adabas command ID
WKCID1 DS X
WKCID23 DS XL2
WKCID4 DS X
WKAADA DS F
WKRETC DS F
WKRECNUM DS F
WKRECCNT DS F
WKBUFCNT DS F
WKDBLWK2 DS XL08 Doubleword work area
*
CB DS XL(ACBXQLL)
*
FB DS XL(FBDXQLL)
DS CL56
*
SB DS XL(SBDXQLL)
DS CL56
*
VB DS XL(VBDXQLL)
DS CL56
*
IB DS XL(IBDXQLL)
DS XL100
*
MB DS XL(MBDXQLL)
MBCOUNT DS F
MBAREA DS (NREC)CL(MISN) 100 * 16 byte ISN areas
*
RB DS XL(RBDXQLL)
RBAREA DS (NREC)CL(LREC) 100 * 96 byte records
*
WORKLEN EQU (*-WORKAREA)
*
LREC EQU 68 LENGTH OF FIELDS IN RECORD
NREC EQU 100 NUMBER OF RECORDS PER CALL
MISN EQU 16 LENGTH OF MULTIFETCH SEGMENTS IN MB
*
print off
SYSSTATE ARCHLVL=2
COPY ASMMSP
LEAVE OPSYN ASM_LEAVE
asmmrel on
print on
*
*
***********************************************************************
* *
* REGISTER EQUATES: *
* *
***********************************************************************
*
YREGS
*
PRINT nogen
*
ASMADA RMODE 24
ASMADA AMODE 31
ASMADA CSECT
J CODE
DC CL8'ASMADA',CL8'&SYSDATC',CL6'&SYSTIME'
*
static loctr set up the static loctr
code loctr followed by the code loctr
*
using savf4sa,r13 Map the save area
stm R14,R12,12(R13)
*
llgtr R12,r15 Base (static loctr)
USING (ASMADA,code),R12
*
lghi R0,WORKLEN+16 Work area size
STORAGE OBTAIN,LENGTH=(0),LOC=24,CHECKZERO=YES GET WORKAREA
cije r15,14,a0002 If already zeroed, bypass this...
lr r10,r1 Hold address
lr R0,R1 Zero work area
lghi R1,WORKLEN+16
xr R14,R14
xr R15,R15
MVCL R0,R14
lr r1,r10 Restore pointer
*
A0002 EQU *
MVC 0(8,R1),=CL8'ASMADAME' spycatcher in memory
MVC 8(8,R1),=CL8'&SYSDATC' assembly date
ahi r1,16 Move pointer past
drop r13
USING WORKAREA,R1
using savf4sa,ASMADA
llgtr r13,r13
stg r13,savf4saprev save current r13
mvc savf4said(4),=a(savf4said_value) set 'F4SA' in area
llgtr R13,r1 Get new workarea into r13
J MAINLINE BEGIN
*
*
CHAIN ds 0h
stg r13,savf4saprev save current r13
llgtr R13,r1 Get new workarea into r13
drop r1
using WORKAREA,r13
using savf4sa,ASMADA
*
***********************************************************************
MAINLINE DS 0H
***********************************************************************
XC WKRETC,WKRETC
*
***********************************************************************
* OPEN MESSAGE FILE *
***********************************************************************
* open message file
LA R14,outfile MODEL DCB
d1 using ihadcb,outdcb
MVC outdcb(outfilel),0(R14)
lay R0,outdcb DCBE ADDRESS
aghi R0,outfile0
sty R0,d1.DCBDCBE
*
LAY R2,OUTDCB
MVC WKREENT(8),OPENPARM
OPEN ((R2),(OUTPUT)),MODE=31,MF=(E,WKREENT)
* ÐI1015
*
USING ADACBX,CB
USING FBBDX,FB
USING RBBDX,RB
USING SBBDX,SB
USING VBBDX,VB
USING IBBDX,IB
USING MBBDX,MB
*
LAY R3,CB
LAY R4,FB
LAY R5,RB
LAY R6,SB
LAY R7,VB
LAY R8,IB
LAY R9,MB
* ÐI1015
ST R3,ADAPAL+00
LA R0,APLXLINK
ST R0,ADAPAL+04
LA R0,LINKWORK
ST R0,ADAPAL+08
STM R4,R9,ADAPAL+12 ADABAS PARAMETER LIST
OI ADAPAL+32,X'80'
*
*
LOAD EPLOC=LINKNAME,ERRET=A0010
OILH R0,MODE31
ST R0,WKAADA
J A0011
A0010 EQU *
WTO 'ASMADA8: ADABAS LINK MODULE NOT LOADED'
MVC WKRETC,=F'16'
J RETURNX
A0011 EQU *
*
*
MVI ACBXVERT,ACBXVERE
MVI ACBXVERN,ACBXVERC
MVC ACBXLEN,=Y(ACBXQLL)
MVC ACBXDBID,DBID300
MVC ACBXFNR,FNR0002
*
MVI WKCID1,C'F'
MVC WKCID23,=X'0001'
MVI WKCID4,C'S'
*
MVI FBDXLOC,C' '
MVC FBDXLEN,=Y(FBDXQLL)
MVI FBDXVERT,ABDXVERE
MVI FBDXVERN,ABDXVERC
MVI FBDXID,ABDXQFB
MVC FBDXSIZE+4(4),=F'56'
*
MVI RBDXLOC,C' '
MVC RBDXLEN,=Y(RBDXQLL)
MVI RBDXVERT,ABDXVERE
MVI RBDXVERN,ABDXVERC
MVI RBDXID,ABDXQRB
MVC RBDXSIZE+4(4),=A(LREC*NREC)
*
MVI MBDXLOC,C' '
MVC MBDXLEN,=Y(MBDXQLL)
MVI MBDXVERT,ABDXVERE
MVI MBDXVERN,ABDXVERC
MVI MBDXID,ABDXQMB
MVC MBDXSIZE+4(4),=A(4+MISN*NREC) ISN QTY THEN MISN AREA
*
MVI SBDXLOC,C' '
MVC SBDXLEN,=Y(SBDXQLL)
MVI SBDXVERT,ABDXVERE
MVI SBDXVERN,ABDXVERC
MVI SBDXID,ABDXQSB
MVC SBDXSIZE+4(4),=F'56'
*
MVI VBDXLOC,C' '
MVC VBDXLEN,=Y(VBDXQLL)
MVI VBDXVERT,ABDXVERE
MVI VBDXVERN,ABDXVERC
MVI VBDXID,ABDXQVB
MVC VBDXSIZE+4(4),=F'56'
*
MVI IBDXLOC,C' '
MVC IBDXLEN,=Y(IBDXQLL)
MVI IBDXVERT,ABDXVERE
MVI IBDXVERN,ABDXVERC
MVI IBDXID,ABDXQIB
MVC IBDXSIZE+4(4),=F'100'
*
*
MVC ACBXCMD,=CL2'OP'
MVC ACBXCID,WKCID
MVC ACBXADD3,SPACES
MVC ACBXADD4,SPACES
MVC ACBXADD5,SPACES
MVC RBDXDATA(06),=CL6'ACC=2.'
MVC RBDXSEND+4(4),=F'6'
LA R1,ADAPAL
L R15,WKAADA
BASR R14,R15
CLC ACBXRSP,=H'0'
JE A0012
*
MVC WKPRINT(131),=CL131'ASMADA: Open Error xxxx/xxxx'
LH R15,ACBXRSP
CVD R15,WKDBLWK2
MVC WKPRINT+19(4),NUMMSK+8
MVI WKPRINT+19,C' '
ED WKPRINT+19(4),WKDBLWK2+6
LH R15,ACBXERRC
CVD R15,WKDBLWK2
MVC WKPRINT+24(4),NUMMSK+8
MVI WKPRINT+24,C' '
ED WKPRINT+24(4),WKDBLWK2+6
LA R2,OUTDCB
LA R0,WKPRINT
PUT (R2),(R0)
MVC WKRETC,=F'8'
J RETURNX
*
A0012 EQU *
MVC WKPRINT(131),=CL131'ASMADA: OPEN DONE'
LA R2,OUTDCB
LA R0,WKPRINT
PUT (R2),(R0)
*
*
MVC ACBXCMD,=CL2'L3'
MVI ACBXCOP1,C'M'
MVI ACBXCOP2,C'V'
MVC ACBXADD1,=CL8'AA '
XC ACBXISN,ACBXISN
XC ACBXISL,ACBXISL
XC ACBXISQ,ACBXISQ
*
MVC FBDXDATA(12),=CL12'AA,AC,AD,AE.'
MVC FBDXSEND+4(4),=F'12'
*
XC RBDXSEND,RBDXSEND
MVC RBDXRECV+4(4),=A(LREC*NREC)
*
XC MBDXSEND,MBDXSEND
MVC MBDXRECV+4(4),=A(4+MISN*NREC)
*
MVC SBDXDATA(03),=CL3'AA.'
MVC SBDXSEND+4(4),=F'3'
*
MVC VBDXDATA(08),=CL8'00000000'
MVC VBDXSEND+4(4),=F'8'
*
A0013 EQU *
LA R1,ADAPAL
L R15,WKAADA
BASR R14,R15
CLC ACBXRSP,=H'0'
JE A0014
CLC ACBXRSP,=H'3'
JE A0015
*
MVC WKPRINT(131),=CL131'ASMADA: Read Error xxxx/xxxx'
LH R15,ACBXRSP
CVD R15,WKDBLWK2
MVC WKPRINT+19(4),NUMMSK+8
MVI WKPRINT+19,C' '
ED WKPRINT+19(4),WKDBLWK2+6
LH R15,ACBXERRC
CVD R15,WKDBLWK2
MVC WKPRINT+24(4),NUMMSK+8
MVI WKPRINT+24,C' '
ED WKPRINT+24(4),WKDBLWK2+6
LA R2,OUTDCB
LA R0,WKPRINT
PUT (R2),(R0)
MVC WKRETC,=F'8'
J RETURNX
*
A0014 EQU *
ASI WKBUFCNT,1
MVC WKPRINT(131),=CL131'ASMADA: READ DONE '
XC WKRECNUM,WKRECNUM
USING MBDSECT,R10
LAY R10,MBAREA
LAY R11,RBAREA
A001400 EQU *
CLC MBRESP,=F'0'
JE A001402
CLC MBRESP,=F'3'
JE A0015
*
MVC WKPRINT(131),=CL131'ASMADA: Read Error xxxx/xxxx (multife+
tch)'
LH R15,ACBXRSP
CVD R15,WKDBLWK2
MVC WKPRINT+19(4),NUMMSK+8
MVI WKPRINT+19,C' '
ED WKPRINT+19(4),WKDBLWK2+6
LH R15,ACBXERRC
CVD R15,WKDBLWK2
MVC WKPRINT+24(4),NUMMSK+8
MVI WKPRINT+24,C' '
ED WKPRINT+24(4),WKDBLWK2+6
LA R2,OUTDCB
LA R0,WKPRINT
PUT (R2),(R0)
MVC WKRETC,=F'8'
J RETURNX
*
A001402 EQU *
MVC WKPRINT+18(LREC),0(R11)
LA R2,OUTDCB
LA R0,WKPRINT
PUT (R2),(R0)
*
LA R10,16(,R10)
LA R11,LREC(,R11)
ASI WKRECNUM,1
CLC WKRECNUM,MBCOUNT
JL A001400
L R0,WKRECCNT
A R0,WKRECNUM
ST R0,WKRECCNT
J A0013
*
A0015 EQU *
L R0,WKRECCNT
A R0,WKRECNUM
ST R0,WKRECCNT
*
MVC WKPRINT(131),=CL131'ASMADA: END OF DATA'
LA R2,OUTDCB
LA R0,WKPRINT
PUT (R2),(R0)
*
*
MVC ACBXCMD,=CL2'CL'
XC FBDXSEND,FBDXSEND
XC RBDXSEND,RBDXSEND
XC SBDXSEND,SBDXSEND
XC VBDXSEND,VBDXSEND
XC RBDXRECV,RBDXRECV
LA R1,ADAPAL
L R15,WKAADA
BASR R14,R15
CLC ACBXRSP,=H'0'
JE A0016
CLC ACBXRSP,=H'3'
JE A0015
*
MVC WKPRINT(131),=CL131'ASMADA: Close Error xxxx/xxxx'
LH R15,ACBXRSP
CVD R15,WKDBLWK2
MVC WKPRINT+20(4),NUMMSK+8
MVI WKPRINT+20,C' '
ED WKPRINT+20,WKDBLWK2+6
LH R15,ACBXERRC
CVD R15,WKDBLWK2
MVC WKPRINT+25(4),NUMMSK+8
MVI WKPRINT+25,C' '
ED WKPRINT+25(4),WKDBLWK2+6
LA R2,OUTDCB
LA R0,WKPRINT
PUT (R2),(R0)
MVC WKRETC,=F'4'
J RETURNX
*
A0016 EQU *
MVC WKPRINT(131),=CL131'ASMADA: CLOSE DONE'
LA R2,OUTDCB
LA R0,WKPRINT
PUT (R2),(R0)
*
*
MVC WKPRINT,SPACES
MVC WKPRINT(131),=CL131'ASMADA9: Records read: '
L R15,WKRECCNT
CVD R15,WKDBLWK2
MVC WKPRINT+23(7),NUMMSK+5
MVI WKPRINT+23,C' '
ED WKPRINT+23(7),WKDBLWK2+5
LA R2,OUTDCB
LA R0,WKPRINT
PUT (R2),(R0)
*
MVC WKPRINT,SPACES
MVC WKPRINT(131),=CL131'ASMADA9: Using L3 commands: '
L R15,WKBUFCNT
CVD R15,WKDBLWK2
MVC WKPRINT+28(7),NUMMSK+5
MVI WKPRINT+28,C' '
ED WKPRINT+28(7),WKDBLWK2+5
LA R2,OUTDCB
LA R0,WKPRINT
PUT (R2),(R0)
*
*
RETURNX DS 0H
LLGT R15,WKRETC
*
lg r13,savf4saprev restore caller save area
st r15,16(,r13)
lm r14,r12,12(r13) restore caller's registers
BR R14 RETURN
*
STATIC LOCTR
*
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* *
* C O N S T A N T S *
* *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
*
STATIC LOCTR
DS 0D
MODE31 equ X'8000'
DS 0D
OPENPARM DC XL8'8000000000000000'
*
DBID300 DC F'300'
FNR0002 DC F'2'
LINKNAME DC CL8'ADAUSER'
NUMMSK DC XL12'402020202020202020202021'
SPACES DC CL256' '
HIVAL DC 256X'FF'
*
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* *
* D A T A C O N T R O L B L O C K S *
* *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
*
outfile DCB DSORG=PS,DDNAME=DDODATA,MACRF=(PM),DCBE=outfdcbe, x
RECFM=FB,LRECL=131
outfile0 EQU *-outfile
outfdcbe DCBE RMODE31=BUFF
outfilel EQU *-outfile
*
LTORG ,
DS 0F
DCBD DSORG=PS
*
IHADCBE
END
– The Security Systems Integrator Company