CTITLESAPK04 - SUBROUTINE USED BY SDPICK 00010000 C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CA 00020000 CA DESIGNER P. C. LUH 00030000 CA AUTHOR P. C. LUH 00040000 CA LANGUAGE FORTRAN 00050000 CA SYSTEM IBM ONLY 00060000 CA DATE MM/DD/YY 00070000 C REVISED 03/06/86 LBL OLD NAME = DYNAM 00080000 C REVISED 05/13/86 ESN CHANGE 'TSODA' TO 'TSODBG'. 00090000 C REVISED 06/04/86 ESN CHANGE 'TSODBG' TO 'IASEIS'. 00100000 C REVISED 09/24/86 ESN ALLOCATE TO MSS INSTEAD OF DISK00110000 C AND CALL FOSMS AND FOWTDS. 00120000 C REVISED 03/29/88 ESN ALLOCATE TO DISK INSTEAD OF MSS00130000 C 00140000 CA 00150001 CA CALL SAPK04 (DSN, FTNAME, KUNIT, IPR, IERR) 00160001 CA INPUT DSN = DATA SET NAME C44 00170001 CA INPUT FTNAME = FIO NAME OF DATA SET C 00180001 CA INPUT KUNIT = UNIT NUMBER OF DATA SET I4 00190001 CA INPUT IPR = PRINT UNIT NUMBER I4 00200001 CA I/O IERR = ERROR FLAG I4 00210001 CA INPUT = 0 ==> ALLOCATE OLD DATASET 00220001 CA INPUT <,> 0 ==> ALLOCATE NEW DATASET 00230001 CA OUTPUT = 998 ==> ERROR FROM FOWTDS 00240001 CA 00250001 CA SUBROUTINE SAPK04 ALLOCATES THE OUTPUT PICK FILE 00260001 CAEND 00270001 C SUBROUTINE DYNAM (DSN, FTNAME, KUNIT, IPR, IERR) 00280001 SUBROUTINE SAPK04 (DSN, FTNAME, KUNIT, IPR, IERR) 00290001 C 00300000 IMPLICIT INTEGER(A-Z) 00310000 C 00320000 C COMMON /P/ STATEMENTS GENERATED BY UTCGI4 11/30/83 00330000 COMMON /P/ STARTP ( 2) , M00000( 29) 00340000 COMMON /P/ ACLNAM ( 5) , M00124( 68) 00350000 COMMON /P/ KPNA 00360000 COMMON /P/ KPRNO , M00420( 11) 00370000 COMMON /P/ KPFCF 00380000 COMMON /P/ KPIRSM 00390000 COMMON /P/ KPNRSM 00400000 COMMON /P/ KPIUSM 00410000 COMMON /P/ KPNUSM , M00484 00420000 COMMON /P/ KPRTF , M00492( 6) 00430000 COMMON /P/ KPLOTF 00440000 COMMON /P/ KPMITF 00450000 COMMON /P/ KPPRNT , M00528( 2) 00460000 COMMON /P/ KPBUGF , M00540( 226) 00470000 COMMON /P/ ENDP 00480000 C 00490000 PARAMETER(LEN=15) 00500001 C 00510000 C CHARACTER ARRAYS -- LOCAL 00520001 C 00530001 CHARACTER*8 PARMS (LEN) 00540001 C 00550001 C CHARACTER VARIABLES -- LOCAL 00560001 C 00570001 CHARACTER*44 DSM 00580001 CHARACTER*44 DSN 00590001 CHARACTER*(*) FTNAME 00600001 CHARACTER*8 OUTPUT 00610001 CHARACTER*300 SMSLIN 00620000 C 00630000 C INTEGER ARRAYS -- LOCAL 00640001 C 00650001 INTEGER IPARMS (2,LEN) 00660001 INTEGER KEYS (LEN) 00670001 INTEGER PROC20 (21) 00680001 INTEGER TEMPDS (20) 00690001 C 00700000 EQUIVALENCE (PARMS,IPARMS) 00710000 C 00720000 C DATA STATEMENTS 00730001 C 00740001 DATA BLKSIZ / Z30 / 00750001 DATA BLOCK / Z09 / 00760001 DATA COND / Z06 / 00770001 DATA DDNAME / Z01 / 00780001 DATA DISK / 'DISK' / 00790001 DATA DSORG / Z3C / 00800001 DATA GETVOL / Z5D / 00810001 DATA LRECL / Z42 / 00820001 DATA NORM / Z05 / 00830001 DATA OUTPUT / 'OUTPUT ' / 00840001 DATA PRIMAR / Z0A / 00850001 DATA PROC20 / 1, 'PICK', 19*' ' / 00860001 DATA RECFM / Z49 / 00870001 DATA RELEAS / Z0D / 00880001 DATA RETPD / Z23 / 00890001 DATA SECOND / Z0B / 00900001 DATA STATUS / Z04 / 00910001 DATA UNIT / Z15 / 00920001 C 00930000 C INITIALIZATION 00940001 C 00950001 NUNIT = LEN 00960000 IF(IERR.EQ.0) NUNIT=2 00970000 KEYS(1) = DDNAME 00980000 KEYS(2) = STATUS 00990000 KEYS(3) = UNIT 01000000 KEYS(4) = BLOCK 01010000 KEYS(5) = PRIMAR 01020000 KEYS(6) = SECOND 01030000 KEYS(7) = RECFM 01040000 KEYS(8) = LRECL 01050000 KEYS(9) = BLKSIZ 01060000 KEYS(10)= RELEAS 01070000 KEYS(11)= NORM 01080000 KEYS(12)= COND 01090000 KEYS(13)= GETVOL 01100000 KEYS(14)= DSORG 01110000 KEYS(15)= RETPD 01120000 C 01130001 PARMS(1) = FTNAME 01140000 PARMS(2) = 'NEW' 01150000 IF(IERR.EQ.0) PARMS(2)='OLD' 01160000 PARMS(3) = 'SDADA' 01170001 IPARMS(2,4) = 3120 01180000 IPARMS(2,5) = 50 01190000 IPARMS(2,6) = 50 01200000 PARMS(7) = 'FB' 01210000 IPARMS(2,8) = 80 01220000 IPARMS(2,9) = 3120 01230000 PARMS(10)= ' ' 01240000 PARMS(11)= 'CATLG' 01250000 PARMS(12)= 'DELETE' 01260000 PARMS(13)= ' ' 01270000 PARMS(14)= 'PS' 01280000 IPARMS(2,15)= 30 01290000 KERR=IERR 01300000 C 01310000 CALL DDALOC (NUNIT, KEYS, PARMS, DSN, IERR, JERR) 01320001 WRITE (IPR,239) IERR,JERR 01330000 C 01340000 IF (IERR .EQ. 0) GO TO 1000 01350001 WRITE(IPR,999) 01360000 RETURN 01370000 C 01380000 1000 CONTINUE 01390000 WRITE (IPR,35) PARMS(13) 01400000 C 01410000 CALL UPDSNB (DSN, PROC20, 0, SMSLIN) 01420000 SMSLIN(1:1) = 'O' 01430000 CALL FOSMS (SMSLIN) 01440000 C 01450000 TEMPDS(1) = KPNA 01460000 TEMPDS(2) = KPRNO 01470000 TEMPDS(3) = DISK 01480001 CALL S1MVCH (OUTPUT,1,TEMPDS(4),1, 8) 01490000 CALL S1MVCH (DSN, 1,TEMPDS(6),1,44) 01500000 KERR = 1 01510000 CALL FOWTDS (TEMPDS, 1, KERR) 01520000 IF (KERR .EQ. 1) GO TO 2000 01530000 C 01540000 WRITE(IPR,998) 01550000 IERR = 998 01560000 RETURN 01570000 C 01580000 2000 OPEN (KUNIT,FILE=FTNAME) 01590001 C 01600000 RETURN 01610000 C 01620000 ENTRY FREEFL (KUNIT,IPR) 01630001 C 01640000 NUNIT = 1 01650000 DSM = ' ' 01660000 CALL DDFREE (NUNIT,KEYS,PARMS,DSM,KERR,JERR) 01670001 WRITE (IPR,110) KERR,JERR 01680000 C 01690000 RETURN 01700000 C 01710000 C FORMATS 01720001 C 01730001 35 FORMAT (' ALLOCATION WAS SUCCESSFUL ON ',A8) 01740001 C 01750001 110 FORMAT (' FROM DDFREE, IERR=',I4,', JERR=',Z10) 01760001 C 01770001 239 FORMAT (' FROM DDALOC, IERR=',I4,', JERR=',Z10) 01780001 C 01790001 998 FORMAT (///' ***** STOP ***** FOWTDS CALL UNSUCCESSFUL ******') 01800001 C 01810001 999 FORMAT (///' ***** STOP ***** ALLOCATION UNSUCCESSFUL ******') 01820001 C 01830001 END 01840000