CTITLEUSALLOC -- BUILD PARAMETER LISTS, CALL DDALOC, RETURN DCB 00010000 C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CA AUTHOR RALPH MCMILLAN 00020000 CA DESIGNER RALPH MCMILLAN 00030000 CA LANGUAGE VS FORTRAN 00040000 CA SYSTEM IBM (SEE CRAY) 00050000 CA WRITTEN 10-22-87 00060000 C REVISED 01/07/88 REM. CHANGE FROM CYLINDER TO TRACK ALLOCATION. 00070000 C REVISED 02/25/88 REM. ADD BLOCK SIZE TO PARAMETER LIST AND TO 00080000 C DDALOC. 00090000 C REVISED 06/16/88 ESN. ADD RECORD LENGTH TO PARAMETER LIST 00100000 C AND TO DDALOC. 00110000 C REVISED 10/08/93 REM. CHANGE EXPDT TO 99365 00120000 CA 00130000 CA CALL USALLOC (DSNAME, UNIT, MSVGP, RECFM, BLKSIZ, LRECL, 00140000 CA PRI, SEC, VOLCNT, DSORG, PERMA, FREEC, DCBTYP, 00150000 CA DDNAME, DCBADR, ERR, ERRIN) 00160000 CA 00170000 CA IN/OUT ARGUMENT TYPE DESCRIPTION 00180000 CA IN DSNAME CH44 DATA SET NAME 00190000 CA IN UNIT CH6 UNIT NAME OF OUTPUT DEVICE 00200000 CA IN MSVGP CH6 MASS STORAGE GROUP NAME. WILL BE BLANK IF00210000 CA NOT ALLOCATING MASS STORAGE. 00220000 CA IN RECFM CH4 RECORD FORMAT ("U", "UT", OR "F") 00230000 CA IN BLKSIZ I4 BLOCK SIZE 00240000 CA IN LRECL I4 RECORD LENGTH 00250000 CA IN PRI I4 PRIMARY NUMBER OF TRACKS TO ALLOCATE 00260000 CA IN SEC I4 SECONDARY NUMBER OF TRACKS TO ALLOCATE 00270000 CA IN VOLCNT I4 VOLUME COUNT. WILL BE 0 FOR TAPE IF 00280000 CA CALCULATED NUMBER IS < 6 00290000 CA IN DSORG CH4 DATA SET ORGANIZATION ("PS" OR "DA") 00300000 CA IN PERMA I4 PERMANENTLY ALLOCTED ATTRIBUTE FLAG 00310000 CA 0 - DO NOT USE 00320000 CA 1 - ALLOCATE WITH PERM. ALLOC. ATTRIBUTE 00330000 CA (UNIRAS META FILES ONLY) 00340000 CA IN FREEC I4 FREE ON CLOSE FLAG 00350000 CA 0 - DO NOT FREE ON CLOSE 00360000 CA 1 - FREE ON CLOSE (UNIRAS META FILES ONLY)00370000 CA IN DCBTYP I4 FLAG FOR TYPE OF DCB TO RETURN. 00380000 CA 0 - NORMAL QSAM DCB 00390000 CA 1 - BSAM DCB TO CREATE DIRECT ACCESS FILE 00400000 CA IN/OUT DDNAME CH8 DD NAME. IF BLANK A SYSTEM SUPPLIED NAME 00410000 CA WILL BE RETURNED. 00420000 CA OUT DCBADR I4 ADDRESS OF A GETMAINED DCB 00430000 CA OUT ERR I4 ERROR CODE. 00440000 CA 0 - OK. 00450000 CA 1000 - ERROR IN OBTAINING DCB. 00460000 CA OTHER NON ZERO - ERROR FROM DDALOC. 00470000 CA OUT ERRIN I4 CODES FROM DYNAMIC ALLOCATION (SVC 99). 00480000 CA BYTES 1 AND 2 - ERROR CODE. 00490000 CA BYTES 3 AND 4 - INFORMATION CODES. 00500000 CA 00510000 CA 00520000 CA THIS SUBROUTINE USES THE INPUT PARAMETERS TO BUILD THE ARRAYS 00530000 CA NECESSARY FOR DDALOC AND THEN CALLS DDALOC. 00540000 CA 00550000 CA THIS ROUTINE WILL ALWAYS ADD THE FOLLOWING PARAMETERS: 00560000 CA NEW 00570000 CA CATALOG 00580000 CA RELEASE 00590000 CA TRACK ALLOCATION 00600000 CA 00610000 CA IF AN ERROR OCCURS IN OBTAINING THE DCB AREA, THEN THE ALLOCATED 00620000 CA DATA SET IS DELETED AND A MESSAGE IS PRINTED ON UNIT 6. 00630000 CA 00640000 CA 00650000 CA 00660000 C 00670000 C 00680000 C VARIABLE DESCRIPTION 00690000 C 00700000 C NAME TYPE DESCRIPTION 00710000 C 00720000 C IKEY I4 ARRAY TO HOLD THE ALLOCATION KEYS. 00730000 C IPARMA CH8 ARRAY TO HOLD THE CHARACTER ALLOCATION PARAMETERS 00740000 C IPARMI I4 ARRAY TO HOLD THE INTEGER ALLOCATION PARAMETERS 00750000 C MXKEY I4 MAXIMUM NUMBER OF KEYS ALLOWED (ARRAY SIZE). 00760000 C 00770000 C 00780000 C 00790000 SUBROUTINE USALLOC (DSNAME, UNIT, MSVGP, RECFM, BLKSIZ, LRECL, 00800000 * PRI, SEC, VOLCNT, DSORG, PERMA, FREEC, DCBTYP, 00810000 * DDNAME, DCBADR, ERR, ERRIN) 00820000 C 00830000 IMPLICIT INTEGER (A-Z) 00840000 PARAMETER (MXKEY = 18) 00850000 C-------------------------- PARAMETER LIST VARIABLES 00860000 CHARACTER*8 DDNAME 00870000 CHARACTER*44 DSNAME 00880000 CHARACTER*4 DSORG 00890000 CHARACTER*6 MSVGP 00900000 CHARACTER*4 RECFM 00910000 CHARACTER*6 UNIT 00920000 C-------------------------- INTERNAL ARRAYS 00930000 INTEGER IKEY (MXKEY) 00940000 INTEGER IPARMI (2*MXKEY) 00950000 CHARACTER*8 IPARMA (MXKEY) 00960000 EQUIVALENCE (IPARMA(1), IPARMI(1)) 00970000 C-------------------------- ARRAYS FOR UNALLOCATING 00980000 INTEGER UNALLOCK (3) /1, 4, 5/ 00990000 CHARACTER*8 UNALLOCP (3) /' ','DELETE ',' '/ 01000000 C 01010000 C DDNAME 01020000 C 01030000 IF (DDNAME .NE. ' ') THEN 01040000 IKEY(1) = 1 01050000 IPARMA(1) = DDNAME 01060000 ELSE 01070000 IKEY(1) = 85 01080000 IPARMA(1) = ' ' 01090000 END IF 01100000 C 01110000 C STATUS = NEW 01120000 C 01130000 IKEY(2) = 4 01140000 IPARMA(2) = 'NEW ' 01150000 C 01160000 C DISPOSITION = CATALOG 01170000 C 01180000 IKEY(3) = 5 01190000 IPARMA(3) = 'CATLG ' 01200000 C 01210000 C TRACK SPACE ALLOCATION 01220000 C 01230000 IKEY(4) = 7 01240000 IPARMA(4) = ' ' 01250000 C 01260000 C PRIMARY NUMBER OF TRACKS 01270000 C 01280000 IKEY(5) = 10 01290000 IPARMI(9) = 0 01300000 IPARMI(10) = PRI 01310000 C 01320000 C SECONDARY NUMBER OF TRACKS 01330000 C 01340000 IKEY(6) = 11 01350000 IPARMI(11) = 0 01360000 IPARMI(12) = SEC 01370000 C 01380000 C RELEASE SPACE 01390000 C 01400000 IKEY(7) = 13 01410000 IPARMA(7) = ' ' 01420000 C 01430000 C VOLUME COUNT 01440000 C 01450000 IKEY(8) = 19 01460000 IPARMI(15) = 0 01470000 IPARMI(16) = VOLCNT 01480000 C 01490000 C UNIT 01500000 C 01510000 IKEY(9) = 21 01520000 IPARMA(9) = UNIT 01530000 C 01540000 C BLOCK SIZE 01550000 C 01560000 IKEY(10) = 48 01570000 IPARMI(19) = 0 01580000 IPARMI(20) = BLKSIZ 01590000 C 01600000 C RECORD LENGTH 01610000 C 01620000 IKEY(11) = 66 01630000 IPARMI(21) = 0 01640000 IPARMI(22) = LRECL 01650000 C 01660000 C DATA SET ORGANIZATION 01670000 C 01680000 IKEY(12) = 60 01690000 IPARMA(12) = DSORG 01700000 C 01710000 C RECORD FORMAT 01720000 C 01730000 IKEY(13) = 73 01740000 IPARMA(13) = RECFM 01750000 C 01760000 NKEY = 13 01770000 C 01780000 C NOW DO THE PARAMETERS THAT MAY OR MAY NOT BE REQUIRED 01790000 C 01800000 C MASS STORAGE GROUP NAME 01810000 C 01820000 IF (MSVGP .NE. ' ') THEN 01830000 NKEY = NKEY + 1 01840000 IKEY(NKEY) = 94 01850000 IPARMA(NKEY) = MSVGP 01860000 END IF 01870000 C 01880000 C PERMANENTLY ALLOCATED ATTRIBUTE 01890000 C 01900000 IF (PERMA .NE. 0) THEN 01910000 NKEY = NKEY + 1 01920000 IKEY(NKEY) = 82 01930000 IPARMA(NKEY) = ' ' 01940000 END IF 01950000 C 01960000 C FREE ON CLOSE 01970000 C 01980000 IF (FREEC .NE. 0) THEN 01990000 NKEY = NKEY + 1 02000000 IKEY(NKEY) = 28 02010000 IPARMA(NKEY) = ' ' 02020000 END IF 02030000 C 02040000 C CHECK FOR TAPE PARAMETERS 02050000 C 02060000 IF (DSNAME(5:5) .EQ. 'T') THEN 02070000 C LABEL = SL 02080000 NKEY = NKEY + 1 02090000 IKEY(NKEY) = 30 02100000 IPARMA(NKEY) = 'SL ' 02110000 C EXPIRATION DATE = 99365 02120000 NKEY = NKEY + 1 02130000 IKEY(NKEY) = 34 02140000 IPARMA(NKEY) = '99365 ' 02150000 END IF 02160000 C********************************************************************** 02170000 C*** 02180000 C*** NOW CALL DDALOC TO ALLOCATE THE DATA SET 02190000 C*** 02200000 C********************************************************************** 02210000 C 02220000 CALL DDALOC (NKEY, IKEY, IPARMA, DSNAME, ERR, ERRIN) 02230000 C 02240000 IF (ERR .NE. 0) GO TO 1000 02250000 C CHECK FOR RETURN OF DDNAME 02260000 IF (DDNAME .EQ. ' ') DDNAME = IPARMA(1) 02270000 C 02280000 C GET AND RETURN ADDRESS OF A DCB 02290000 C 02300000 CALL USDCBS (DCBTYP, DDNAME, RECFM, DCBADR, ERR) 02310000 C 02320000 C IF AN ERROR OCCURS IN GETTING DCB, THEN WE MUST DELETE THE 02330000 C ALLOCATED DATA SET BEFORE RETURNING 02340000 C 02350000 IF (ERR .NE. 0) THEN 02360000 UNALLOCP(1) = DDNAME 02370000 CALL DDFREE (3, UNALLOCK, UNALLOCP, DSNAME, ERR, ERRIN) 02380000 IF (ERR .NE. 0) WRITE (6, 9000) DDNAME, DSNAME, ERR, ERRIN 02390000 ERR = 1000 02400000 END IF 02410000 C 02420000 C------------------------------------- EXIT 02430000 1000 RETURN 02440000 C 02450000 9000 FORMAT ('-*** DYNAMIC UNALLOCATION ERROR HAS OCCURRED ON:'/ 02460000 * 5X,'DDNAME=',A8/5X,'DSNAME=',A44/5X,'ERR=',Z8/ 02470000 * 5X,'ERRIN=',Z8) 02480000 C 02490000 END 02500000