***********************************************************************
ONLNDASD CSECT
ONLNDASD AMODE 31
ONLNDASD RMODE 24
		BAKR R14,Ø SAVE CALLER DATA ON STACK
		LR R12,R15 GET ENTRY POINT
		LA R11,2Ø48(R12) LOAD SECOND BASE
		LA R11,2Ø48(R11) LOAD SECOND BASE
		USING ONLNDASD,R12,R11 ADDRESSABILITY
		L R2,Ø(R1) GET ADDR OF PARM
		OPEN (REPORT,(OUTPUT))
***********************************************************************
* SCAN THROUGH THE UCB'S, LOOKING FOR THE TYPE WE WANT... *
***********************************************************************
SCANUCBS DS ØH
		USING UCBOB,R4 ADDRESSABILITY TO UCB
		LA R4,UCBAREA +POINT TO UCB STORAGE AREA
		LA R3,MSG3+1 POINT TO FIRST MSG FIELD
		XC UCBWORK,UCBWORK +INITIALIZE UCBSCAN WORKAREA
		*
		UCBSCAN COPY, X
			  WORKAREA=UCBWORK, X
			  UCBAREA=UCBAREA, X
			DCEAREA=NONE, X
			DCELEN=Ø, X
			VOLSER=NONE, DON'T SELECT BY VOLSER X
			DEVN=Ø, START WITH FIRST UCB X
			DYNAMIC=YES, INCLUDE DYNAMICALLY ADDED UCBS X
			RANGE=ALL, 4 AND 3-DIGIT UCBS X
			NONBASE=NO, NOT SURE WHAT THIS DOES X
			DEVCLASS=DASD, SELECT DASD UCBS ONLY X
			DEVCID=Ø, DON'T SELECT BY DEVICE CHAR. X
			IOCTOKEN=NONE, NO IODEVICE TABLE TOKEN X
			LINKAGE=SYSTEM, USE PC CALL X
			PLISTVER=MAX
*
		LTR R15,R15 GOT UCB OK?
		BZ UCBCHECK YES..CHECK IT
		C R15,=F'4' END OF UCBS?
		BE ENDUCBS YES..CLEAN UP, ETC
		B BADCALL NO...SHOW RETURN/REASON CODES
UCBCHECK DS ØH
		TM UCBSTAT,UCBONLI IS THIS ONE ONLINE?
		BO GETINFO YES..
		B UCBLOOP NO...IGNORE IT
***********************************************************************
* NB AS WE GET THE FORMAT4 FROM THE VTOC THERE IS SOMETIMES AN *
* EXTRA (CE?) CYLINDER ADDED ON- WE WILL TAKE THIS OFF IF WE CAN *
* RECOGNIZE THAT IT IS THERE (EG 886 ON A 338Ø 'D'). *
**********************************************************************
***********************************************************************
GETINFO DS ØH
 MVC 27(8,R3),=C'(?????) ' SET UP DEFAULT SIZE
*
 LSPACE UCB=(R4), GET THE FORMAT4 DSCB... X
 F4DSCB=F4DSCB, X
 MSG=F4ERRMSG PLACE POSSIBLE ERRMSG IN HERE
*
 LTR R15,R15 LSPACE WORKED OK?
 BZ CHKCYLS YES..
 ST R15,FWORD NO...SAVE RETURN CODE
 TM SWITCH,MSGSENT ALREADY DISPLAYED ERROR TEXT?
 BO SHOWRC YES..
 OI SWITCH,MSGSENT NO...SET SO WE DON'T REPEAT IT
 PUT REPORT,F4ERRMSG DISPLAY ERROR TEXT
SHOWRC DS ØH
 UNPK DWORD(3),FWORD+3(2) UNPACK RETURN CODE + 1 BYTE
 TR DWORD(2),HEXTAB-24Ø XLATE TO PRINTABLE HEX
 MVC 26(5,R3),=C'RC=X"' SET UP CONSTANT
 MVC 31(2,R3),DWORD MOVE IN RC
 MVI 33(R3),C'"'
 B CARRYON IGNORE REST OF THIS BIT
