CTITLEJSTXGL -- READS FIRST TXAN GLOBAL FILE RECORD FOR JSCORE 00000100 C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CA AUTHOR DANIEL POLAK 00000300 CA DESIGNER DANIEL POLAK 00000400 CA LANGUAGE FORTRAN H 00000500 CA SYSTEM IBM (SEE CRAY - DUMMY) 00000600 CA WRITTEN 06-24-83 00000700 C REVISED 05-09-84 DJP - USE ALL POSSIBLE DISTRICT NUMBERS IN 00000800 C THE CATALOG SEARCH FOR THE GLOBAL FILE 00000900 C REVISED 02-15-85 LBL - DUMMY CALL TO FGTRCE. 00001000 C COMMENTED OUT EXTERNAL. 00001100 C REVISED 03-03-86 JBC - UPDATED CURRENT DISTRICT NUMBERS. 00001110 C REVISED 06/16/87 REM. CHANGED ABSTRACT TO REFLECT CRAY VERSION. 00001110 CA 00001200 CA CALL JSTXGL (KPNA, KPRNO, DSN, DISTNO, IPR, IER, RECORD) 00001300 CA 00001400 CA IN/OUT ARGUMENT TYPE DESCRIPTION 00001500 CA 00001600 CA IN KPNA A4 PROCESS NAME 00001700 CA IN KPRNO I4 PROCESS NUMBER 00001800 CA IN DSN I4 GLOBAL FILE DATASET NUMBER 00001900 CA IN DISTNO I4 DISTRICT NUMBER FROM ACCT CARD 00002000 CA IN IPR I4 INTERNAL PRINT UNIT NUMBER 00002100 CA OUT IER I4 ERROR RETURN FLAG = -1 ON ERROR 00002200 CA OUT RECORD I4 FIRST RECORD FROM THE GLOBAL FILE 00002300 CA 00002400 CA 00002500 CA JSTXGL READS THE FIRST RECORD FROM THE TXAN GLOBAL FILE. 00002600 CA 00002700 C 00002800 SUBROUTINE JSTXGL (KPNA, KPRNO, DSN, DISTNO, IPR, IER, RECORD) 00002900 C 00003000 IMPLICIT INTEGER (A-Z) 00003100 C 00003200 C EXTERNAL FGTRCE 00003300 C 00003400 C INTEGER ARRAY IN THE PARAMETER LIST 00003500 C 00003600 INTEGER RECORD (1) 00003700 C 00003800 C INTEGER ARRAYS -- LOCAL 00003900 C 00004000 INTEGER CATN (11) /'DXX.', 'DNNN', 'NNNN', 8*' '/ 00004100 INTEGER DIST (45) /'D01.', 'D02.', 'D03.', 'D04.', 'D05.',00004200 * 'D06.', 'D07.', 'D08.', 'D09.', 'D11.',00004300 * 'D12.', 'D15.', 'D16.', 'D17.', 'D18.',00004400 * 'D19.', 'D20.', 'D21.', 'D30.', 'D31.',00004500 * 'D32.', 'D33.', 'D40.', 'D41.', 'D44.',00004600 * 'D50.', 'D51.', 'D52.', 'D54.', 'D60.',00004601 * 'D61.', 'D64.', 'D70.', 'D71.', 'D74.',00004602 * 'D80.', 'D81.', 'D82.', 'D84.', 'D90.',00004603 * 'D91.', 'D92.', 'D94.', 'D98.', 'D99.'/00004604 INTEGER DSNAME (11) 00004700 C 00004800 C REAL VARIABLES -- LOCAL 00004900 C 00005000 REAL*8 DDNAME /' '/ 00005100 REAL*8 DSNUM 00005200 C 00005300 C INTEGER CONSTANT -- LOCAL 00005400 C 00005500 INTEGER NDIST /45/ 00005600 C 00005700 C 00005800 C 00005900 IF (1 .EQ. 2) CALL FGTRCE 00006000 C 00006100 C SEARCH FOR THE CATALOG FOR THE DATASET NAME 00006200 C 00006300 CALL S1BNCV (DSN, DSNUM, 1, 8) 00006400 CALL S1MVCH (DISTNO, 3, CATN, 2, 2) 00006500 CALL S1MVCH (DSNUM, 2, CATN, 6, 7) 00006600 CALL USCATS (CATN, DSNAME, DSCNT, VOLCNT) 00006700 IF (DSCNT .GT. 0) GO TO 20 00006800 C 00006900 C CHECK THROUGH ALL POSSIBLE DISTRICT NUMBERS 00007000 C 00007100 DO 10 I = 1, NDIST 00007200 CATN(1) = DIST(I) 00007300 CALL USCATS (CATN, DSNAME, DSCNT, VOLCNT) 00007400 IF (DSCNT .GT. 0) GO TO 20 00007500 C 00007600 10 CONTINUE 00007700 C 00007800 C DATASET NOT FOUND IN THE CATALOG 00007900 C 00008000 GO TO 40 00008100 C 00008200 C ALLOCATE AND OPEN THE GLOBAL FILE 00008300 C 00008400 20 CALL USAOLD (DSNAME, DDNAME, DCBADR, ERR1, ERR2) 00008500 IF (ERR1 .NE. 1) GO TO 50 00008600 CALL FGIRTR (DCBADR, LEN, ERR1) 00008700 IF (ERR1 .NE. 1) GO TO 60 00008800 C 00008900 C READ THE FIRST RECORD 00009000 C 00009100 CALL FGRTR (DCBADR, RECORD, LEN, ERR1) 00009200 IF (ERR1 .NE. 1 .AND. ERR1 .NE. 4) GO TO 70 00009300 C 00009400 C UNALLOCATE THE GLOBAL FILE 00009500 C 00009600 CALL UGUNAL (DCBADR, ERR1, ERR2) 00009700 C 00009800 30 RETURN 00009900 C 00010000 C ERROR DIAGNOSTICS 00010100 C 00010200 40 WRITE (IPR, 9000) DSNUM, KPNA, KPRNO 00010300 IER = -1 00010400 GO TO 30 00010500 C 00010600 50 WRITE (IPR, 9010) KPNA, KPRNO, ERR1, ERR2 00010700 IER = -1 00010800 GO TO 30 00010900 C 00011000 60 WRITE (IPR, 9020) KPNA, KPRNO 00011100 IER = -1 00011200 GO TO 30 00011300 C 00011400 70 WRITE (IPR, 9030) KPNA, KPRNO, ERR1 00011500 IER = -1 00011600 GO TO 30 00011700 C 00011800 C FORMAT STATEMENTS 00011900 C 00012000 9000 FORMAT (/' *** DATASET FOR DSN = ',A8,' NOT FOUND IN CATALOG ', 00012100 * 'FOR PROCESS = ',A4,I1) 00012200 C 00012300 9010 FORMAT (/' *** ALLOCATION OF THE PERMANENT FILE FAILED FOR ', 00012400 * 'PROCESS = ',A4,I1,' ERROR1 = ',I5,' ERROR2 = ',Z8) 00012500 C 00012600 9020 FORMAT (/' *** OPEN OF THE PERMANENT FILE FAILED FOR PROCESS = ', 00012700 * A4,I1) 00012800 C 00012900 9030 FORMAT (/' *** READ FROM THE PERMANENT FILE FAILED FOR PROCESS ', 00013000 * '= ',A4,I1,' ERROR CODE = ',I5) 00013100 END 00013200