/* REXX *** */
PARSE ARG PRINT REST
/* IPCS environment */
/* Analyze allocation internal queues */
/* This may be useful in identifying jobs affected by esoteric */
/*  allocation problems not visible through other tools */
PR2 = ''
IF PRINT = 'PRINT' then PR2 = 'PRINT'
else PR2 = 'NOPRINT'
/* SAVE OLD SETDEF VALUES */
ADDRESS IPCS
'EVALDEF REXX(PRINT(PR1) ',
             'TERMINAL(TE1)'
SCC = RC
IF RC ^= 0 then DO
   SAY 'IPCS NOT ACTIVE'
   EXIT 16
END
/* SET NEW SETDEF VALUES */
IF PR2 ^= '' then ,
   'SETDEF 'PR2
'ANALYZE RESOURCE XREF'
'VERBX ALCWAIT'
"NOTE ' '"
'EVALUATE CVT+294 POINTER LENGTH(4) REXX(STORAGE(csd))'
'EVALUATE 'csd'.+78 UNSIGNED LENGTH(4) REXX(STORAGE(allocs))'
'EVALUATE CVT+224 POINTER LENGTH(4) REXX(STORAGE(aqtop))'
'EVALUATE CVT+22C POINTER LENGTH(4) REXX(STORAGE(asvtp))'
"NOTE 'Tape allocations in progress = "allocs"'"
'EVALUATE 'asvtp'.+204 UNSIGNED LENGTH(4) REXX(STORAGE(maxu))'
asvtp = D2X(X2D(asvtp)+524)
top = aqtop
'EVALUATE 'top'.+4 POINTER LENGTH(4) REXX(STORAGE(next))'
IF top = next then "NOTE 'Allocation queue is empty'"
else DO UNTIL top = next
    'EVALUATE 'next'.+1E UNSIGNED LENGTH(2) REXX(STORAGE(asid))'
    'EVALUATE 'next'.+2C UNSIGNED LENGTH(1) REXX(STORAGE(bits))'
    wait  = bits % 128
    lower = bits // 16
    queues = (bits % 16) // 4
    IF bits % 128 then wait = ''
    else wait = 'waiting'
    IF lower % 8 then wait = wait' device'
    if queues > 1 then wait = wait' A-queue'
    if queues // 2 then wait = wait' B-queue'
    IF asid <= maxu THEN DO
      asof = D2X(4*asid)
      'EVALUATE 'asvtp'.+'asof' UNSIGNED LENGTH(1) REXX(STORAGE(asflg))'
      END
    else DO
      asflg = 150
      name = '** Error **'
      END
    IF asflg < 128 THEN DO
        'EVALUATE 'asvtp'.+'asof' POINTER LENGTH(4) REXX(STORAGE(ascb))'
        'EVALUATE 'ascb'.+AC POINTER LENGTH(4) REXX(STORAGE(jbns))'
        IF jbns = '00000000' then DO
           'EVALUATE 'ascb'.+B0 POINTER LENGTH(4) REXX(STORAGE(jbni))'
           'EVALUATE 'jbni'. CHARACTER LENGTH(8) REXX(STORAGE(name))'
           END
        ELSE 'EVALUATE 'jbns'. CHARACTER LENGTH(8) REXX(STORAGE(name))'
        END
    else ,
        name = '** Missing **'
    "NOTE 'Asid "asid wait name"'"
    'EVALUATE 'next'.+4 POINTER LENGTH(4) REXX(STORAGE(next))'
   END
/* RESTORE ORIGINAL SETDEF VALUES */
'SETDEF 'PR1
EXIT 0