CHKCYLS DS ØH
 MVC 27(7,R3),=X'4Ø2Ø2Ø6B2Ø212Ø' YES..MOVE IN EDIT PATTERN
 LH R1,F4DSCB+18 GET NUMBER OF CYLINDERS
 CH R1,=H'886' 886 CYLS (338Ø 'D')?
 BE TAKE1OFF YES..
 CH R1,=H'1771' 1771 CYLS (338Ø 'E')?
 BE TAKE1OFF YES..
 CH R1,=H'2656' 2656 CYLS (338Ø 'K')?
 BE TAKE1OFF YES..
 CH R1,=H'1114' 1114 CYLS (339Ø M1)?
 BE TAKE1OFF YES..
 CH R1,=H'2227' 2227 CYLS (339Ø M2)?
 BE TAKE1OFF YES..
 CH R1,=H'334Ø' 334Ø CYLS (339Ø M3)?
 BE TAKE1OFF YES..
 CH R1,=H'1ØØ18' 1ØØ18 CYLS (339Ø M9)?
 BE TAKE1OFF YES..
 B GETCYLS NO...
TAKE1OFF DS ØH
 BCTR R1,Ø THERE IT GOES...
GETCYLS DS ØH
 CVD R1,DWORD CONVERT TO DECIMAL
 ED 27(7,R3),DWORD+5 EDIT IN NUMBER OF CYLINDERS
 MVI 27(R3),C'(' MAKE IT LOOK PRETTY
 MVI 34(R3),C')'
CARRYON DS ØH
 TM UCBFL1,UCBBOX BOXED?
 BO ITSBOXED YES..
 TM UCBSTAT,UCBALOC ALLOCATED?
 BO ITSALLOC YES..
 TM UCBSTAT,UCBONLI ONLINE?
 BO ITSONLIN YES..
 B ITSOFLIN NO...LET'S CALL IT OFFLINE
ITSONLIN DS ØH
 MVC 1Ø(7,R3),ONLINE SET UP MSG
 B GETVOLID GO AND GET VOLID
ITSOFLIN DS ØH
 MVC 1Ø(7,R3),OFFLINE SET UP MSG
 B GETVOLID GO AND GET VOLID
ITSBOXED DS ØH
 MVC 1Ø(7,R3),BOXED SET UP MSG
 B GETDEVTP GO AND GET DEVICE TYPE
ITSALLOC DS ØH
 MVC 1Ø(7,R3),ALLOC SET UP MSG
 B GETVOLID GO AND GET THE VOLID
GETVOLID DS ØH
 MVC 18(6,R3),UCBVOLI MOVE VOLID TO MSG LINE
GETDEVTP DS ØH
 MVC 5(4,R3),QUERIES SET UP UNKNOWN DEVTYPE
 CLI UCBTBYT4,X'ØE' 338Ø? DASD
 BE SET338Ø YES..
 CLI UCBTBYT4,X'ØF' 339Ø? DASD
 BE SET339Ø YES..
 B CHKUCBS NO...LEAVE AS '????'
SET338Ø DS ØH
 MVC 5(4,R3),=C'338Ø'
 B CHKUCBS YES..
SET339Ø DS ØH
 MVC 5(4,R3),=C'339Ø'
CHKUCBS DS ØH YES..
 MVC 52(13,R3),NONSHARE DEFAULT TO NON-SHAREABLE
 TM UCBTBYT2,UCBRR SHAREABLE?
 BNO CHECKPRI NO...
 MVC 52(13,R3),SHARE YES..SET TO SHAREABLE
CHECKPRI DS ØH
 TM UCBSTAB,UCBBPRV PRIVATE?
 BNO CHECKPUB NO...
 MVC 37(7,R3),PRIVATE YES..SHOW THAT IN MSG
 BAL R9,LOCUCB SEE WHERE UCB IS...
 B CHECKCTL
