CTITLECSBFSD -- BUILD CSSDAD SUBROUTINE 00010000 C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CA AUTHOR DANIEL POLAK 00020000 CA DESIGNER DANIEL POLAK 00030000 CA LANGUAGE VS FORTRAN 00040000 CA SYSTEM IBM 00050000 CA WRITTEN 06-18-87 00060000 C REVISED 08/20/87 REM. ADD MXPROC AND CHANGE VARIABLE NAMES. 00070000 C REVISED 11/04/87 REM. FILL OUT FORMAT STATEMENT TO 80 CHARACTERS 00080000 C INCREASE SIZE OF PROCLI AND USE VARIABLES 00090000 C AS INDEXES. 00100000 C REVISED 11/12/87 REP. CHANGED FOR CSSDAD BUILD INSTEAD OF CSSDCL 00110000 C BUILD. 00120000 C REVISED 11/24/87 REP. FIX ERROR - NOT 80 CHARACTER LINE. 00130000 C REVISED 12/02/87 REP. CHANGED TO NOT DUPLICATE PROCESSES. 00140000 C REVISED 12/11/87 REP. ADD PRCNDX TO ARG LIST AND FIX ERROR WHEN 00150001 C DUPLICTE DUMMY PTAB ENTRIES EXIST. 00160001 CA 00170001 CA CALL CSBFSD (PROCLC, PROCLI, PRCNDX, MXPROC, NPROC, UNIT) 00180001 CA 00190000 CA IN/OUT ARGUMENT TYPE DESCRIPTION 00200000 CA 00210000 CA IN PROCLC CH4 CHARACTER VARIABLES OF THE PROCESSING LIST00220000 CA IN PROCLI I4 INTEGER VARIABLES OF THE PROCESSING LIST 00230000 CA IN PRCNDX I4 ALPHABETIC INDEX TO THE PROCESSING LIST 00240001 CA IN MXPROC I4 MAXIMUM NUMBER OF PROCESSES ALLOWED 00250000 CA IN NPROC I4 NUMBER OF PROCESSES 00260000 CA IN UNIT I4 FORTRAN I/O UNIT NUMBER FOR SOURCE FILE 00270000 CA 00280000 CA THIS SUBROUTINE BUILDS THE FORTRAN SOURCE CODE FOR SUBROUTINE 00290000 CA CSSDAD. 00300000 CA 00310000 C EJECT 00320000 C 00330000 SUBROUTINE CSBFSD (PROCLC, PROCLI, PRCNDX, MXPROC, NPROC, UNIT) 00340001 C 00350000 IMPLICIT INTEGER (A-Z) 00360000 C 00370000 PARAMETER (IXNA=1, IXPTAB=4) 00380000 C 00390000 C COMMON AREA DECLARATIONS 00400000 C 00410000 COMMON /MPTABI/ NPTAB, PTABI(14, 250) 00420000 COMMON /MPTABC/ PTABC(5, 250) 00430000 CHARACTER*4 PTABC 00440000 INTEGER PTABI 00450000 C 00460000 C CHARACTER ARRAY IN THE PARAMETER LIST 00470000 C 00480000 CHARACTER*4 PROCLC (6, MXPROC) 00490000 C 00500000 C INTEGER ARRAY IN THE PARAMETER LIST 00510000 C 00520000 INTEGER PRCNDX (MXPROC) 00530001 INTEGER PROCLI (15, MXPROC) 00540001 C 00550001 C CHARACTER VARIABLE 00560001 C 00570001 CHARACTER*4 NAMSVE 00580001 C 00590000 C PROGRAM PROLOGUE 00600000 C 00610000 WRITE (UNIT, 1000) 00620000 C 00630000 C EXTERNAL STATEMENTS (ONLY ONE PER PROCESS - NO DUPLICATES) 00640000 C 00650000 NAMSVE = '@#$%' 00660002 DO 10 J = 1, NPROC 00670002 I = PRCNDX(J) 00680001 IPTAB = PROCLI(IXPTAB,I) 00690001 IF (PTABI(2,IPTAB) .GT. 0 .AND. 00700001 + PROCLC(IXNA, I) .NE. NAMSVE ) THEN 00710001 WRITE (UNIT, 1010) PROCLC(IXNA, I) 00720000 NAMSVE = PROCLC(IXNA, I) 00730002 END IF 00740000 10 CONTINUE 00750000 C 00760000 C PROGRAM BODY (ONLY ONE PER PROCESS - NO DUPLICATES) 00770000 C 00780000 WRITE (UNIT, 1020) 00790000 C 00800000 NAMSVE = '@#$%' 00810001 DO 20 J = 1, NPROC 00820001 I = PRCNDX(J) 00830001 IPTAB = PROCLI(IXPTAB,I) 00840000 IF (PTABI(2,IPTAB) .GT. 0 .AND. 00850001 + PROCLC(IXNA, I) .NE. NAMSVE ) THEN 00860001 WRITE(UNIT,1030)PROCLC(IXNA,I),PROCLC(IXNA,I),PROCLC(IXNA,I)00870000 NAMSVE = PROCLC(IXNA, I) 00880002 END IF 00890000 C 00900000 20 CONTINUE 00910000 C 00920000 C PROGRAM EPILOGUE 00930000 C 00940000 WRITE (UNIT, 1040) 00950000 C 00960000 RETURN 00970000 C 00980000 C FORMAT STATEMENTS 00990000 C 01000000 1000 FORMAT (' SUBROUTINE CSSDAD (PROCN, KPA, *) ', 40(' ') / 01010000 * ' CHARACTER*4 PROCN', 56(' ') / 01020000 * ' INTEGER KPA', 58(' ') / 01030000 * ' INTEGER LOCSD', 56(' ')) 01040000 C 01050000 1010 FORMAT (' EXTERNAL SD', A4, 58(' ')) 01060000 C 01070000 1020 FORMAT (' IF (1 .EQ. 2) CALL CSEXEC ', 40(' ')) 01080000 C 01090000 1030 FORMAT (' IF (PROCN .EQ. ''',A4,''') THEN', 47(' ') / 01100000 * ' LOCSD = LOC (SD',A4,')', 54(' ') / 01110000 * ' CALL USSADR (KPA,SD',A4,',LOCSD)', 44(' ') / 01120000 * ' GO TO 10', 66(' ') / 01130000 * ' END IF', 68(' ')) 01140000 C 01150000 1040 FORMAT (' RETURN1', 67(' ') / 01160000 * ' 10 RETURN', 68(' ') / 01170000 * ' END', 71(' ')) 01180000 END 01190000