home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
ibm370
/
iktgup.asm
< prev
next >
Wrap
Assembly Source File
|
2020-01-01
|
38KB
|
468 lines
*COPY GUPVAR 10000000
* Specific variables 10001000
EVCTR DS F File sequence number TSO 10002000
ICPRGS DS 4F Saved registers for type-out @SC88026 10003000
* 10004000
PPLAREA DS A(0,0,CPECB,PRSPCL,RESULT,0,USERBLK) GUP1.1 10005000
CPECB DS F GETLINE/PUTLINE/PUTGET ECB @TS86001 10006000
RESULT DS A Parse PDL ptr GUP1.1 10007000
USERBLK DS D Parse work area (not used) GUP1.1 10008000
* 10009000
CAMLOC DS 4F Ptrs for locating dataset @SC86299 10010000
CAMOBT DS 4F Ptrs for getting DSCB @SC86299 10011000
CAMVOLS DS 0D,XL265 Storage for volume list @SC86299 10012000
CAMDSCB DS 0F,XL101 Storage for DSCB @SC88014 10013000
ORG CAMDSCB+1 @SC88014 10014000
DS1VOL DS CL6,XL2 Volume serial @SC86299 10015000
DS1CRDT DS 2XL3,3X,XL13 Creation date @SC86299 10016000
DS1RFDT DS XL3,XL4 Reference date @SC86299 10017000
DS1DSO DS XL2 Dataset org @SC86299 10018000
DS1RCF DS X Record format @SC86299 10019000
DS1OPT DS X Error option @SC86299 10020000
DS1BLK DS H Block size @SC86299 10021000
DS1LRC DS H Logical record length @SC86299 10022000
ORG , @SC86299 10023000
DYNPL DS A(0,0,0,0,DYNDSP,0),X'80',AL3(DYNRC) GUP1.1 10024000
DYNRC DS F @SC86299 10025000
DYNDSP DS X @SC86299 10026000
FNAME DS CL130 Buffer for reading TSO 10027000
*COPY GUPSPC 10028000
* External references in TSO GUPI: 10028100
* CLOSE DCB FREEMAIN FREEPOOL GETMAIN IKJCPPL IKJENDP 10028200
* IKJIDENT IKJKEYWD IKJNAME IKJPARM IKJPOSIT IKJSUBF LINK 10028300
* LOCATE OBTAIN OPEN SAVE 10028400
* 10028500
* Specific preliminaries 10029000
&STORDS SETC 'KSTORG' Storage DSECT for Kermit globals @SC89268 10029500
* 10030000
LFID EQU 60 Filespec length GUP1.2 10031000
STKDWDS EQU 511 Requested stack length TSO 10032000
XXBAT EQU X'04' Special flag for batch mode GUP1.1 10033000
KWRKBASE EQU 11 Base register for work area @SC89268 10033300
KSUBBASE EQU 12 Base register for CSECT @SC89268 10033600
* 10034000
IKJCPPL , GUP1.1 10035000
*COPY GUPFIN 10036000
LR 2,15 Save return code GUP1.1 10037000
CLOSE MSGFIL GUP1.1 10038000
LR 15,2 Return code GUP1.1 10039000
*COPY GUPNIT 10040000
* TSO user interface TSO 10041000
* 10042000
LA 4,DYNDSP Set up DYNALC plist GUP1.2 10043000
LA 6,DYNRC GUP1.2 10044000
STM 4,6,DYNPL+16 GUP1.2 10045000
OI DYNPL+24,X'80' Mark end of plist GUP1.2 10046000
* 10047000
TM 0(1),X'80' What kind of plist? GUP1.1 10048000
BZ GUPCP Seems to be CP GUP1.1 10049000
MVC SRCNAM(3*LFID+3),BATDDNS Copy ddnames+mark GUP1.1 10050000
LA 4,XXCOR+XX8+XXBAT Default flags GUP1.1 10051000
L 1,0(1) Ptr to parm string GUP1.1 10052000
LH 2,0(1) Get length GUP1.1 10053000
OPTLP SR 0,0 Mask: zeroes GUP1.1 10054000
CH 2,EH2 Enough for a 'NO'? GUP1.1 10055000
BL OPTZ No GUP1.1 10056000
CLC =C'NO',2(1) Is it? GUP1.1 10057000
BNE OPTYES No, assume positive option GUP1.1 10058000
EH2 EQU *+2,2 GUP1.1 10059000
LA 1,2(1) Yes, it is. Space over the NO GUP1.1 10060000
SH 2,EH2 Cut off the NO GUP1.1 10061000
BCTR 0,0 Mask: ones GUP1.1 10062000
OPTYES SH 2,EH4 See if room for option GUP1.1 10063000
BL OPTZ No, done scan GUP1.1 10064000
CLC =C'MARK=',2(1) GUP1.1 10065000
BNE OPTCK Check flags GUP1.1 10066000
SH 2,EH4 See if mark field available GUP1.1 10067000
BL OPTZ No, done scan GUP1.1 10068000
MVC MRKD,7(1) Copy in case NOSEQ8 GUP1.1 10069000
LA 1,8(1) Space over option GUP1.1 10070000
B OPTLQ GUP1.1 10071000
OPTCK LA 3,XX8 Test for SEQ8 GUP1.1 10072000
CLC =C'SEQ8',2(1) GUP1.1 10073000
BE OPTOK Found it GUP1.1 10074000
LA 3,XXCOR Test for in-storage GUP1.1 10075000
CLC =C'STOR',2(1) GUP1.1 10076000
BNE OPTZ None of these, give up GUP1.1 10077000
OPTOK OR 4,3 Turn flag on GUP1.1 10078000
NR 3,0 GUP1.1 10079000
XR 4,3 Turn off if "NO" GUP1.1 10080000
LA 1,4(1) Advance ptr over option GUP1.1 10081000
OPTLQ LTR 2,2 Any more options? GUP1.1 10082000
BNP OPTZ GUP1.1 10083000
CLI 2(1),C',' Make sure there is a separator GUP1.1 10084000
BNE OPTZ No, give up GUP1.1 10085000
LA 1,1(1) GUP1.1 10086000
BCT 2,OPTLP GUP1.1 10087000
OPTZ STC 4,FLG Save current flags GUP1.1 10088000
OPEN (MSGFIL,OUTPUT) Message data set GUP1.1 10089000
TM MSGFIL+FABOFLGS-FABD,X'10' GUP1.1 10090000
BZ ERREX Oops GUP1.1 10091000
B OPN GUP1.1 10092000
* 10093000
USING CPPL,1 @SC86299 10094000
GUPCP MVI SRCNAM,C' ' GUP1.1 10095000
MVC SRCNAM+1(3*LFID+2),SRCNAM Blank out parm area GUP1.1 10096000
MVI FLG,0 GUP1.1 10097000
L 3,CPPLUPT Fill in parse parameter list GUP1.1 10098000
L 4,CPPLECT GUP1.1 10099000
LA 5,CPECB GUP1.2 10100000
L 6,=V(PRSPCL) GUP1.2 10101000
LA 7,RESULT GUP1.2 10102000
L 8,CPPLCBUF GUP1.2 10103000
LA 9,USERBLK GUP1.2 10104000
STM 3,9,PPLAREA GUP1.1 10105000
DROP 1 GUP1.1 10106000
MVI CPECB,0 GUP1.1 10107000
LINK EP=IKJPARS,MF=(E,PPLAREA) Perform parsing serviceUP1.1 10108000
LTR 15,15 Any good? GUP1.1 10109000
BNZ ERREX No, exit with error GUP1.1 10110000
* Interpret results GUP1.1 10111000
L 8,RESULT Address parsed data GUP1.1 10112000
USING IKJPARMD,8 GUP1.1 10113000
LA 1,PRSSRC -> Base dataset name info GUP1.1 10114000
LA 6,SRCNAM -> Destination field GUP1.1 10115000
BAL 7,MOVDSN Move dataset name GUP1.1 10116000
LA 1,PRSCTL Do update DSN GUP1.1 10117000
LA 6,CTLNAM GUP1.1 10118000
BAL 7,MOVDSN GUP1.1 10119000
LA 1,PRSOUT Do output DSN GUP1.1 10120000
LA 6,OUTNAM GUP1.1 10121000
BAL 7,MOVDSN GUP1.1 10122000
CLI PRSSEQ8+1,1 SEQ8 option set? GUP1.1 10123000
BNE *+8 No GUP1.1 10124000
OI FLG,XX8 Yes, enable flag GUP1.1 10125000
CLI PRSSTOR+1,1 STOR option set? GUP1.1 10126000
BNE *+8 No GUP1.1 10127000
OI FLG,XXCOR Yes, enable flag GUP1.1 10128000
LA 1,PRSMRKV GUP1.1 10129000
LA 6,MRKD GUP1.1 10130000
BAL 7,MOVMEM Move mark, if any GUP1.1 10131000
B OPN Done GUP1.1 10132000
* 10133000
MOVDSN L 2,0(1) --> dataset name GUP1.1 10134000
LH 3,4(1) Length GUP1.1 10135000
BCTR 3,0 GUP1.1 10136000
EX 3,CPYTXT Move dataset name GUP1.1 10137000
LA 6,44(6) Point to member storage GUP1.1 10138000
LA 1,8(1) GUP1.1 10139000
MOVMEM L 2,0(1) Member name GUP1.1 10140000
LTR 2,2 Test for member GUP1.1 10141000
BZR 7 None GUP1.1 10142000
LH 3,4(1) Length GUP1.1 10143000
BCTR 3,0 GUP1.1 10144000
EX 3,CPYTXT Move member name GUP1.1 10145000
BR 7 GUP1.1 10146000
CPYTXT MVC 0(,6),0(2) GUP1.1 10147000
DROP 8 GUP1.1 10148000
* 10149000
WTEXT STM 14,1,ICPRGS Save registers GUP1.1 10150000
TM FLG,XXBAT Batch version? GUP1.1 10151000
BZ WTXCP No, just do a TPUT GUP1.1 10152000
STH 0,MSGFIL+FABLRECL-FABD Save LRECL GUP1.1 10153000
LR 0,1 GUP1.1 10154000
PUT MSGFIL,(0) And write it out GUP1.1 10155000
B WTXRET GUP1.1 10156000
WTXCP SVC 93 GUP1.1 10157000
WTXRET LM 14,1,ICPRGS Restore and return GUP1.1 10158000
BR 15 GUP1.1 10159000
* 10160000
MSGFIL DCB DDNAME=SYSPRINT,MACRF=PM,RECFM=U,BLKSIZE=130,DSORG=PS 10161000
* 10162000
BATDDNS DC CL(LFID)'+SYSUT1' GUP1.2 10163000
DC CL(LFID)'+SYSIN' GUP1.2 10164000
DC CL(LFID)'+SYSUT2' GUP1.2 10165000
DC C' ' Leave sequence field blank GUP1.1 10166000
* 10167000
PRSPCL IKJPARM , GUP1.1 10168000
PRSSRC IKJPOSIT DSNAME,USID,PROMPT='SOURCE DSNAME' GUP1.1 10169000
PRSCTL IKJPOSIT DSNAME,USID,PROMPT='UPDATE DSNAME' GUP1.1 10170000
PRSOUT IKJPOSIT DSNAME,USID,PROMPT='OUTPUT DSNAME' GUP1.1 10171000
PRSSEQ8 IKJKEYWD DEFAULT='SEQ8' GUP1.1 10172000
IKJNAME 'SEQ8' GUP1.1 10173000
IKJNAME 'NOSEQ8' GUP1.1 10174000
PRSSTOR IKJKEYWD DEFAULT='STOR' GUP1.1 10175000
IKJNAME 'STOR' GUP1.1 10176000
IKJNAME 'NOSTOR' GUP1.1 10177000
PRSMARK IKJKEYWD , GUP1.1 10178000
IKJNAME 'MARK',SUBFLD=PRS2MRK GUP1.1 10179000
PRS2MRK IKJSUBF , GUP1.1 10180000
PRSMRKV IKJIDENT 'SEQUENCE MARK',FIRST=ANY,OTHER=ANY,MAXLNTH=3 UP1.1 10181000
IKJENDP , GUP1.1 10182000
GUPI CSECT 10183000
* TSO 10184000
OPNERR LA 1,L'OPNEM TSO 10185000
BAL 0,FILERR TSO 10186000
OPNEM DC C'FILE NOT FOUND: ' TSO 10187000
DSKERR LA 2,8(1) TSO 10188000
LA 1,L'DSKEM TSO 10189000
BAL 0,FILERR TSO 10190000
DSKEM DC C'DISK ERROR ON FILE ' TSO 10191000
* TSO 10192000
FILERR LA 4,FNAME Buffer to use TSO 10193000
LR 5,1 TSO 10194000
MVCL 4,0 Copy message TSO 10195000
LA 3,LFID Length of a name field TSO 10196000
LR 5,3 TSO 10197000
MVCL 4,2 Copy name TSO 10198000
LA 1,FNAME Start of buffer again TSO 10199000
SR 4,1 TSO 10200000
WTEXT (1),(4) TSO 10201000
B ERREX TSO 10202000
*COPY GUPSUB 10203000
TITLE 'DISKIO Routine - performs disk I/O functions' 10204000
* Function selected on entry by R0: 10205000
* 1=> open (in): R1->pattern FDB, R2->name. Returns R0->FAB, R1->FDB 10206000
* 2=> open (out): (same, but no complete FDB if new file) 10207000
* 4=> close file: R1->adr(FAB). 10208000
* 9=> read: R1->FAB. Returns R15=12 if EOF, 0 if ok; R0=# data 10209000
* 10=> write: R1->FAB. Returns R15=13 if disk full, 0 if ok. 10210000
DISKIO ENTER 10211000
USING FABD,3 @SC86295 10212000
SR 4,4 Signal no block assigned @SC86295 10213000
LA 6,FDBTRKAL-FDBD(1) Use pattern TRKAL @SC88026 10214000
ST 6,DYNPL+20 Set up calling sequence GUP1.1 10215000
BCT 0,DSKOPNO @SC86295 10216000
* 10217000
* Open for input file whose name is at (R2), FDB at (R1) 10218000
MVI DYNDSP,X'88' SHR,KEEP @SC86299 10219000
BAL 9,DSKALC Get FAB @SC86295 10220000
BAL 2,DSKLKP Get DSCB @SC86299 10221000
BNZ DSKER1 Not found @SC86295 10222000
BAL 14,DSKVALS @SC86295 10223000
BAL 9,DSKFABS Set up FAB from FDB @SC86299 10224000
CNOP 0,4 @SC86299 10225000
BAL 2,DSKOPT Open and test @SC86299 10226000
OPEN (0,INPUT),MF=L @SC86299 10227000
* 10228000
* Open for output file whose name is at (R2), FDB at (R1) 10229000
DSKOPNO BCT 0,DSKTEST @SC86295 10230000
MVI DYNDSP,X'42' NEW,CATLG @SC86299 10231000
BAL 9,DSKALC Get FAB @SC86295 10232000
BAL 2,DSKLKP Get DSCB @SC86299 10233000
BNZ DSKOPN Not found, just writing new @SC86299 10234000
MVI DYNDSP,X'18' OLD,KEEP @SC86299 10235000
TM DS1DSO,2 PDS? GUP1.1 10236000
BZ DSKOPN No, we just write over it GUP1.1 10237000
BAL 14,DSKVALS Yes, copy DCB info GUP1.1 10238000
BAL 9,DSKFABS GUP1.1 10239000
DSKOPN CNOP 0,4 @SC86299 10240000
BAL 2,DSKOPT Open and test @SC86299 10241000
OPEN (0,OUTPUT),MF=L @SC86299 10242000
DSKOPT CLI FABDSN,C'+' Just DDNAME? GUP1.1 10243000
BE DSKOPDZ Yes, don't need to allocate GUP1.1 10244000
KCALL DYNALC,DYNPL,EXT @SC86299 10245000
DSKOPDZ DS 0H GUP1.1 10246000
OPEN ((3)),MF=(E,(2)) @SC86299 10247000
TM FABOFLGS,X'10' @SC86299 10248000
BZ DSKER1 Didn't work @SC86299 10249000
B RTRN0 @SC86295 10250000
* 10251000
DSKTEST BCT 0,DSKCLOS @SC86295 10252000
B RTRN1 @SC86299 10253000
* 10254000
* Close file whose ticket is at (R1), release block 10255000
DSKCLOS BCT 0,DSKRED @SC86295 10256000
ICM 3,15,0(1) Get FAB ptr, if any @SC86295 10257000
BZ RTRN0 None, ignore @SC86295 10258000
XC 0(4,1),0(1) Yes, now clear ticket @SC86295 10259000
CLOSE ((3)) @SC86299 10260000
FREEPOOL (3) @SC86299 10261000
LA 0,FABDWDS @SC86295 10262000
LR 1,3 @SC86299 10263000
DMSFRET DWORDS=(0),LOC=(1) @SC86295 10264000
B RTRN0 @SC86295 10265000
* 10266000
* Read from file whose ticket is at (R1) 10267000
DSKRED SH 0,=H'4' 10268000
BCT 0,DSKWRT @SC86295 10269000
LTR 3,1 Get FAB ptr @SC86299 10270000
BNP RTRN1 Not defined anymore @SC86299 10271000
L 15,FABGET I/O routine @SC86299 10272000
BALR 14,15 Go to it @SC86299 10273000
LM 4,5,FDBBUFF Get buffer and size @SC86299 10274000
LH 7,FABLRECL Actual length @SC86299 10275000
AR 7,1 End of record @SC86299 10276000
BAL 2,DSKTV @SC86299 10277000
LA 1,4(1) Skip over SDW if V @SC86299 10278000
SR 7,1 Revised length @SC86299 10279000
LR 6,1 @SC86299 10280000
CR 7,5 @SC86299 10281000
BNL *+6 @SC86299 10282000
LR 5,7 Buffer not filled @SC86299 10283000
L 1,4(13) @SC86299 10284000
ST 5,20(1) Return length in R0 @SC86299 10285000
MVCL 4,6 Copy to buffer @SC86299 10286000
B RTRN0 @SC86299 10287000
* End of file on input. Don't close it yet. @SC86295 10288000
DSKEOD LA 15,12 End return code @SC86295 10289000
B RTRN @SC86295 10290000
* 10291000
* Write to file whose ticket is at (R1) 10292000
DSKWRT DS 0H 10293000
LTR 3,1 Get FAB ptr @SC86299 10294000
BNP RTRN1 Not defined anymore @SC86299 10295000
LM 4,5,FDBBUFF Get buffer and size @SC86299 10296000
LR 6,5 Copy for LRECL @SC86299 10297000
CH 6,FDBLRC @SC86299 10298000
BNH *+8 @SC86299 10299000
LH 6,FDBLRC Don't allow more than LRECL if V @SC86299 10300000
BAL 2,DSKTV @SC86299 10301000
LA 6,4(5) + 4 if RECFM=V @SC86299 10302000
STH 6,FABLRECL Set up for output @SC86299 10303000
L 15,FABGET I/O routine @SC86299 10304000
BALR 14,15 Do it @SC86299 10305000
XC 0(4,1),0(1) @SC86299 10306000
STCM 6,3,0(1) In case V @SC86299 10307000
BAL 2,DSKTV @SC86299 10308000
LA 1,4(1) V: space over SDW @SC86299 10309000
LR 6,1 @SC86299 10310000
LR 7,5 @SC86299 10311000
MVCL 6,4 Copy to output record @SC86299 10312000
B RTRN0 @SC86295 10313000
* 10314000
DSKTV TM FABRECFM,FABRECU @SC86299 10315000
BNM 4(2) U @SC86299 10316000
TM FABRECFM,FABRECF @SC86299 10317000
BO 4(2) F @SC86299 10318000
BR 2 V @SC86299 10319000
* Return on error, release useless block, if any 10320000
DSKER1 LTR 1,4 Any block assigned? @SC86295 10321000
BZ RTRN1 No @SC86295 10322000
LA 0,FABDWDS Yes, release it @SC86295 10323000
DMSFRET DWORDS=(0),LOC=(1) @SC86295 10324000
B RTRN1 Flag error @SC86295 10325000
* 10326000
DSKALC LR 5,1 Save FDB ptr @SC86295 10327000
LA 6,1 Update counter @SC86299 10328000
A 6,EVCTR @SC86299 10329000
ST 6,EVCTR @SC86299 10330000
LA 0,FABDWDS @SC86295 10331000
DMSFREE DWORDS=(0),ERR=DSKER1 @SC86295 10332000
LR 3,1 New block ptr @SC86295 10333000
LR 4,1 @SC86295 10334000
L 1,4(13) @SC86295 10335000
ST 3,20(1) Return R0 @SC86295 10336000
XC 0(8*FABDWDS,3),0(3) @SC86295 10337000
MVC FDBD(FDBCOP),0(5) Copy user's FDB @SC86295 10338000
MVC FABDSN,0(2) @SC86299 10339000
LR 15,2 Set up DSN ptr @SC86299 10340000
LA 0,FABDDNAM Get DDN ptr @SC86299 10341000
LA 1,FDBUNT Get UNIT ptr @SC86299 10342000
LA 2,FDBVOL Get VOL ptr @SC86299 10343000
STM 15,2,DYNPL Set up DYNALC @SC86299 10344000
MVI FABBUFCB+3,1 Fill out DCB @SC86299 10345000
MVI FABDSORG,X'40' =PS @SC86299 10346000
MVI FABIOBAD+3,1 @SC86299 10347000
LA 0,DSKEOD @SC86299 10348000
LA 1,DSKOPEX @SC86299 10349000
STM 0,1,FABEODAD @SC86299 10350000
UNPK FABDDNAM,EVCTR(5) @SC86299 10351000
TR FABDDNAM,TRHEX Get unique DDNAME @SC86299 10352000
MVI FABDDNAM,C'K' @SC86299 10353000
MVI FABDDNAM+7,C'Z' @SC86299 10354000
MVC FABOFLGS(4),=X'02,00,48,48' @SC86299 10355000
MVI FABCHECK+3,1 @SC86299 10356000
LA 1,RTRN1 @SC86299 10357000
ST 1,FABSYNAD In case of error @SC86299 10358000
MVI FABIOBA+3,1 @SC86299 10359000
MVI FABEOBAD+3,1 GUP1.1 10360000
MVI FABRECAD+3,1 GUP1.1 10361000
MVI FABCNTRL+3,1 GUP1.1 10362000
MVI FABEOB+3,1 @SC86299 10363000
DSKFABS LH 1,FDBLRC Copy Info to DCB @SC86299 10364000
CLI FABDSN,C'+' Just DDNAME? GUP1.1 10365000
BE DSKDDA Yes, copy it to FAB GUP1.1 10366000
STH 1,FABLRECL @SC86299 10367000
MVC FABBLKSI,FDBBLKSI @SC86299 10368000
MVI FABRECFM,FABRECU @SC86299 10369000
CLI FDBRCF,C'U' @SC86299 10370000
BER 9 @SC86299 10371000
MVI FABRECFM,FABRECF+FABRECBR @SC86299 10372000
CLI FDBRCF,C'F' @SC86299 10373000
BER 9 @SC86299 10374000
MVI FABRECFM,FABRECV+FABRECBR @SC86299 10375000
LA 1,4(1) Allow for RDW @SC86299 10376000
STH 1,FABLRECL @SC86299 10377000
BR 9 @SC86299 10378000
DSKDDA MVC FABDDNAM,FABDSN+1 Copy to DDNAME GUP1.1 10379000
BR 9 GUP1.1 10380000
* 10381000
* Call with R15->name, return to R2 with CC set (Z if ok) 10382000
DSKLKP SR 0,0 @SC86299 10383000
CLI 0(15),C'+' Just DDNAME? GUP1.1 10384000
BER 2 Yes, say we found it GUP1.1 10385000
LA 1,CAMVOLS @SC86299 10386000
LA 14,X'44' Name code @SC86299 10387000
SLL 14,24 @SC86299 10388000
STM 14,1,CAMLOC Save dsn ptr, etc @SC86299 10389000
LA 0,CAMVOLS+6 @SC86299 10390000
LA 1,CAMDSCB @SC86299 10391000
LA 14,X'C1' Search code @SC86299 10392000
SLL 14,24 @SC86299 10393000
STM 14,1,CAMOBT @SC86299 10394000
LOCATE CAMLOC @SC86299 10395000
LTR 6,15 Retain 1st code in R6 @SC86299 10396000
BNZR 2 Give up @SC86299 10397000
OBTAIN CAMOBT Get DSCB @SC86299 10398000
LTR 15,15 Test return code @SC86299 10399000
BR 2 @SC86295 10400000
* 10401000
DSKVALS LA 0,FDBD Ptr to FDB @SC86295 10402000
L 1,4(13) @SC86295 10403000
ST 0,24(1) Return ptr to caller @SC86295 10404000
CLI FABDSN,C'+' Just DDNAME? GUP1.1 10405000
BER 14 Yes, done: no DSCB GUP1.1 10406000
MVC FDBBLKSI,DS1BLK @SC86299 10407000
MVC FDBVOL,DS1VOL Copy volume name @SC86299 10408000
LH 1,DS1BLK Use BLKSIZE if 'U' @SC86299 10409000
MVI FDBRCF,C'U' @SC86299 10410000
TM DS1RCF,FABRECU @SC86299 10411000
BO DSKVLR @SC86299 10412000
LH 1,DS1LRC Use LRECL if 'F' @SC86299 10413000
MVI FDBRCF,C'F' @SC86299 10414000
TM DS1RCF,FABRECF @SC86299 10415000
BO DSKVLR @SC86299 10416000
MVI FDBRCF,C'V' @SC86299 10417000
S 1,F4 Use LRECL-4 if 'V' @SC86299 10418000
DSKVLR STH 1,FDBLRC @SC86299 10419000
BR 14 @SC86299 10420000
* 10421000
DSKOPEX DC 0F'0',X'85',AL3(DSKOPC) OPEN EXIT @SC86299 10422000
* 10423000
DSKOPC LR 3,1 @SC86299 10424000
LH 5,FABBLKSI @SC86299 10425000
LTR 5,5 @SC86299 10426000
BP *+8 @SC86299 10427000
LH 5,=H'6233' @SC86299 10428000
LR 6,5 @SC86299 10429000
TM FABRECFM,FABRECU @SC86299 10430000
BO DSKOPS @SC86299 10431000
LH 6,FABLRECL @SC86299 10432000
BNZ *+8 @SC86299 10433000
OI FABRECFM,FABRECF+FABRECBR @SC86299 10434000
LTR 6,6 @SC86299 10435000
BP DSKOPQ @SC86299 10436000
LA 6,80 @SC86299 10437000
BAL 2,DSKTV @SC88049 10438000
LA 6,4(6) Allow LRECL=84 for VB @SC88049 10439000
DSKOPQ TM FABRECFM,FABRECF @SC86299 10440000
BZ DSKOPV @SC86299 10441000
SR 4,4 @SC86299 10442000
DR 4,6 @SC86299 10443000
LTR 5,5 @SC88104 10444000
BP *+8 @SC88104 10445000
LA 5,1 BLKSIZE was less than LRECL! @SC88104 10446000
MR 4,6 @SC86299 10447000
B DSKOPS @SC86299 10448000
DSKOPV LA 4,4(6) @SC86299 10449000
CR 4,5 @SC86299 10450000
BNH DSKOPS @SC86299 10451000
LR 5,4 @SC86299 10452000
DSKOPS STH 6,FABLRECL @SC86299 10453000
STH 5,FABBLKSI @SC86299 10454000
BR 14 @SC86299 10455000
* 10456000
LOCALS , @SC86295 10457000
EXIT 10458000