CHECKPUB DS ØH
 TM UCBSTAB,UCBBPUB PUBLIC?
 BNO CHECKSTR NO...
 MVC 37(7,R3),PUBLIC YES..SHOW THAT IN MSG
 BAL R9,LOCUCB SEE WHERE UCB IS...
 B CHECKCTL
CHECKSTR DS ØH
 TM UCBSTAB,UCBBSTR STORAGE?
 BNO CHECKCTL
 MVC 37(7,R3),STORAGE YES..SHOW THAT IN MSG
 BAL R9,LOCUCB SEE WHERE UCB IS...
CHECKCTL DS ØH
 XC FWORD2,FWORD2 CLEAR WORK REG
 MVC FWORD2+2(2),UCBCHAN DEVICE ADDRESS TO LOOK FOR
 MVC CTLUNIT,CTLNFND SET DEFAULT CTLUNIT
 BAL R9,FINDCTL GO AND FIND CTLUNIT
 MVC 67(8,R3),CTLUNIT SET CTLUNIT
 UNPK UNPKFLD(5),UCBCHAN(3) UNPACK HEX CUU + 1 CHAR
 TR UNPKFLD(4),TRTAB2-24Ø MAKE PRINTABLE HEX
 CLI UNPKFLD,C'Ø' LEADING ZERO?
 BNE DISPLAY2 NO...
 MVI UNPKFLD,C' ' YES..BLANK OUT
DISPLAY2 DS ØH
 MVC Ø(4,R3),UNPKFLD MOVE CUU TO MSG LINE
 PUT REPORT,MSG3 DISPLAY INFO
 MVI MSG3,C' ' YES..CLEAR OUT LINE
 MVC MSG3+1(MSG3L-1),MSG3
 LA R3,MSG3+1
 B UCBLOOP AND GET NEXT UCB
ENDUCBS DS ØH
***********************************************************************
* RETURN TO CALLER WITH RELEVANT RETURN CODE... *
***********************************************************************
RETURN DS ØH
 L R15,RETC LOAD RETURN CODE
 PR , RESTORE CALLER DATA, RETURN
***********************************************************************
* BAD RETURN CODE FROM CALL TO 'UCBSCAN'... *
***********************************************************************
BADCALL DS ØH
 ST R15,RETCD SAVE RETURN CODE FROM UCBSCAN
 ST RØ,REASN SAVE REASON CODE FROM UCBSCAN
 UNPK UNPKFLD(3),RETCD+3(2) UNPK RETURN CODE + 1 BYTE
 TR UNPKFLD(2),TRTAB2-24Ø XLATE TO PRINTABLE HEX
 MVC MSGBTXT1,UNPKFLD MOVE RETURN CODE TO MSG AREA
 UNPK UNPKFLD(3),REASN+3(2) UNPK REASON CODE + 1 BYTE
 TR UNPKFLD(2),TRTAB2-24Ø XLATE TO PRINTABLE HEX
 MVC MSGBTXT2,UNPKFLD MOVE REASON CODE TO MSG AREA
 PUT REPORT,MSGB SHOW CODES...
 MVC RETC,=F'8' SET RC=8
 B RETURN
***********************************************************************
* + + S U B R O U T I N E + + + *
* CONVERT CHARACTER CUU (EG 'Ø94F') INTO ITS BINARY EQUIVALENT. THIS *
* IS SO THAT VALID RANGE COMPARISONS CAN BE MADE IF A RANGE OF CUUS *
* HAS BEEN REQUESTED. THE ROUTINE USES 4-DIGIT ADDRESSES, PADDED WITH *
* A LEADING 'Ø', IF REQUIRED. *
***********************************************************************
CONVCUU DS ØH
 TR FWORD(4),TRTAB CONV. C'A->F' INTO X'A->F'
 XC DWORD,DWORD CLEAR OUT WORKAREA
 PACK DWORD+4(4),FWORD(5) REMOVE ZONES
 L R8,DWORD+4 LOAD 'ØØCCUUØØ'
 SRL R8,8 SHIFT OUT TRAILING 'ØØ'
 ST R8,FWORD SAVE BINARY CUU VALUE
 BR R9 RETURN FROM SUBROUTINE
