The date on the COBOL program is 2005. Sent from Proton Mail mobile
-------- Original Message -------- On May 5, 2023, 7:06 PM, Farley, Peter wrote: > Took me a while to find it, but I *think* this is my re-implementation for > TIOT access in Rexx when SWA=ABOVE (I know I copied this technique from > another author whose name I did not save, so my apologies to that author - if > you are still reading this list, please take credit where it is due). Notes > about errors or omissions in the below logic are welcomed. The date on the > source member where I found these routines was 2006, so things may be > different now. I haven't had a need to use this code since 2006, and I can't > test it again right at this moment. If I can find any round tuits I can try > to convert the logic to valid Enterprise COBOL and test it. If someone else > has the time now, please be my guest and let us know your results. Peter > --------------------------- alldsn: procedure parse upper arg ddname nextdsn > = getdsn(ddname) dsnlist = '' do xi = 1 by 1 while nextdsn /= (ddname 'NOT > FOUND') dsnlist = dsnlist nextdsn nextdsn = getdsn(ddname'+'xi) end if xi = 1 > then , dsnlist = nextdsn return dsnlist getdsn: procedure parse upper arg > ddname parse var ddname ddname '+' concat if concat = '' then concat = 0 > tcb_address = storage(21C,4) tiot_address = > storage(d2x(c2d(tcb_address)+12),4) dd_address = d2x(c2d(tiot_address)+28) > dd_length = storage(d2x(c2d(tiot_address)+24),1) tiot_address = > d2x(c2d(tiot_address)+24) jfcb_address = storage(d2x(x2d(tiot_address)+12),3) > do while dd_length /= '00'x if storage(dd_address,8) = ddname then leave > tiot_address = d2x(x2d(tiot_address)+c2d(dd_length)) dd_length = > storage(tiot_address,1) dd_address = d2x(x2d(tiot_address)+4) jfcb_address = > storage(d2x(x2d(tiot_address)+12),3) end if dd_length = '00'x then return > ddname 'NOT FOUND' do concat tiot_address = > d2x(x2d(tiot_address)+c2d(dd_length)) dd_length = storage(tiot_address,1) > dd_address = d2x(x2d(tiot_address)+4) jfcb_address = > storage(d2x(x2d(tiot_address)+12),3) if dd_length = '00'x then return ddname > 'NOT FOUND' if storage(dd_address,8) /== ' ' then , return ddname 'NOT FOUND' > end return strip(storage(d2x(c2d(jfcb_address)+16),44),'T') > ------------------------- -----Original Message----- From: IBM Mainframe > Discussion List On Behalf Of Farley, Peter Sent: Friday, May 5, 2023 5:58 PM > To: IBM-MAIN@LISTSERV.UA.EDU Subject: Re: COBOL to dynamic DD name EXTERNAL > EMAIL That logic is fine for SWA below the line, but I don't think many shops > still run that way, at least not the larger ones. ISTR there was at one time > a published Rexx implementation of the SWA-above logic, but I can't put my > finger on it just yet. That logic (if found) should be transferable to > Enterprise COBOL. Peter -----Original Message----- From: IBM Mainframe > Discussion List On Behalf Of rpinion865 Sent: Friday, May 5, 2023 2:00 PM > To: IBM-MAIN@LISTSERV.UA.EDU Subject: COBOL to dynamic DD name I don't know > if this program is of any use to the original poster. But, I came across the > source this afternoon. It would seem if you can read the JFCB, maybe you > could update it? IDENTIFICATION DIVISION. PROGRAM-ID. COBJFCB. INSTALLATION. > AUTHOR. KEVIN. DATE-WRITTEN. 11/07/2005. ENVIRONMENT DIVISION. INPUT-OUTPUT > SECTION. DATA DIVISION. FILE SECTION. WORKING-STORAGE SECTION. 01 > TCB-ADDRESS-POINTER. 05 TCB-ADDR-POINTER USAGE IS POINTER. 01 TIOT-SEG-POINT. > 05 TIOT-SEG-POINTER USAGE IS POINTER. 05 TIOT-SEG-PNT REDEFINES > TIOT-SEG-POINTER PIC S9(9) COMP. 01 JFCB-POINT. 05 JFCB-POINTER USAGE IS > POINTER. 05 JFCB-POINT-RED REDEFINES JFCB-POINTER. 10 FILLER PIC X. 10 > JFCB-LOW-3 PIC X(3). LINKAGE SECTION. 01 DDNAME-DSN-ARRAY. 05 DDNAME-DSN > OCCURS 100 TIMES INDEXED BY NDX1. 10 DDA-DDNAME PIC X(8). 10 DDA-DSN PIC > X(44). 01 TCB-POINTER USAGE IS POINTER. 01 TCB. 05 FILLER PIC X(12). 05 > TIOT-POINTER USAGE IS POINTER. 01 TIOT-START PIC X(24). 01 TIOT-SEG. 05 > TIO-LEN PIC X. 05 FILLER PIC X(3). 05 DD-NAME PIC X(8). 05 JFCB-ADDR PIC > X(3). 01 JFCB. 05 FILLER PIC X(16). 05 DS-NAME PIC X(44). PROCEDURE DIVISION > USING DDNAME-DSN-ARRAY. MOVE LOW-VALUES TO JFCB-POINT. MOVE X'0000021C' TO > TCB-ADDRESS-POINTER. SET ADDRESS OF TCB-POINTER TO TCB-ADDR-POINTER. SET > ADDRESS OF TCB TO TCB-POINTER. SET ADDRESS OF TIOT-START TO TIOT-POINTER. SET > TIOT-SEG-POINTER TO TIOT-POINTER. ADD 24 TO TIOT-SEG-PNT. SET ADDRESS OF > TIOT-SEG TO TIOT-SEG-POINTER. SET NDX1 TO 1. PERFORM UNTIL TIO-LEN = > LOW-VALUES OR NDX1 > 100 MOVE DD-NAME TO DDA-DDNAME(NDX1) MOVE JFCB-ADDR TO > JFCB-LOW-3 SET ADDRESS OF JFCB TO JFCB-POINTER MOVE DS-NAME TO DDA-DSN(NDX1) > DISPLAY DDA-DDNAME(NDX1) DDA-DSN(NDX1) ADD 20 TO TIOT-SEG-PNT SET ADDRESS OF > TIOT-SEG TO TIOT-SEG-POINTER SET NDX1 UP BY 1 END-PERFORM. GOBACK. -- This > message and any attachments are intended only for the use of the addressee > and may contain information that is privileged and confidential. If the > reader of the message is not the intended recipient or an authorized > representative of the intended recipient, you are hereby notified that any > dissemination of this communication is strictly prohibited. If you have > received this communication in error, please notify us immediately by e-mail > and delete the message and any attachments from your system. > ---------------------------------------------------------------------- For > IBM-MAIN subscribe / signoff / archive access instructions, send email to > lists...@listserv.ua.edu with the message: INFO IBM-MAIN This message and any > attachments are intended only for the use of the addressee and may contain > information that is privileged and confidential. If the reader of the message > is not the intended recipient or an authorized representative of the intended > recipient, you are hereby notified that any dissemination of this > communication is strictly prohibited. If you have received this communication > in error, please notify us immediately by e-mail and delete the message and > any attachments from your system. > ---------------------------------------------------------------------- For > IBM-MAIN subscribe / signoff / archive access instructions, send email to > lists...@listserv.ua.edu with the message: INFO IBM-MAIN ---------------------------------------------------------------------- For IBM-MAIN subscribe / signoff / archive access instructions, send email to lists...@listserv.ua.edu with the message: INFO IBM-MAIN