***********************************************************************
* + + S U B R O U T I N E + + + *
* SEE IF UCB IS ABOVE ('A') OR BELOW ('B') THE 16MEG LINE. NOTE THAT *
* THERE IS ONLY AN EXTENSION FOR UCBS IF THEY ARE 'BELOW THE LINE'. *
***********************************************************************
LOCUCB DS ØH
 MVI 48(R3),C'?' DEFAULT IS "DON'T KNOW"
 MODESET MF=(E,SUPMODE) ENTER SUPERVISOR MODE
*
 UCBLOOK DEVN=UCBCHAN, LOOK BY DEVICE ADDRESS X
 UCBPTR=FWORD, TO HOLD A(UCB COMMON SEGMENT) X
 DYNAMIC=YES, INCLUDE DYNAMIC UCBS X
 RANGE=ALL, 3 AND 4 DIGIT UCBS X
 NOPIN, DON'T PIN UCB X
 LOC=ANY ABOVE AND BELOW THE LINE
*
 LTR R15,R15 SUCCESSFUL?
 BNZ RESET NO...LEAVE AS DEFAULT
 MODESET MF=(E,PROBMODE) RETURN TO PROBLEM MODE
 MVI 48(R3),C'A' DEFAULT IS 'A'BOVE
 L R1,FWORD GET UCB ADDRESS
 C R1,=F'16777216' ABOVE 16M?
 BHR R9 YES..RETURN
 MVI 48(R3),C'B' NO...MAKE IT 'B'ELOW
 BR R9 RETURN FROM ROUTINE
RESET DS ØH
 MODESET MF=(E,PROBMODE) RETURN TO PROBLEM MODE
 BR R9 RETURN FROM ROUTINE
***********************************************************************
* + + S U B R O U T I N E + + + *
* FIND WHICH CTLUNIT THE ADDRESS IS ON: HDS, SVA, ESS, ETC... *
***********************************************************************
FINDCTL DS ØH
 LA R1,CTLRTAB LOCATE CTLUNIT TABLE
 LA R2,CTLENTS NUMBER OF ENTRIES
 L R1Ø,FWORD2 GET BINARY CUU VALUE
FINDLOOP DS ØH
 L R6,Ø(R1) GET LOW RANGE ADDRESS
 CR R1Ø,R6 CUU EQUAL?
 BL FINDBUMP LOW - NOT IN RANGE, TRY NEXT
 L R6,4(R1) GET HIGH RANGE ADDRESS
 CR R1Ø,R6 CUU EQUAL?
 BH FINDBUMP HIGH - NOT IN RANGE, TRY NEXT
 MVC CTLUNIT,8(R1) IN RANGE - SAVE CTLUNIT NAME
 BR R9 RETURN FROM ROUTINE
FINDBUMP DS ØH
 LA R1,16(R1) BUMP TO NEXT ENTRY
 BCT R2,FINDLOOP KEEP LOOKING
 BR R9 RETURN FROM ROUTINE
 EJECT
*--------------------------------------------------------------------*
*
 LTORG LITERAL POOL
*
OFFLINE DC CL7'OFFLINE'
ONLINE DC CL7'ONLINE '
BOXED DC CL7'BOXED '
ALLOC DC CL7'ALLOC '
PRIVATE DC CL7'PRIVATE'
PUBLIC DC CL7'PUBLIC '
STORAGE DC CL7'STORAGE'
SHARE DC CL13'SHAREABLE'
NONSHARE DC CL13'NON-SHAREABLE'
HEXTAB DC C'Ø123456789ABCDEF'
LETTERS DC X'ØAØBØCØDØEØF'
NUMBERS DC X'ØØØ1Ø2Ø3Ø4Ø5Ø6Ø7Ø8Ø9'
FWORD DS F
FWORD2 DS F
DWORD DS D
F4DSCB DS CL96
F4ERRMSG DS CL3Ø
QUERIES DC CL4'????'
CUU DS CL4
VOLID DS CL6
SWITCH DC X'ØØ' SWITCH FIELD
FOUND1 EQU X'Ø1'
GENERIC EQU X'Ø2'
RANGE EQU X'Ø4'
GETDASD EQU X'Ø8'
MSGSENT EQU X'Ø4'
ALLUCBS EQU X'1Ø'
ONECUU EQU X'2Ø'
ONEVOLID EQU X'4Ø'
ONLIN EQU X'8Ø'
RETC DS F
UCBAREA DS XL48 HOLDS UCB COMMON & DEV SEGS
UCBWORK DS XL1ØØ UCBSCAN WORKAREA
UNPKFLD DS CL5
RETCD DS F
REASN DS F
SUPMODE MODESET KEY=ZERO,MODE=SUP,MF=L
PROBMODE MODESET KEY=NZERO,MODE=PROB,MF=L
*
* Ø 1 2 3 4 5 6 7 8 9 A B C D E F
TRTAB DC X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' Ø
 DC X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' 1
 DC X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' 2
 DC X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' 3
 DC X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' 4
 DC X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' 5
 DC X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' 6
 DC X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' 7
 DC X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' 8
 DC X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' 9
 DC X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' A
 DC X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' B
 DC X'FFØØØØØØØØØØØØFFFFFFFFFFFFFFFFFF' C (ABCDEF)
 DC X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' D
 DC X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' E
 DC X'ØØØØØØØØØØØØØØØØØØØØFFFFFFFFFFFF' F (Ø123456789)
*
* THIS TABLE HOLDS THE RANGE OF ADDRESSES FOR EACH CONTROL UNIT (IN
* ITS DECIMAL EQUIVALENT).
*
TRTAB2 DC CL16'Ø123456789ABCDEF'
*
CTLRTAB DS ØF
 DC F'Ø1Ø24',F'Ø1279',C' H.D.S. ' Ø4ØØ-Ø4FF HDS
 DC F'Ø1792',F'Ø2Ø47',C' RVA1 ' Ø7ØØ-Ø7FF RVA1
 DC F'Ø4Ø96',F'Ø8191',C' SVA1 ' 1ØØØ-13FF SVA1
 DC F'Ø8192',F'12287',C' SVA2 ' 2ØØØ-23FF SVA2
 DC F'12288',F'13311',C' SVA3 ' 3ØØØ-33FF SVA3
 DC F'16384',F'174Ø7',C' SVA4 ' 4ØØØ-43FF SVA4
CTLENTS EQU (*-CTLRTAB)/16 NUMBER OF TABLE ENTRIES
CTLNFND DC CL8'????????'
CTLUNIT DC CL8' '
*
MSG3 DC CL8Ø' '
MSG3L EQU *-MSG3
*
MSGB DC C'>>> ERROR IN CALL TO "UCBSCAN"...RC=X''..'', RS=X''..'X
 '.'
MSGBTXT1 EQU MSGB+38,2
MSGBTXT2 EQU MSGB+48,2
MSGBL EQU *-MSGB
*---------------------------------------------------------------------*
* REPORT DCB... *
*---------------------------------------------------------------------*
REPORT DCB DDNAME=REPORT,DSORG=PS,LRECL=8Ø,MACRF=PM,BLKSIZE=8Ø
*---------------------------------------------------------------------*
* REGISTERS EQUATES, ETC... *
*---------------------------------------------------------------------*
YREGS
 PRINT ON,GEN
UCBDEF DSECT
 IEFUCBOB
 PRINT NOGEN
 CVT DSECT=YES
*
 END , END OF PROGRAM