program GLOCH2 c . Copyright (C) 1996, California Institute of Technology. c . All rights reserved. U. S. Government sponsorship under c . NASA contract NAS7-918 is acknowledged. c>> 2001-11-14 GLOCH2 Krogh Initialized KACT to 0 at start. c>> 1997-05-01 GLOCH2 Krogh Replace some use of LEVEL with FILINF. c>> 1997-05-01 GLOCH2 Krogh Reject unrequested common block output. c>> 1996-07-08 GLOCH2 Krogh Initial Code c Generates global diagnostics and cross reference information from the c files glsave and gltemp generated by gloch1. Input is described in c the comments for gloch1. Only comments for variables used here are c given here. c One can also type "?" to get help. c c ************************ Routines *********************************** c c Main program c c subroutine INIT c Initializes many variables. c subroutine INPUT c Reads and processed user input. c subroutine LOCSTR (CTYP, LS) c subroutine NSORT(KLOC, KTYP) c integer function NSORTC(I, J) c integer function NSORTX(I, J) c subroutine TXTOUT(ERRNAM, ERRTXT) c Prints both error messages, and requested output. c c ******************** Variable Definitions **************************** c c BUF2 Used for temporary storage of two names. c BUFOUT Buffer used to hold output text. c BYFILE in NSORT, .true. if sorting file names, else .false. Also used c in cross ref./who calls to signal entry => file. c CTYPA Used to hold type information. c ERRNAM Name for an error message, blank if none. The following names c have a special meaning. c ' 1' Too many files in the input. c ' 2' Output of type error info. for entries. c ' 3' Output of type error info for types. c ERRTXT Text for an error message. c FILINF is KBGLO*(index of file) + line number in file. c FILNAM Array of file names (8 bytes), described above. Also see LENT. c FMTLAB Character string used as format for printing labels. c GLTYPC Character string used to convert between a type index and a c type letter for global type information. c C Temporary storage of a single character. c C1 Temporary storage of a single character. c C2 Temporary storage of a single character. c I Temporary index. c I1,I2,I3,I4,I5,I6 Used as temporary indices. c IIN Unit number for reading gltemp or scratch file obtained from c gltemp. c IOUT Unit number for scratch file holding info from gltemp. c IDX two dimensional array used to hold indices for the sort order c of files (column 1) and entries/common (column 2). c INDENT Amount to indent for various levels in output of trees. c ISORTD Two dimensional array defining how file (column 1) and entry/ c common block (column 2) names are to be sorted. Rows define sort c keys as follows. c 1 Sort on name c 2 (Entries only) Sort based on how file containing entry is c sorted. c 3 Sort based on maximum distance to any leaf. c 4 Sort based on maximum distance from any root. c -1,-2,-3,-4 Reverse the order of the above sorts. c ISORTS Saved values from previous sorts of ISORTD. c ITEM Used in INPUT to count the number of action arguments seen. c J Temporary index. c J1 ... J9 Temporary indices. c K Temporary index. c K0,K1,K2,K3,K4,K5 Used as temporary indices. c KACT Current action, set in INPUT. c = 1 Set sort on files (only in INPUT). c = 2 Set sort on entries (only in INPUT). c = 3 Set diagnostics desired (only in input). c = 4 List the things specified in LIST. c = 5 Get a cross reference. c = 6 Get a "who calls". c KBxxxx Parameters used to define bits and fields in symbol table c entries. See NAMTYP in comments for gloch1. c KGLENT Pointer to the symbol table entry for a global name. c KGLFRO Pointer to a place in LREF where a list of references from this c entry are stored. If < 0, it points to the primary entry for the c program unit. c KGLNXT Pointer to next entry in the list for a file. Last entry in c list is negative, and its absolute value points to the file. c KGLTO Pointer to a place in LREF where a list of references to this c entry are stored. If this is < 0, this is a common block, and the c absolute value points to the reference list for the common. c KINDI Array with two entries, for item1 and item2 of certain actions. c 1 indicates files c 2 indicates entries. c 3 indicates common blocks c KOMPTY If > 0, then comparing declaration string with a reference c string. Else comparing two references. If < 0, then just starting. c KRECUR Identifies the kind of recursion to be used for output. c -1 Just one entries in a file, or the file an entry is in. c 0 No recursion. c 1 (+) Recursion to obtain a list with lots on a line. c 2 (-) Recursion to obtain a list with one per line. c 3 (*) Recursion to print a tree, one per line. c KSTK Index telling how much has been pushed on the stack. c KSTK1 Used in tracking state for multilevel who calls, etc. c KSTK2 Used in tracking state for multilevel who calls, etc. c KSTKP Index in the stack where print is to start next, (KACT > 4). c KSTKS! In NSORT contains the current location in LREF for the stack. c KSTKS2 In NSORT contains pointer to alternate infor in LREF. c KSTKS3 In NSORT contains index of current file. c KSTKS4 In NSORT contains global entry index. c L Temporary index. c LABELS .true. if item labels are to be attached to names for output. c LENT Array giving the start of a list of entry names associated c with a file. c LEV In NSORT, used to track the current level when computing them. c LEVEL Used to store levels used in a sort. (See ISORTD.) Also used c to track order of things to print when printing. c LEVTYP In NSORT, used to remember the type of levels stored in LEVEL. c LFILE Index of last file name in FILNAM (and LENT). c LGLOB Last index used for KGLENT, KGLTO, and KGLFRO. c LINEW The number of characters on an output line. c LIST Array containing indices of kinds of things to list. c 1 List common block names. c 2 List entry names. c 3 List file names. c 4 List all entry names that are referenced but not defined. c LNAME Last index actually used in NAME for storing names. c LONG Parameter giving the length for a long interface string. c Strings this long or longer will have one copy stored for each use, c those shorter will share space, and thus must have a new copy when c changed. c LREF Array used to track local references. An item pointed to is c one of four types (k indicates value of pointer pointing to entry): c Start of "to" list, pointed to by KGLTO: c LREF(k) Pointer to next LREF entry. c LREF(k-1) Pointer to type info. for entries. (See NAMTYP.) c LREF(k-2) Pointer to alternate type information (0 if none). c LREF(k-3) Pointer to type info. for entry declaration. c Common block information entry. c Same as above, except, c LREF(K-3) Index of last entry making reference to this common. c LREF(K-4) Index of next entry of this type. (=0, if this is c the last case for this common.) c Type information entry: c Same as "to" list, but without the LREF(k-3). Pointed to by c an LREF(k-2). c Item entry, pointed to by KGLFRO or an LREF(k) entry. c LREF(k) Pointer to next LREF entry (0 if none) c LREF(k-1) Pointer to global entry for this item. c LREFL Last index used in LREF (0 initially). c LTYPST Last index used in the character array TYPSTR. c M Temporary index. c MAPxxx Parameters for character mappings. c MAPDIG=3 Digit c MAPOTH=6 Anything else. c MAPARG Maps index for actual arg. for checking with formal arg. c 0 An array element, matches almost anything. c 1 Scalar, matches any scalar. c 2 Expression, matches only scalars with value not set. c 3 Array c 4 Function c 6 A value that should not occur c MAPDUM Maps index for formal arg. for checking with actual arg. c 1 Scalar with value set. c 2 Scalar with value not set (if an actual arg. could be wrong) c 3 An array, value may or may not be set. c 4 Function c 5 A value that should never occur. c MXFILE Parameter giving the maximum number of files that can be c processed. c MXLREF Parameter giving the dimension of LREF. c MXNAME Parameter giving the dimension of NAME, and NAMTYP. c MXSTK Maximum number of items on stack for dealing with parentheses c and the call tree. c MXTLEN Parameter giving the most arguments we can handle in a given c argument list or common block. c MXGLOB Parameter giving the maximum number of global names. c NAME A character*8 array of names, the symbol table of names. c NAMEI1 Array used to hold indices used to sort names for first item. c NAMEI2 Array used to hold indices used to sort names for second item. c NCHAIN Used to track alternate list of "call to's" when printing c cross reference. c NENT Used to save next entry when KACT > 4, and KINDI(1 or 2) = 1. c NEWGLO Index of first global entry that is not obtained from an c earlier processing run. c NOERR If .true. there has been no error in process of checking types c when checking calling sequences. Used to give extra header c information on the first error. c NOSORT Set .true. initially. Set to .false. if sort has been done to c order the information provided in gltemp. c NUM0 ichar('0'). c NXTCOM Index for next common block of same name when checking common c blocks. c RECUR0 set .true. when printing a cross reference or who calls and the c the items are files or entries but the first is different from the c second. Set back to false after the first pass. Causes a "fake" c LREF entry to be created. c REFHED Used to store text for header lines when printing errors in c checking types. c TMPNAM Character string to be hashed. c TXTSTR Used to store text (or blanks) for output of messages connected c with checking types. c TYPSTR Array of character strings containing type information about c arguments, and common blocks. c c ********************** Specifications ******************************** c c Common and parameters required in both GLOCH1 and GLOCH2 integer MXGLOB, MXLREF, MXNAME, MXTYST, MXTLEN parameter (MXGLOB=2020, MXLREF=25000, MXNAME=2333, MXTYST=200, 1 MXTLEN=256) c Misc. Parameters integer LONG, MXFILE parameter (LONG=7, MXFILE=1500) c Parameters used for character mappings integer MAPDIG, MAPOTH parameter (MAPDIG=3, MAPOTH=6) c Parameters associated with bits in symbol table entries. integer KBDEC, KBREF, KBDEF, KBARG, KBDUM, KBCOM, KBPAR, KBDIM, 1 KBEXT, KBGLO, KBDIMW parameter (KBDEC=16, KBREF=32, KBDEF=64, KBARG=128, KBDUM=256, 1 KBCOM=512, KBPAR=1024, KBDIM=2048, KBEXT=32768, KBGLO=65536) parameter (KBDIMW = KBEXT / KBDIM) c character CTYPA*(MXTLEN), FILNAM(MXFILE)*8, GLTYPC*56, 1 NAME(MXNAME)*8, TYPSTR(MXTYST)*(MXTLEN) integer KGLENT(MXGLOB), KGLFRO(MXGLOB), KGLNXT(MXGLOB), 1 KGLTO(MXGLOB), LENT(MXFILE), LFILE, 2 LGLOB, LNAME, LREF(MXLREF), LREFL, LTYPST, MAP(128) common /GLCHRB/ CTYPA, FILNAM, GLTYPC, NAME, TYPSTR common /GLINTB/ KGLENT, KGLFRO, KGLNXT, KGLTO, 1 LENT, LFILE, LGLOB, LNAME, LREF, LREFL, 2 LTYPST, MAP c c Common required only in GLOCH2 character OUTFIL*32 common /GLCHR2/ OUTFIL logical BYFILE, LABELS integer IDX(MXGLOB, 2), INDENT, ISORTD(3, 2), ISORTS(3, 2), KACT, 1 KINDI(2), KRECUR, LEVEL(MXGLOB), LINEW, LIST(5), 2 NAMEI1(MXGLOB), NAMEI2(MXGLOB), NEWGLO, NUM0 common /GLINT2/ IDX, INDENT, ISORTD, ISORTS, KACT, KINDI, KRECUR, 1 LEVEL, LINEW, LIST, NAMEI1, NAMEI2, NEWGLO, NUM0, BYFILE, 2 LABELS c c Locals external NSORTX integer MXSTK parameter (MXSTK=30) logical RECUR0, NOSORT character BUF2*18, BUFOUT*512, C1, C2, FMTLAB*8, 1 REFHED*16, TMPNAM*8, TXTSTR*13 integer FILINF(MXGLOB), I, I1, I2, I3, IIN, IOUT, J, J1, J2, J3, 1 J4, J5, J6, J7, J8, J9, K, K1, K2, K3, K4, K5, KOMPTY, KSTK, 2 KSTK1(MXSTK), KSTK2(MXSTK), KSTKP, L, MAPARG(0:7), MAPDUM(0:7), 3 NCHAIN, NENT, NSORTX, NXTCOM c c c ************************ Data Statements ***************************** c data MAPDUM / 5, 2, 1, 2, 5, 3, 3, 3 / data MAPARG / 1, 2, 6, 6, 0, 3, 6, 4 / data FMTLAB / '(I2,'':'')' / c c ********************** Start of Executable Code ********************** c c Start main processing KACT = 0 call INIT if (KACT .gt. 3) go to 900 c Set info. for actual args. with global implications. open (10, FILE='gltemp',STATUS='OLD',FORM='UNFORMATTED', ERR=900) print '(A)', ' Processing global data' L = 0 IIN = 10 IOUT = 0 NOSORT = .true. 600 K = 0 610 K = K + 1 if (K.le.MXGLOB) go to 650 K = MXGLOB if (IOUT .eq. 0) then IOUT = min(12, 23 - IIN) open(IOUT, STATUS='SCRATCH', FORM='UNFORMATTED') end if 620 do 630 K = 1, K write (IOUT) NAMEI1(K), NAMEI2(K), FILINF(K) 630 continue if (IIN .eq. 0) then rewind (IOUT) IIN = IOUT IOUT = 0 end if go to 600 650 read(IIN, END=730) NAMEI1(K), NAMEI2(K), FILINF(K) c NAMEI1 is KBGLO*(index for known global item) + argument # c NAMEI2 is KBGLO*(index of thing called) + argument index. c FILINF is KBGLO*(index of file) + line number in file. J3 = NAMEI2(K) / KBGLO I2 = NAMEI2(K) - KBGLO * J3 I3 = LREF(KGLTO(J3) - 3) if (I3 .eq. 0) then c Entry not defined, set to flag that arg, is passed as actual arg. I1 = -1 else I1 = I3 / 1024 I3 = I3 - 1024 * I1 + I2 - 1 C1 = TYPSTR(I1)(I3:I3) I1 = mod(index(GLTYPC, C1)-1, 4) if (I1 .ne. 2) then c Don't know whether defined. K2 = KGLFRO(J3) if (K2 .lt. 0) K2 = KGLFRO(-K2) K1 = 0 670 if (K2 .ne. 0) then c Accept results so far if "from" list is short enough. K1 = K1 + 1 if (K1 .lt. L) then K2 = LREF(K2) go to 670 end if go to 610 end if end if end if go to 760 c Got to end of input file 730 close (IIN, STATUS='DELETE') K = K - 1 if (IOUT .ne. 0) then c Treat output file as new input file. L = L + 1 if (L .gt. 10) stop 1'GLOCH2 -- Can''t process "gltemp", try a larger value for MXGLOB' IIN = 0 go to 620 end if c Sort the interface info. if (K .eq. 0) go to 800 ISORTD(1, 2) = 3 ISORTD(2, 2) = 1 call NSORT(1, 2) c Set IDX(I, 2) to order in sort for entry with index I. do 740 I = 1, LGLOB IDX(IDX(I, 2), 1) = I 740 continue NOSORT = .false. call INSORT(NSORTX, K, IDX(1, 1), K) c Update the interface information, first get info. for dummy called. 750 J3 = NAMEI2(K) / KBGLO I2 = NAMEI2(K) - KBGLO * J3 I3 = LREF(KGLTO(J3) - 3) if (I3 .eq. 0) then c Entry not defined, set to flag that arg, is passed as actual arg. I1 = -1 else I1 = I3 / 1024 I3 = I3 - 1024 * I1 + I2 - 1 C1 = TYPSTR(I1)(I3:I3) I1 = mod(index(GLTYPC, C1)-1, 4) end if c Then get the info. for the dummy (or common var.) passed as an arg. c In this section of the code, variables are used as follows. c I1 = mod 4 index for dummy in called routine. (-1 if no such routine.) c I2 is used as a flag, if < 0, argument was from common. c I3 is ultimately the location in LREF pointing to the type string. c J = mod 4 index for argument in call, = mod(K3, 4) c J1 = min(J, I1) c J2 = max(J, I1) c J3 = global index for routine called. c K1 is ultimately the Location in TYPSTR array for the original string. c K2 is ultimately the index in type string for the argument letter. c K3 is full index for the type of the argument in the call - 1. c K4 TYPSTR(K1)(K4:) starts the original type string. 760 K1 = NAMEI1(K) / KBGLO K2 = NAMEI1(K) - KBGLO * K1 I3 = KGLTO(K1) if (I3 .lt. 0) then I3 = -I3 770 K2 = K2 - 1024 if (K2 .gt. 1024) then I3 = LREF(I3-4) go to 770 end if c Check if common block is contained in routine called. J4 = I3 780 J4 = LREF(J4) if (J4 .ne. 0) then if (LREF(J4-1) .ne. J3) go to 780 J5 = FILINF(K) / KBGLO BUF2(1:9) = FILNAM(J5) BUF2(10:18) = NAME(KGLENT(J3)) write (BUFOUT,'(A,I5,3A,I3,2A)') 'At line', 1 FILINF(K)-J5*KBGLO, ' of file ',BUF2(1: 2 index(BUF2, ' ')), 'argument', I2-1, 3 ' in the call to ', BUF2(10:8+index(BUF2(10:), 4 ' ')) call TXTOUT(' ', BUFOUT) BUF2(1:9) = NAME(KGLENT(K1)) write (BUFOUT,'(A,I4,3A)') ' is entry', K2, 1 ' in the common block ', BUF2(1:index(BUF2, ' ')), 2 'contained in both.' call TXTOUT(' ', BUFOUT) end if K2 = K2 - 1 I3 = I3 - 1 c Flag that variable was in common I2 = -1 - LREF(I3-1) else I3 = I3 - 3 end if 790 K1 = LREF(I3) / 1024 K4 = LREF(I3) - 1024 * K1 C2 = TYPSTR(K1)(K4+K2:K4+K2) K3 = index(GLTYPC, C2) - 1 J = mod(K3, 4) J1 = min(I1, J) J2 = max(I1, J) if (J1 .ne. J2) then if (J1 .lt. 0) then J2 = 3 else if (J1 .gt. 0) then if (J2 - J1 .eq. 1) then J2 = 2 if (I2 .lt. 0) J2 = 3 end if end if end if if (J .ne. J2) then c Have new flags set. K3 = K3 - J + J2 + 1 J6 = index(TYPSTR(K1)(K4:), ' ') if (J6 .gt. LONG) then TYPSTR(K1)(K4+K2:K4+K2) = GLTYPC(K3:K3) else CTYPA=TYPSTR(K1)(K4:K4+J6) CTYPA(K2+1:K2+1) = GLTYPC(K3:K3) call LOCSTR (CTYPA(1:J6), I3) end if end if if (I2 .lt. -1) then c Process other definition of the common. I3 = -2 - I2 I2 = -1 - LREF(I3-1) go to 790 end if if (NOSORT) go to 650 K = IDX(K, 1) if (K .ne. 0) go to 750 800 write (9) LFILE, LGLOB, LREFL, LNAME, LTYPST, NEWGLO write (9) (FILNAM(J), J = 1, LFILE) write (9) (LENT(J), J = 1, LFILE) write (9) (KGLENT(J), J = 1, LGLOB) write (9) (KGLFRO(J), J = 1, LGLOB) write (9) (KGLNXT(J), J = 1, LGLOB) write (9) (KGLTO(J), J = 1, LGLOB) write (9) (LREF(J), J = 1, LREFL) write (9) (NAME(J), J = 1, LNAME) write (9) (TYPSTR(J), J = 1, LTYPST) LNAME = -LNAME call HASH(LNAME) print 810, LFILE, LGLOB, LREFL, LNAME, LTYPST 810 format(/' New values for saved parameters.'/ 1 ' LFILE =', I5, ' LGLOB =', I5, ' LREFL =', I6/ 2 ' LNAME =', I5, ' LTYPST =', I5/) close (9) c 900 if (OUTFIL .ne. ' ') call TXTOUT(' ', ' ') call input c c Start of code for output of results c Check if sort needed. do 940 K = 1, 2 do 930 J = 1, 3 if (ISORTD(J, K) .ne. ISORTS(J, K)) then call NSORT(J, K) go to 940 else if (abs(ISORTD(J, K)) .eq. 1) then go to 940 end if 930 continue 940 continue go to (1300, 1400, 1400), KACT - 3 c Check the calling sequences. do 950 K = 1, LGLOB NAMEI1(IDX(K, 2)) = K 950 continue NXTCOM = 0 do 1240 K = 1, LGLOB K2 = NAMEI1(K) TMPNAM = NAME(KGLENT(K2)) K1 = KGLTO(K2) if (K1 .gt. 0) then c Process the references to entry K2 K5 = 0 KOMPTY = -1 REFHED = ' Reference to ' c Check calling sequence with references. c I1 => type info. from declaration c I2 => type info. from reference. I1 = LREF(K1-3) I2 = LREF(K1-1) if (I1 .ne. 0) then if (KACT .eq. 3) then J1 = I1 / 1024 J2 = I1 - 1024 * J1 c Check for unreferenced parameters do 955 K3 = 1, 255 C1 = TYPSTR(J1)(J2+K3:J2+K3) if (C1 .eq. ' ') go to 957 if (index('mvirdzMVIRDZ', C1) .ne. 0) go to 970 955 continue 957 if (I2 .eq. 0) go to 1240 if (LREF(K1-2) .eq. 0) then c Check if compatible J3 = I2 / 1024 J4 = I2 - 1024 * J3 do 960 K3 = 0, 255 C1 = TYPSTR(J1)(J2+K3:J2+K3) C2 = TYPSTR(J3)(J4+K3:J4+K3) if (C1 .ne. C2) then J5 = index(GLTYPC, C1) - 1 J6 = index(GLTYPC, C2) - 1 if (J5/8 .ne. J6/8) go to 970 if (J5 .ge. 48) then if ((J5.eq.48) .or. (J6.eq.48)) go to 960 go to 970 end if c J5 is dummy, J6 is arg. J5 = MAPDUM(mod(J5, 8)) J6 = MAPARG(mod(J6, 8)) if (J5 .ne. J6) then if (max(J5, J6) .ge. 4) go to 970 if (J6 .eq. 0) go to 960 if ((J5.ne.2) .or. (J6.ne.1)) go to 970 end if else if (C1 .eq. ' ') then go to 1240 end if 960 continue end if end if 970 BUFOUT(1:16) = 'Declaration for ' KOMPTY = -2 go to 1020 else if (KACT .eq. 3) then if (LREF(K1-2) .eq. 0) go to 1240 end if go to 1000 end if c Common block K1 = -K1 REFHED = ' Common Block ' 980 NXTCOM = LREF(K1-4) I2 = LREF(K1-1) if ((LREF(K1) .eq. 0) .or. (I2 .eq. 0)) go to 1240 if ((KACT .eq. 3) .and. (LREF(K1-2) .eq. 0)) then c Just one common block, check if O.K. J1 = I2 / 1024 J2 = I2 - 1024 * J1 do 990 K3 = J2, 256 J3 = index(' jsfoawJSFOAW', TYPSTR(J1)(K3:K3)) if (J3 .le. 1) then if (J3 .ne. 0) go to 1210 go to 1000 end if 990 continue end if 1000 I1 = I2 c Output results 1010 I2 = 0 BUFOUT(1:16) = REFHED 1020 BUFOUT(17:24) = TMPNAM do 1030 L = 24, 18, -1 if (BUFOUT(L:L) .ne. ' ') go to 1040 1030 continue 1040 BUFOUT(L+1:L+2) = ': ' if (I1 .ne. 0) then I3 = I1 / 1024 I1 = I1 - 1024 * I3 J = index(TYPSTR(I3)(I1:), ' ') - 1 1050 K3 = L + 2 K2 = min(J, LINEW-K3) BUFOUT(K3+1:K3+K2) = TYPSTR(I3)(I1:I1+K2-1) K3 = K3 + K2 J = J - K2 call TXTOUT(' 3', BUFOUT(1:K3)) if (REFHED(4:4) .eq. 'C') then c Flag problems in the common block. do 1060 K4 = L + 3, K3 if (index('jsfoawJSFOAW', BUFOUT(K4:K4)) .eq. 0) then BUFOUT(K4:K4) = '^' else BUFOUT(K4:K4) = ' ' end if 1060 continue else K5 = K5 + K2 if (KOMPTY .lt. 0) then CTYPA(K5-K2+1:K5) = TYPSTR(I3)(I1:I1+K2-1) if (KOMPTY .ne. -2) go to 1170 end if J7 = K5 - K2 - L - 2 if (KOMPTY .eq. -2) then c Flag any in the declaration that are not used. BUFOUT(L+3:L+3) = ' ' do 1080 K4 = L+4, K3 C1 = CTYPA(J7+K4:J7+K4) if (index('mvirdzMVIRDZ', C1) .ne. 0) then BUFOUT(K4:K4) = '^' else BUFOUT(K4:K4) = ' ' end if 1080 continue else if (KOMPTY .ge. 0) then do 1120 K4 = L+3, K3 C1 = CTYPA(J7+K4:J7+K4) C2 = BUFOUT(K4:K4) if (C1 .eq. C2) go to 1110 J5 = index(GLTYPC, C1) - 1 J6 = index(GLTYPC, C2) - 1 if (J5/8 .ne. J6/8) go to 1100 if (J5 .ge. 48) then if ((J5.eq.48) .or. (J6.eq.48)) go to 1110 go to 1100 end if J5 = mod(J5, 8) J6 = mod(J6, 8) J8 = MAPDUM(J5) J9 = MAPARG(J6) if (KOMPTY .eq. 0) then c Comparing declaration and reference. 1090 if (J8 .eq. J9) go to 1110 if (max(J8, J) .ge. 4) then if (J8 .ne. 5) go to 1100 J8 = 2 if (J5 .ge. 3) J8 = 3 go to 1090 end if if (J9 .eq. 0) go to 1110 if ((J8.eq.2) .and. (J9.eq.1)) go to 1110 else c Comparing two references. if (J8 + J9 .le. 3) go to 1110 end if 1100 BUFOUT(K4:K4) = '^' go to 1120 1110 BUFOUT(K4:K4) = ' ' 1120 continue end if end if if (index(BUFOUT(L+3:K3), '^') .ne. 0) then if (L .gt. 0) BUFOUT(1:L+1) = ' ^ flags doubts:' call TXTOUT(' 3', BUFOUT(1:K3)) end if 1170 if (J .ne. 0) then I1 = I1 + K2 BUFOUT(4:L+1) = ' (continued)' go to 1050 end if if (KOMPTY .lt. 0) KOMPTY = KOMPTY + 2 K5 = 0 if (I2 .ne. 0) go to 1000 c Get and sort the entry names. I1 = LREF(K1) if (I1 .eq. 0) go to 1240 J = 0 1180 J = J + 1 I3 = LREF(I1-1) NAMEI2(J) = IDX(I3, 2) * KBGLO + KGLENT(I3) I1 = LREF(I1) if (I1 .ne. 0) go to 1180 call ISORT(NAMEI2, 1, J) TXTSTR = 'In: ' I2 = 1 1190 I = I2 I2 = min(J+1, I + (LINEW - 11) / 9) BUFOUT(1:LINEW) = TXTSTR J1 = -4 do 1200 I = I, I2 - 1 J1 = J1 + 9 BUFOUT(J1:J1+7) = NAME(mod(NAMEI2(I), KBGLO)) 1200 continue call TXTOUT(' 2', BUFOUT(1:J1+7)) TXTSTR = ' ' if (I2 .le. J) go to 1190 K1 = LREF(K1-2) if (K1 .ne. 0) then I1 = LREF(K1 - 1) go to 1010 end if end if 1210 if (NXTCOM .ne. 0) then c Get info for next common block segment (same name) K1 = NXTCOM if (REFHED(15:15) .eq. 'k')then REFHED(11:15) = '+ 1 ' else I1 = 14 1220 C1 = REFHED(I1:I1) if (C1 .ne. '9') then REFHED(I1:I1) = char(ichar(C1) + 1) else REFHED(I1:I1) = '0' I1 = I1 - 1 if (REFHED(I1:I1) .eq. ' ') REFHED(I1:I1) = '0' go to 1220 end if end if go to 980 end if 1240 continue go to 900 c c Output a list 1300 continue K = 0 1310 K = K + 1 K1 = LIST(K) if (K1 .eq. 0) go to 900 K2 = 2 K3 = LGLOB if (K1 .eq. 3) then K2 = 1 K3 = LFILE end if do 1330 I = 1, K3 NAMEI1(I) = IDX(I, K2) * KBGLO + I 1330 continue call ISORT(NAMEI1, 1, K3) I1 = 0 do 1360 I = 1, K3 I3 = mod(NAMEI1(I), KBGLO) if (K1 .eq. 3) then BUFOUT(I1+1:I1+8) = FILNAM(I3) else if (KGLTO(I3) .lt. 0) then if (K1 .ne. 1) go to 1360 else if (K1 .eq. 1) go to 1360 if (K1 .eq. 4) then if (KGLNXT(I3) .ne. 0) go to 1360 end if end if BUFOUT(I1+1:I1+8) = NAME(KGLENT(I3)) end if I1 = I1 + 9 BUFOUT(I1:I1) = ' ' if (I1 .gt. LINEW - 8) then call TXTOUT(' ', BUFOUT(1:I1-1)) I1 = 0 end if 1360 continue if (I1 .gt. 0) call TXTOUT(' ', BUFOUT(1:I1-1)) BUFOUT(1:1) = ' ' call TXTOUT(' ', BUFOUT(1:1)) go to 1310 c c Output a cross reference or "who calls" 1400 continue K2 = min(2, KINDI(1)) K1 = LGLOB if (K2 .eq. 1) then K1 = LFILE end if do 1410 I = 1, K1 NAMEI1(I) = IDX(I, K2) * KBGLO + I 1410 continue call ISORT(NAMEI1, 1, K1) if (LABELS) then K3 = K1 do 1420 J = 1, 5 K3 = K3 / 10 if (K3 .eq. 0) go to 1430 1420 continue 1430 continue FMTLAB(3:3) = char(NUM0 + J) else J = -1 end if L = 10 + J K3 = 1 K4 = 0 if (KINDI(1) .ne. KINDI(2)) then K3 = 2 if ((max(KINDI(1), KINDI(2)).eq.2) .and. (KRECUR.eq.0)) K4 = 1 end if NCHAIN = 0 do 1700 I = 1, K1 BYFILE = KINDI(1) .eq. 1 RECUR0 = .false. if (K3 .eq. 2) then RECUR0 = max(KINDI(1), KINDI(2)) .eq. 2 LREF(2) = 0 end if I3 = mod(NAMEI1(I), KBGLO) LEVEL(1) = I3 J = 1 KSTK = 0 KSTKP = 1 1440 KSTK = KSTK + 1 KSTK1(KSTK) = J NENT = 0 if (.not. BYFILE) go to 1450 c Get entry and save the index. I3 = LENT(I3) 1445 NENT = KGLNXT(I3) 1450 if (KACT .eq. 5) then c Cross reference. if (KINDI(2) .eq. 3) then if (KGLTO(I3) .ge. 0) go to 1700 else if (KGLTO(I3) .lt. 0) go to 1700 if (RECUR0) then LREF(1) = I3 I3 = 2 go to 1480 end if end if I3 = KGLFRO(I3) go to 1480 end if c Who calls if (KINDI(1) .eq. 3) then I3 = KGLTO(I3) if (I3 .ge. 0) go to 1700 I3 = -I3 else if (I3 .lt. 0) go to 1700 if (RECUR0) then LREF(1) = I3 I3 = 2 go to 1480 end if I3 = KGLTO(I3) end if 1460 NCHAIN = LREF(I3-2) 1470 I3 = LREF(I3) 1480 if (I3 .gt. 0) then 1490 I1 = LREF(I3-1) if (KINDI(2) .eq. 1) then c Set LEVEL(J) to the file index 1500 I1 = KGLNXT(I1) if (I1 .gt. 0) go to 1500 I1 = -I1 c Save info to point to entry. if (I1 .eq. 0) I1 = -LREF(I3-1) * KBGLO end if if (KRECUR .eq. 3) then do 1510 K = K3, KSTK if (LEVEL(KSTK1(K)) .eq. I1) go to 1470 1510 continue if (KINDI(2) .eq. 1) then do 1520 K = KSTK1(KSTK) + 1, J if (LEVEL(K) .eq. I1) go to 1470 1520 continue end if else c Don't enter if a duplicate ( K3 = 1 + | KINDI(1) - KINDI(2) | ) do 1530 K = K3, J if (LEVEL(K) .eq. I1) go to 1470 1530 continue end if 1540 J = J + 1 LEVEL(J) = I1 go to 1470 end if I3 = NCHAIN if (I3 .ne. 0) go to 1460 I3 = NENT if (I3 .gt. 0) then c Pick up the next entry/common block (if only want for an entry, then c stop when the KGLFRO indicates it's not a multiple entry. if (BYFILE) go to 1445 if (KGLFRO(NENT) .lt. 0) go to 1445 end if c At this point LEVEL(KSTK1(KSTK):J) contains a list of all the items at c the this level away from item in LEVEL(KSTK1(KSTK)-1). 1550 RECUR0 = .false. BYFILE = KINDI(2) .eq. 1 if (KRECUR .eq. 3) go to 1570 if (KRECUR .le. 0) then if (KSTK .gt. K4) go to 1565 end if c Take care of recursion. I3 = J 1560 KSTK2(KSTK) = I3 - 1 if (I3 .gt. KSTK1(KSTK)) then I3 = LEVEL(I3) if (I3 .gt. 0) go to 1440 I3 = KSTK2(KSTK) go to 1560 end if c Pop the stack. 1565 KSTK = KSTK - 1 if (KSTK .gt. 0) then I3 = KSTK2(KSTK) c Recur one step back. go to 1560 end if KSTK = 1 1570 if (KSTK1(KSTK) + 1 .lt. J) then c Sort the list backward do 1580 K = KSTK1(KSTK)+1, J I1 = LEVEL(K) if (I1 .gt. 0) then NAMEI2(K) = (LGLOB-IDX(I1, KINDI(2))) * KBGLO + I1 else NAMEI2(K) = I1 end if 1580 continue call ISORT(NAMEI2, KSTK1(KSTK)+1, J) do 1590 K = KSTK1(KSTK)+1, J if (NAMEI2(K) .lt. 0) then LEVEL(K) = NAMEI2(K) else LEVEL(K) = mod(NAMEI2(K), KBGLO) end if 1590 continue end if c End of sorting if (KRECUR .eq. 3) then if (J .gt. KSTK1(KSTK)) then c Not down to lowest level yet, recur till we get there. I3 = LEVEL(J) if (I3 .gt. 0) go to 1440 KSTK = KSTK + 1 KSTK1(KSTK) = J end if end if c Ready to print c Print the header stuff I1 = 0 1620 I3 = KSTK1(KSTKP) c 1630 if (KRECUR .gt. 1) then I2 = 1 if (KRECUR .eq. 2) then I1 = min(KSTKP-1, 1) * INDENT else I1 = (KSTKP-1) * INDENT 1640 if (I1 .gt. LINEW - L) then c Start line with "+'s when indent is going past line length. BUFOUT(I2:I2) = '+' I2 = I1 - INDENT go to 1640 end if end if BUFOUT(I2:min(I1, LINEW)) = ' ' else if (I1 .eq. 0) then if (I3 .ne. 1) then I1 = L BUFOUT(1:I1) = ' ' end if end if K = LEVEL(I3) if (K .lt. 0) then if (I1 .eq. 0) I1 = I1 + 1 BUFOUT(I1:I1) = '*' K = -K if (K .ge. KBGLO) then c Wanted file name -- precede entry name with "?". K = K / KBGLO BUFOUT(I1:I1) = '?' K2 = 0 TMPNAM = NAME(KGLENT(K)) go to 1650 end if end if if (KINDI(min(I3, 2)) .eq. 1) then TMPNAM = FILNAM(K) K2 = IDX(K, 1) else TMPNAM = NAME(KGLENT(K)) K2 = IDX(K, 2) end if 1650 if (LABELS) then write (BUFOUT(I1+1:I1+L-9), FMTLAB) K2 I1 = I1 + L - 9 end if BUFOUT(I1+1:I1+8) = TMPNAM I1 = I1 + 9 BUFOUT(I1:I1) = ' ' if ((KRECUR .gt. 1) .or. (I1 .gt. LINEW - L)) then call TXTOUT(' ', BUFOUT(1:I1-1)) I1 = 0 if (KRECUR .eq. 3) then KSTKP = KSTKP + 1 if (KSTKP .le. KSTK) go to 1620 1660 KSTK = KSTK - 1 if (KSTK .eq. 0) go to 1700 J = J - 1 if (J .le. KSTK1(KSTK)) go to 1660 KSTKP = KSTK + 1 I3 = LEVEL(J) if (I3 .gt. 0) go to 1440 1670 J = J - 1 if (LEVEL(J) .lt. 0) go to 1670 go to 1550 end if end if I3 = I3 - 1 if (I3 .gt. 1) go to 1630 if (I3 .eq. 0) I3 = J if (I3 .ne. 1) go to 1630 if (I1 .gt. 0) call TXTOUT(' ', BUFOUT(1:I1-1)) 1700 continue go to 900 c End of GLOCH2 end subroutine HASH (LNAME) c Just to save and restore HASH table data. Needed for G option c in GLOCH1. c integer LNAME, MXNAME parameter (MXNAME=2333) integer HTABLE(MXNAME), K, LFREEN, NAMTYP(MXNAME) save HTABLE, LFREEN, NAMTYP c if (LNAME .lt. 0) then LNAME = -LNAME write (9) MXNAME, LFREEN write (9) (NAMTYP(K), K = 1, LNAME) write (9) (HTABLE(K), K = 1, MXNAME) else read (9) K, LFREEN if (K .ne. MXNAME) stop 1 'GLOCH1 -- Incombatible hash table formats' read (9) (NAMTYP(K), K = 1, LNAME) read (9) (HTABLE(K), K = 1, MXNAME) end if return end subroutine INIT c Get everything initialized. c Common and parameters required in both GLOCH1 and GLOCH2 integer MXGLOB, MXLREF, MXNAME, MXTYST, MXTLEN parameter (MXGLOB=2020, MXLREF=25000, MXNAME=2333, MXTYST=200, 1 MXTLEN=256) c Misc. Parameters integer LONG, MXFILE parameter (LONG=7, MXFILE=1500) c Parameters used for character mappings integer MAPDIG, MAPOTH parameter (MAPDIG=3, MAPOTH=6) c Parameters associated with bits in symbol table entries. integer KBDEC, KBREF, KBDEF, KBARG, KBDUM, KBCOM, KBPAR, KBDIM, 1 KBEXT, KBGLO, KBDIMW parameter (KBDEC=16, KBREF=32, KBDEF=64, KBARG=128, KBDUM=256, 1 KBCOM=512, KBPAR=1024, KBDIM=2048, KBEXT=32768, KBGLO=65536) parameter (KBDIMW = KBEXT / KBDIM) c character CTYPA*(MXTLEN), FILNAM(MXFILE)*8, GLTYPC*56, 1 NAME(MXNAME)*8, TYPSTR(MXTYST)*(MXTLEN) integer KGLENT(MXGLOB), KGLFRO(MXGLOB), KGLNXT(MXGLOB), 1 KGLTO(MXGLOB), LENT(MXFILE), LFILE, 2 LGLOB, LNAME, LREF(MXLREF), LREFL, LTYPST, MAP(128) common /GLCHRB/ CTYPA, FILNAM, GLTYPC, NAME, TYPSTR common /GLINTB/ KGLENT, KGLFRO, KGLNXT, KGLTO, 1 LENT, LFILE, LGLOB, LNAME, LREF, LREFL, 2 LTYPST, MAP c c Common required only in GLOCH2 character OUTFIL*32 common /GLCHR2/ OUTFIL logical BYFILE, LABELS integer IDX(MXGLOB, 2), INDENT, ISORTD(3, 2), ISORTS(3, 2), KACT, 1 KINDI(2), KRECUR, LEVEL(MXGLOB), LINEW, LIST(5), 2 NAMEI1(MXGLOB), NAMEI2(MXGLOB), NEWGLO, NUM0 common /GLINT2/ IDX, INDENT, ISORTD, ISORTS, KACT, KINDI, KRECUR, 1 LEVEL, LINEW, LIST, NAMEI1, NAMEI2, NEWGLO, NUM0, BYFILE, 2 LABELS c c Locals integer I c c ****************** Start of Executable Code ************************** c c Open the names file. c Set up the mapping table. NUM0 = ichar('0') do 150 I = 1, 128 MAP(I) = MAPOTH 150 continue MAP(ichar('0')) = MAPDIG MAP(ichar('1')) = MAPDIG MAP(ichar('2')) = MAPDIG MAP(ichar('3')) = MAPDIG MAP(ichar('4')) = MAPDIG MAP(ichar('5')) = MAPDIG MAP(ichar('6')) = MAPDIG MAP(ichar('7')) = MAPDIG MAP(ichar('8')) = MAPDIG MAP(ichar('9')) = MAPDIG LINEW = 0 OUTFIL = ' ' c 1 2 3 4 5 c 12345678901234567890123456789012345678901234567890123456 GLTYPC='mlkjMLKJvutsVUTSihgfIHGFrqpoRQPOdcbaDCBAzyxwZYXWe123456E' c open (9, FILE='glsave', FORM='UNFORMATTED', STATUS='OLD') read (9) LFILE, LGLOB, LREFL, LNAME, LTYPST, NEWGLO read (9) (FILNAM(I), I = 1, LFILE) read (9) (LENT(I), I = 1, LFILE) read (9) (KGLENT(I), I = 1, LGLOB) read (9) (KGLFRO(I), I = 1, LGLOB) read (9) (KGLNXT(I), I = 1, LGLOB) read (9) (KGLTO(I), I = 1, LGLOB) read (9) (LREF(I), I = 1, LREFL) read (9) (NAME(I), I = 1, LNAME) read (9) (TYPSTR(I), I = 1, LTYPST) call HASH(LNAME) rewind (9) return c End of subroutine INIT end subroutine INPUT c Process input to get the next action. c Common and parameters required in both GLOCH1 and GLOCH2 integer MXGLOB, MXLREF, MXNAME, MXTYST, MXTLEN parameter (MXGLOB=2020, MXLREF=25000, MXNAME=2333, MXTYST=200, 1 MXTLEN=256) c Misc. Parameters integer LONG, MXFILE parameter (LONG=7, MXFILE=1500) c Parameters used for character mappings integer MAPDIG, MAPOTH parameter (MAPDIG=3, MAPOTH=6) c Parameters associated with bits in symbol table entries. integer KBDEC, KBREF, KBDEF, KBARG, KBDUM, KBCOM, KBPAR, KBDIM, 1 KBEXT, KBGLO, KBDIMW parameter (KBDEC=16, KBREF=32, KBDEF=64, KBARG=128, KBDUM=256, 1 KBCOM=512, KBPAR=1024, KBDIM=2048, KBEXT=32768, KBGLO=65536) parameter (KBDIMW = KBEXT / KBDIM) c character CTYPA*(MXTLEN), FILNAM(MXFILE)*8, GLTYPC*56, 1 NAME(MXNAME)*8, TYPSTR(MXTYST)*(MXTLEN) integer KGLENT(MXGLOB), KGLFRO(MXGLOB), KGLNXT(MXGLOB), 1 KGLTO(MXGLOB), LENT(MXFILE), LFILE, 2 LGLOB, LNAME, LREF(MXLREF), LREFL, LTYPST, MAP(128) common /GLCHRB/ CTYPA, FILNAM, GLTYPC, NAME, TYPSTR common /GLINTB/ KGLENT, KGLFRO, KGLNXT, KGLTO, 1 LENT, LFILE, LGLOB, LNAME, LREF, LREFL, 2 LTYPST, MAP c c Common required only in GLOCH2 character OUTFIL*32 common /GLCHR2/ OUTFIL logical BYFILE, LABELS integer IDX(MXGLOB, 2), INDENT, ISORTD(3, 2), ISORTS(3, 2), KACT, 1 KINDI(2), KRECUR, LEVEL(MXGLOB), LINEW, LIST(5), 2 NAMEI1(MXGLOB), NAMEI2(MXGLOB), NEWGLO, NUM0 common /GLINT2/ IDX, INDENT, ISORTD, ISORTS, KACT, KINDI, KRECUR, 1 LEVEL, LINEW, LIST, NAMEI1, NAMEI2, NEWGLO, NUM0, BYFILE, 2 LABELS c c Locals integer MXLINE parameter (MXLINE=120) character C, BUFIN*(MXLINE) integer I, ITEM, J, K, KSUM, M save BUFIN c c************************ Start of Executable Code ********************* c if (LINEW .ne. 0) go to 20 5 ISORTS(1, 1) = 0 ISORTS(1, 2) = 0 ISORTD(1, 1) = 1 ISORTD(1, 2) = 1 INDENT = 3 LINEW = 79 go to 20 10 if (ITEM .eq. 2) return print *, ' The above action requires further specification.' 20 KACT = 0 print *, ' Input (? for help): ' read (*, '(A)') BUFIN 30 KSUM = -1 KRECUR = 0 LABELS = .false. ITEM = 0 K = 0 40 K = K + 1 C = BUFIN(K:K) if ((C .eq. ' ') .or. (C .eq. '!')) then if (C .eq. '!') then if (K .eq. 1) then 70 call TXTOUT(' ', BUFIN(2:)) go to 20 end if else if (BUFIN(K+1:) .ne. ' ') then go to 40 end if if (KACT .ne. 0) go to 10 go to 20 end if J = ichar(C) if (MAP(J) .eq. MAPDIG) then KSUM = 10 * max(KSUM, 0) + J - NUM0 go to 40 end if if (C .eq. '?') then c Request for Help. C = BUFIN(K+1:K+1) if (C .eq. ' ') then print '(1X,A)', 1 'Input is of the form [output] [filename] Action_letter I1 I2', 2 'This input comes in through "standard input". For help on', 3 'specific fields use the following input.', 4 '?O -- Describes the optional output field.', 5 '?N -- Describes the optional filename field.', 6 'Possible action letters are the letters following ? below.', 9 '?E -- Describes the entry sort.', A '?F -- Describes the file sort.', B '?D -- Describes global diagnostics.', C '?L -- Describes how to get listings of things.', D '?C -- Describes how to get a cross reference.', E '?W -- Describes how to get a "who calls".', F 'I2 is not always needed. Files and entries are always printed', G 'in the order defined by the E and F sort actions.', H ' Q -- Ends the processing. A "!" starts a comment', I 'which is written to the current file if in column 1.' go to 20 end if c 1 2 3 4 5 6 7 9 J = (index('OoNnEeFfDdLlCcWw', C) + 1) / 2 go to(110, 120, 130, 140, 150, 160, 170, 180, 190), J print '(''" ?"'', A1, A)', C, ' has no help available.' go to 20 110 print '(1x,A)', 1'dddL specifies line width, where ddd indicates 1 or more digits.' 2,'dddI specifies indentation on lines after the first', 3'Both may be given, but must have no intervening blanks.' go to 20 120 print '(1x,A)', 1'File name is 2 or more character followed by a blank' go to 20 130 print '(1x,A)', 1'Use one or more of the following keys with no embedded blanks', 2'F Must be first. Ordered by the file containing the entry.', 3'L Sort based on smallest maximum distance to a leaf.', 4'R Sort based on smallest maximum distance to a root.', 5'N Sort based on the entry name.', 6'- Preceding any of the above reverses the sort order.' go to 20 140 print '(1x,A)', 1'Use one or more of the following keys with no embedded blanks', 2'L Sort based on smallest maximum distance to a leaf.', 3'R Sort based on smallest maximum distance to a root.', 4'N Sort based on the file name.', 5'- Preceding any of the above reverses the sort order.' go to 20 150 print '(1x,A)', 1'With nothing following the "D" or "d" give global diagnostics', 2'A Gives a listing of all interface information.' go to 20 160 print '(1x,A)', 1'The I1 following action L, is one or more of the following.', 2'C List all common block names.', 3'E List all entry names.', 4'F List all files.', 5'U List all undefined entries.' go to 20 170 print '(1x,A)', 1'Provide a cross reference between I1 and I2. Thus for each name' 2,'in I1 list the Names from I2 that I1 references. I1 & I2 are:', 3'E for entries', 4'F for files', 5'C for common blocks (I2 only)' go to 190 180 print '(1x,A)', 1'Provide a "who calls" between I1 and I2. Thus for each name', 2'in I1 list the Names from I2 that I1 call it. I1 & I2 are:', 3'E for entries', 4'F for files', 5'C for common blocks (I1 only)' 190 print '(1x,A)', 1'I2 can be followed by # and/or one of +,-, or *.', 2'# Is allowed only if I1 and I2 are the same in which case it', 3' cause item numbers to be printed before names listed from', 4' I2 and after names listed from I3.', 5'+ Includes things referenced indirectly', 6'- As for "+", but put items on separate lines.', 7'* Print a full tree, one item per line.' go to 20 end if c if (KACT .eq. 0) then if (KSUM .lt. 0) then if (BUFIN(K+1:K+1) .ne. ' ') then c Get an output file name J = index(BUFIN(K:), ' ') if (OUTFIL .ne. BUFIN(K:K+J-2)) then if (OUTFIL .ne. ' ') close (8) OUTFIL = BUFIN(K:K+J-2) open (8, FILE=OUTFIL(1:index(OUTFIL, ' ')-1)) end if K = K + J - 1 go to 40 end if c 1 2 3 4 5 6 7 J = index('FfEeDdLlCcWwQq', C) if (J .eq. 0) then print '(1X, A1, A)',C,' is not a defined action letter.' go to 20 end if KACT = (J + 1) / 2 if (KACT .eq. 3) then if (BUFIN(K+1:) .eq. ' ') return 250 K = K + 1 if (BUFIN(K:K) .eq. ' ') go to 250 KACT = 0 if (index('Aa', BUFIN(K:K)) .ne. 0) return print '(1X, A1, A)', BUFIN(K:K), 1 ' is an unknown diagnostic request.' go to 20 end if if (KACT .le. 6) go to 40 stop 'Processing complete.' else J = index('IiLl', C) if (J .eq. 0) then print '(1X, A1, A)', C, ' not allowed after an integer.' go to 20 end if J = (J + 1) / 2 if (J .lt. 2) then INDENT = min(KSUM, 5) else LINEW = max(KSUM, 40) end if KSUM = -1 go to 40 end if end if if (KACT .le. 2) then c Defining a sort I = 0 M = 1 300 I = I + 1 310 C = BUFIN(K:K) if (C .eq. '-') then M = -1 K = K + 1 go to 310 end if J = index('NnFfLlRr', C) if (J .eq. 0) then if (I .le. 3) ISORTD(I, KACT) = 1 go to 20 end if J = (J + 1) / 2 if (J .eq. 2) then if (KACT .eq. 1) then print *, ' Can''t use E when sorting files.' go to 20 end if end if if (I .gt. 3) then print *, ' Trying to specify too many keys.' go to 20 end if ISORTD(I, KACT) = J * M K = K + 1 go to 300 end if if (KACT .eq. 4) then ITEM = 1 I = 1 350 C = BUFIN(K:K) J = index('cCeEfFuU', C) if (J .ne. 0) then LIST(I) = (J + 1) / 2 I = I + 1 K = K + 1 go to 350 end if LIST(I) = 0 if (C .eq. ' ') return print '(1X, A1, A)', C, ' is not something to list.' go to 20 end if c KACT = 5 or 6 ITEM = ITEM + 1 J = index('fFeEcC', BUFIN(K:K)) if (J .eq. 0) then print '(1X, A1, A)', BUFIN(K:K), 1 ' can''t be an item for actions C or W.' go to 20 end if KINDI(ITEM) = (J + 1) / 2 if ((J .ge. 5) .and. (ITEM + KACT .ne. 7)) then print '('' C is not allowed as used'')' go to 20 end if if (BUFIN(K+1:K+1) .eq. '!') go to 40 370 K = K + 1 C = BUFIN(K:K) if (C .eq. ' ') go to 40 if (ITEM .eq. 1) then print '(1X, A1, A)', C, ' not allowed after the first item.' go to 20 end if J = index('.+-*#', C) if (J .eq. 0) then print '(1X, A1, A)', C, ' not allowed after an item.' go to 20 end if if (J .eq. 5) then LABELS = .true. go to 370 end if if (KRECUR .ne. 0) then print *, ' Only one of "+-*" can follow item 2.' go to 20 end if KRECUR = J - 1 if (KRECUR .eq. 0) KRECUR = -1 go to 370 c End of subroutine INPUT end subroutine LOCSTR (CTYP, LS) c Enter a new type string definition character CTYP*(*) integer LS c c Common and parameters required in both GLOCH1 and GLOCH2 integer MXGLOB, MXLREF, MXNAME, MXTYST, MXTLEN parameter (MXGLOB=2020, MXLREF=25000, MXNAME=2333, MXTYST=200, 1 MXTLEN=256) c Misc. Parameters integer LONG, MXFILE parameter (LONG=7, MXFILE=1500) c character CTYPA*(MXTLEN), FILNAM(MXFILE)*8, GLTYPC*56, 1 NAME(MXNAME)*8, TYPSTR(MXTYST)*(MXTLEN) integer KGLENT(MXGLOB), KGLFRO(MXGLOB), KGLNXT(MXGLOB), 1 KGLTO(MXGLOB), LENT(MXFILE), LFILE, 2 LGLOB, LNAME, LREF(MXLREF), LREFL, LTYPST, MAP(128) common /GLCHRB/ CTYPA, FILNAM, GLTYPC, NAME, TYPSTR common /GLINTB/ KGLENT, KGLFRO, KGLNXT, KGLTO, 1 LENT, LFILE, LGLOB, LNAME, LREF, LREFL, 2 LTYPST, MAP c c Locals integer J, K, K1, L c c************************ Start of Executable Code ********************* c if (LTYPST .ne. 0) then L = len(CTYP) if (L .lt. LONG) then do 70 J = 1, LTYPST K = index(TYPSTR(J), CTYP) if (K .ne. 0) then K1 = K - LONG + L if (K1 .le. 0) go to 90 if (index(TYPSTR(J)(K1:K), ' ') .ne. 0) go to 90 end if 70 continue end if K = index(TYPSTR(LTYPST), ' ') if (K .ne. 0) then K = K + 1 if (K + L .le. 257) go to 80 end if end if LTYPST = LTYPST + 1 if (LTYPST .gt. MXTYST) stop 1 'GLOCH1 -- Parameter MXTYST must be bigger.' TYPSTR(LTYPST) = ' ' K = 1 80 J = LTYPST TYPSTR(LTYPST)(K:K+LEN(CTYP)-1) = CTYP 90 LREF(LS) = 1024 * J + K return c End of subroutine LOCSTR end subroutine NSORT(KLOC, KTYP) c Get levels as needed and sort integer KLOC, KTYP c c Common and parameters required in both GLOCH1 and GLOCH2 integer MXGLOB, MXLREF, MXNAME, MXTYST, MXTLEN parameter (MXGLOB=2020, MXLREF=25000, MXNAME=2333, MXTYST=200, 1 MXTLEN=256) c Misc. Parameters integer LONG, MXFILE parameter (LONG=7, MXFILE=1500) c Parameters used for character mappings integer MAPDIG, MAPOTH parameter (MAPDIG=3, MAPOTH=6) c Parameters associated with bits in symbol table entries. integer KBDEC, KBREF, KBDEF, KBARG, KBDUM, KBCOM, KBPAR, KBDIM, 1 KBEXT, KBGLO, KBDIMW parameter (KBDEC=16, KBREF=32, KBDEF=64, KBARG=128, KBDUM=256, 1 KBCOM=512, KBPAR=1024, KBDIM=2048, KBEXT=32768, KBGLO=65536) parameter (KBDIMW = KBEXT / KBDIM) c character CTYPA*(MXTLEN), FILNAM(MXFILE)*8, GLTYPC*56, 1 NAME(MXNAME)*8, TYPSTR(MXTYST)*(MXTLEN) integer KGLENT(MXGLOB), KGLFRO(MXGLOB), KGLNXT(MXGLOB), 1 KGLTO(MXGLOB), LENT(MXFILE), LFILE, 2 LGLOB, LNAME, LREF(MXLREF), LREFL, LTYPST, MAP(128) common /GLCHRB/ CTYPA, FILNAM, GLTYPC, NAME, TYPSTR common /GLINTB/ KGLENT, KGLFRO, KGLNXT, KGLTO, 1 LENT, LFILE, LGLOB, LNAME, LREF, LREFL, 2 LTYPST, MAP c c Common required only in GLOCH2 character OUTFIL*32 common /GLCHR2/ OUTFIL logical BYFILE, LABELS integer IDX(MXGLOB, 2), INDENT, ISORTD(3, 2), ISORTS(3, 2), KACT, 1 KINDI(2), KRECUR, LEVEL(MXGLOB), LINEW, LIST(5), 2 NAMEI1(MXGLOB), NAMEI2(MXGLOB), NEWGLO, NUM0 common /GLINT2/ IDX, INDENT, ISORTD, ISORTS, KACT, KINDI, KRECUR, 1 LEVEL, LINEW, LIST, NAMEI1, NAMEI2, NEWGLO, NUM0, BYFILE, 2 LABELS c c Locals external NSORTC integer I1,I2,I3,J,J1,K,K1,KXSTAK,L,LAST,LEV,LEVTYP,NSORTC parameter (KXSTAK=30) integer KSTKS1(KXSTAK), KSTKS2(KXSTAK), KSTKS3(KXSTAK), 1 KSTKS4(KXSTAK) save LEVTYP data LEVTYP / 0 / c c ********************** Start of Executable Code ********************** c c Save current sort parameters and get levels if needed. BYFILE = KTYP .eq. 1 LAST = LGLOB if (BYFILE) LAST = LFILE do 700 J1 = KLOC, 4 ISORTS(J1, KTYP) = ISORTD(J1, KTYP) L = abs(ISORTS(J1, KTYP)) if (L .eq. 1) go to 710 if (L .eq. 2) go to 700 K1 = 10 * KTYP + L if (K1 .eq. LEVTYP) go to 700 LEVTYP = K1 c Need to get levels. do 10 K1 = 1, LAST LEVEL(K1) = 0 10 continue if (L .eq. 3) then c Need max level from a leaf if (BYFILE) then c File levels do 200 K1 = 1, LAST K = LENT(K1) c Insure that no entry is calling another that we will see later. 40 if (KGLFRO(K) .ne. 0) then I1 = KGLFRO(K) 50 I2 = LREF(I1-1) 80 I2 = KGLNXT(I2) if (I2 .gt. 0) go to 80 if ((I2 .ne. 0) .and. (K1 .ne. -I2)) go to 200 I1 = LREF(I1) if (I1 .ne. 0) go to 50 end if K = KGLNXT(K) if (K .gt. 0) go to 40 c Start over with the first entry. LEV = 1 J = K1 c 100 LEVEL(J) = LEV K = LENT(J) 120 if (KGLTO(K) .lt. 0) then K = KGLNXT(K) if (K .gt. 0) go to 120 go to 190 end if I1 = KGLTO(K) KSTKS4(LEV) = K KSTKS3(LEV) = J 130 KSTKS2(LEV) = LREF(I1-2) 150 I1 = LREF(I1) KSTKS1(LEV) = I1 if (I1 .ne. 0) then I2 = LREF(I1-1) J = I2 170 J = KGLNXT(J) if (J .gt. 0) go to 170 J = -J c J is index of file referring to current entry. if (J .eq. KSTKS3(LEV)) go to 150 if (LEVEL(J) .gt. LEV) go to 150 c Check for recursion do 180 L = 1, LEV - 1 if (I1 .eq. KSTKS1(L)) then c This level used to flag recursion. LEVEL(J) = 1000 go to 150 end if 180 continue LEV = LEV + 1 go to 100 end if I1 = KSTKS2(LEV) if (I1 .ne. 0) go to 130 K = KGLNXT(KSTKS4(LEV)) J = KSTKS3(LEV) if (K .gt. 0) go to 120 190 if (LEV .gt. 1) then LEV = LEV - 1 I1 = KSTKS1(LEV) go to 150 end if 200 continue else c Entry levels -- much easier do 300 K = 1, LAST if (KGLFRO(K) .ne. 0) go to 300 I1 = KGLTO(K) if (I1 .lt. 0) go to 300 LEV = 1 LEVEL(K) = 1 230 I3 = LREF(I1-2) LEV = LEV + 1 c 240 I1 = LREF(I1) if (I1 .ne. 0) then I2 = LREF(I1-1) if (LEVEL(I2) .ge. LEV) go to 240 c Check for recursion do 250 L = 1, LEV - 2 if (I1 .eq. KSTKS1(L)) then LEVEL(I2) = 2000 go to 240 end if 250 continue LEVEL(I2) = LEV KSTKS1(LEV-1) = I1 KSTKS2(LEV-1) = I3 I1 = KGLTO(I2) go to 230 end if if (I3 .ne. 0) then I1 = I3 I3 = LREF(I3-2) go to 240 end if if (LEV .gt. 2) then LEV = LEV - 1 I1 = KSTKS1(LEV-1) I3 = KSTKS2(LEV-1) go to 240 end if 300 continue end if else if (L .eq. 4) then c Need max level from a root if (BYFILE) then c File levels do 600 K1 = 1, LAST K = LENT(K1) if (KGLTO(K) .lt. 0) go to 600 410 I1 = KGLTO(K) c Insure that any entry calling this one is in the same file. 420 I1 = LREF(I1) if (I1 .ne. 0) then I2 = LREF(I1 - 1) 480 I2 = KGLNXT(I2) if (I2 .gt. 0) go to 480 if (K1 .ne. -I2) go to 600 go to 420 end if K = KGLNXT(K) if (K .gt. 0) go to 410 c Start over with the first entry. LEV = 1 J = K1 c 500 LEVEL(J) = LEV K = LENT(J) 510 if (KGLFRO(K) .le. 0) then K = KGLNXT(K) if (K .gt. 0) go to 510 go to 580 end if I1 = KGLFRO(K) KSTKS4(LEV) = K KSTKS3(LEV) = J go to 530 520 I1 = LREF(I1) 530 KSTKS1(LEV) = I1 if (I1 .ne. 0) then I2 = LREF(I1-1) J = I2 540 J = KGLNXT(J) if (J .gt. 0) go to 540 c Skip if there is no file for the entry. if (J .eq. 0) go to 520 J = -J c J is index of file called from current entry. if (J .eq. KSTKS3(LEV)) go to 520 if (LEVEL(J) .gt. LEV) go to 520 c Check for recursion do 560 L = 1, LEV - 1 if (I1 .eq. KSTKS1(L)) then LEVEL(J) = 1000 go to 520 end if 560 continue LEV = LEV + 1 go to 500 end if K = KGLNXT(KSTKS4(LEV)) J = KSTKS3(LEV) if (K .gt. 0) go to 510 580 if (LEV .gt. 1) then LEV = LEV - 1 I1 = KSTKS1(LEV) go to 520 end if 600 continue else c Entry levels -- much easier do 670 K = 1, LAST if (KGLTO(K) .lt. 0) go to 670 if (LREF(KGLTO(K)) .ne. 0) go to 670 LEV = 1 LEVEL(K) = 1 I1 = KGLFRO(K) 630 LEV = LEV + 1 650 if (I1 .ne. 0) then I2 = LREF(I1-1) if (LEVEL(I2) .Lt. LEV) then c Check for recursion do 660 L = 1, LEV - 2 if (I1 .eq. KSTKS1(L)) then LEVEL(J1) = 1000 go to 650 end if 660 continue LEVEL(I2) = LEV KSTKS1(LEV-1) = I1 I1 = KGLFRO(I2) go to 630 end if else LEV = LEV - 1 if (LEV .le. 1) go to 670 I1 = KSTKS1(LEV-1) end if I1 = LREF(I1) go to 650 670 continue end if end if if (ISORTS(J1, KTYP) .gt. 0) then c Make 0 levels large. (Common or mutual recursion.) do 690 K1 = 1, LAST if (LEVEL(K1) .eq. 0) LEVEL(K1) = 1000 690 continue end if 700 continue c c Do the sort 710 call INSORT(NSORTC, LAST, IDX(1, KTYP), K) c Associate the sort position with the file or entry index. do 720 J = 1, LAST I1 = IDX(K, KTYP) IDX(K, KTYP) = J K = I1 720 continue return c End of subroutine NSORT end integer function NSORTC(I, J) c Compare routine for sorting. integer I, J c c Common and parameters required in both GLOCH1 and GLOCH2 integer MXGLOB, MXLREF, MXNAME, MXTYST, MXTLEN parameter (MXGLOB=2020, MXLREF=25000, MXNAME=2333, MXTYST=200, 1 MXTLEN=256) c Misc. Parameters integer LONG, MXFILE parameter (LONG=7, MXFILE=1500) c Parameters used for character mappings integer MAPDIG, MAPOTH parameter (MAPDIG=3, MAPOTH=6) c Parameters associated with bits in symbol table entries. integer KBDEC, KBREF, KBDEF, KBARG, KBDUM, KBCOM, KBPAR, KBDIM, 1 KBEXT, KBGLO, KBDIMW parameter (KBDEC=16, KBREF=32, KBDEF=64, KBARG=128, KBDUM=256, 1 KBCOM=512, KBPAR=1024, KBDIM=2048, KBEXT=32768, KBGLO=65536) parameter (KBDIMW = KBEXT / KBDIM) c character CTYPA*(MXTLEN), FILNAM(MXFILE)*8, GLTYPC*56, 1 NAME(MXNAME)*8, TYPSTR(MXTYST)*(MXTLEN) integer KGLENT(MXGLOB), KGLFRO(MXGLOB), KGLNXT(MXGLOB), 1 KGLTO(MXGLOB), LENT(MXFILE), LFILE, 2 LGLOB, LNAME, LREF(MXLREF), LREFL, LTYPST, MAP(128) common /GLCHRB/ CTYPA, FILNAM, GLTYPC, NAME, TYPSTR common /GLINTB/ KGLENT, KGLFRO, KGLNXT, KGLTO, 1 LENT, LFILE, LGLOB, LNAME, LREF, LREFL, 2 LTYPST, MAP c c Common required only in GLOCH2 character OUTFIL*32 common /GLCHR2/ OUTFIL logical BYFILE, LABELS integer IDX(MXGLOB, 2), INDENT, ISORTD(3, 2), ISORTS(3, 2), KACT, 1 KINDI(2), KRECUR, LEVEL(MXGLOB), LINEW, LIST(5), 2 NAMEI1(MXGLOB), NAMEI2(MXGLOB), NEWGLO, NUM0 common /GLINT2/ IDX, INDENT, ISORTD, ISORTS, KACT, KINDI, KRECUR, 1 LEVEL, LINEW, LIST, NAMEI1, NAMEI2, NEWGLO, NUM0, BYFILE, 2 LABELS c c Locals integer I1, J1, K, K1, K2 c c ********************** Start of Executable Code ********************** c K = 1 50 if (BYFILE) then I1 = ISORTD(K, 1) go to (100, 110, 300, 300), abs(I1) c Sort by names 100 if (FILNAM(I) .gt. FILNAM(J)) then NSORTC = I1 else NSORTC = -I1 end if return 110 stop 'GLOCHK -- Code shouldn''t get here in NSORTC' end if 120 I1 = ISORTD(K, 2) go to (140, 200, 300, 300), abs(I1) c Sort by entry name 140 if (KGLTO(I) .lt. 0) then c Always put common names last. if (KGLTO(J) .ge. 0) then NSORTC = I1 return end if else if (KGLTO(J) .lt. 0) then NSORTC = -I1 return end if if (NAME(KGLENT(I)) .gt. NAME(KGLENT(J))) then NSORTC = I1 else NSORTC = -I1 end if return c Sort by the sort order for the file. 200 K1 = KGLNXT(I) J1 = 0 210 if (K1 .ge. 0) then if (K1 .gt. 0) then J1 = J1 + 1 K1 = KGLNXT(K1) go to 210 end if if (KGLTO(I) .ne. 0) then c Entry is not in a file , sort after other entries K1 = LGLOB else c Name is one for a common block, sort last. K1 = LGLOB + 1 end if else K1 = ISORTD(-K1, 1) end if K1 = 1024*K1*I1 + J1 K2 = KGLNXT(J) J1 = 0 220 if (K2 .ge. 0) then if (K2 .gt. 0) then J1 = J1 + 1 K2 = KGLNXT(K2) go to 220 end if if (KGLTO(J) .ne. 0) then K2 = LGLOB else K2 = LGLOB + 1 end if else K2 = ISORTD(-K2, 1) end if K2 = 1024*K2*I1 + J1 NSORTC = K1 - K2 if (NSORTC .ne. 0) return K = K + 1 go to 120 c Sort by the level. 300 NSORTC = (LEVEL(I) - LEVEL(J)) * I1 if (NSORTC .ne. 0) return K = K + 1 go to 50 c End of subprogram NSORTC end integer function NSORTX(I, J) c Compare routine for sorting global arg info. integer I, J c c Common and parameters required in both GLOCH1 and GLOCH2 integer MXGLOB, MXLREF, MXNAME, MXTYST, MXTLEN parameter (MXGLOB=2020, MXLREF=25000, MXNAME=2333, MXTYST=200, 1 MXTLEN=256) c Misc. Parameters integer LONG, MXFILE parameter (LONG=7, MXFILE=1500) c Parameters used for character mappings integer MAPDIG, MAPOTH parameter (MAPDIG=3, MAPOTH=6) c Parameters associated with bits in symbol table entries. integer KBDEC, KBREF, KBDEF, KBARG, KBDUM, KBCOM, KBPAR, KBDIM, 1 KBEXT, KBGLO, KBDIMW parameter (KBDEC=16, KBREF=32, KBDEF=64, KBARG=128, KBDUM=256, 1 KBCOM=512, KBPAR=1024, KBDIM=2048, KBEXT=32768, KBGLO=65536) parameter (KBDIMW = KBEXT / KBDIM) c character CTYPA*(MXTLEN), FILNAM(MXFILE)*8, GLTYPC*56, 1 NAME(MXNAME)*8, TYPSTR(MXTYST)*(MXTLEN) integer KGLENT(MXGLOB), KGLFRO(MXGLOB), KGLNXT(MXGLOB), 1 KGLTO(MXGLOB), LENT(MXFILE), LFILE, 2 LGLOB, LNAME, LREF(MXLREF), LREFL, LTYPST, MAP(128) common /GLCHRB/ CTYPA, FILNAM, GLTYPC, NAME, TYPSTR common /GLINTB/ KGLENT, KGLFRO, KGLNXT, KGLTO, 1 LENT, LFILE, LGLOB, LNAME, LREF, LREFL, 2 LTYPST, MAP c c Common required only in GLOCH2 character OUTFIL*32 common /GLCHR2/ OUTFIL logical BYFILE, LABELS integer IDX(MXGLOB, 2), INDENT, ISORTD(3, 2), ISORTS(3, 2), KACT, 1 KINDI(2), KRECUR, LEVEL(MXGLOB), LINEW, LIST(5), 2 NAMEI1(MXGLOB), NAMEI2(MXGLOB), NEWGLO, NUM0 common /GLINT2/ IDX, INDENT, ISORTD, ISORTS, KACT, KINDI, KRECUR, 1 LEVEL, LINEW, LIST, NAMEI1, NAMEI2, NEWGLO, NUM0, BYFILE, 2 LABELS c c ********************** Start of Executable Code ********************** c c Sort defined by indices backed in NAMEI1 and order defined in IDX(*,1) 300 NSORTX = IDX(NAMEI1(I)/KBGLO, 2) - IDX(NAMEI1(J)/KBGLO, 2) return c End of subprogram NSORTX end subroutine TXTOUT(ERRNAM, ERRTXT) c Prints out text c c ******************** Variable Declarations *************************** c c character ERRNAM*(*), ERRTXT*(*) c c Common and parameters required in both GLOCH1 and GLOCH2 integer MXGLOB, MXLREF, MXNAME, MXTYST, MXTLEN parameter (MXGLOB=2020, MXLREF=25000, MXNAME=2333, MXTYST=200, 1 MXTLEN=256) c Misc. Parameters integer LONG, MXFILE parameter (LONG=7, MXFILE=1500) c Parameters used for character mappings integer MAPDIG, MAPOTH parameter (MAPDIG=3, MAPOTH=6) c Parameters associated with bits in symbol table entries. integer KBDEC, KBREF, KBDEF, KBARG, KBDUM, KBCOM, KBPAR, KBDIM, 1 KBEXT, KBGLO, KBDIMW parameter (KBDEC=16, KBREF=32, KBDEF=64, KBARG=128, KBDUM=256, 1 KBCOM=512, KBPAR=1024, KBDIM=2048, KBEXT=32768, KBGLO=65536) parameter (KBDIMW = KBEXT / KBDIM) c character CTYPA*(MXTLEN), FILNAM(MXFILE)*8, GLTYPC*56, 1 NAME(MXNAME)*8, TYPSTR(MXTYST)*(MXTLEN) integer KGLENT(MXGLOB), KGLFRO(MXGLOB), KGLNXT(MXGLOB), 1 KGLTO(MXGLOB), LENT(MXFILE), LFILE, 2 LGLOB, LNAME, LREF(MXLREF), LREFL, LTYPST, MAP(128) common /GLCHRB/ CTYPA, FILNAM, GLTYPC, NAME, TYPSTR common /GLINTB/ KGLENT, KGLFRO, KGLNXT, KGLTO, 1 LENT, LFILE, LGLOB, LNAME, LREF, LREFL, 2 LTYPST, MAP c c Common required only in GLOCH2 character OUTFIL*32 common /GLCHR2/ OUTFIL logical BYFILE, LABELS integer IDX(MXGLOB, 2), INDENT, ISORTD(3, 2), ISORTS(3, 2), KACT, 1 KINDI(2), KRECUR, LEVEL(MXGLOB), LINEW, LIST(5), 2 NAMEI1(MXGLOB), NAMEI2(MXGLOB), NEWGLO, NUM0 common /GLINT2/ IDX, INDENT, ISORTD, ISORTS, KACT, KINDI, KRECUR, 1 LEVEL, LINEW, LIST, NAMEI1, NAMEI2, NEWGLO, NUM0, BYFILE, 2 LABELS c c Locals logical NOERR integer J, K save NOERR data NOERR / .true. / c 1060 format(/'Print below gives details for questionable interfaces.'/ 1' One letter per argument or common block entry as follows:'/ 2'In the table heading below: S=scalar, A=array, E expression,'/ 3'R referenced, D value defined, N = neither R nor D, Ae = array'/ 4'element, x = not used, Dr = Defined, might be referenced, and,'/ 5'U=unknown (not defined, might be referenced, passed as actual'/ 6'argument in such a way the state is unknown).'// 7'Actual arg. , Dummy arg. , Common Variable'/ 8'---- S --- , --- SN --- , --- SN'/ 9'| ---- E --- , --- SR --- , --- SR'/ A'| | ---- x --- , --- SDr --- , --- SD'/ B'| | | ---- x --- , --- SU --- , --- SDR'/ C'| | | | --- Ae --- , --- AN --- , --- AN'/ D'| | | | | --- A --- , --- AR --- , --- AR'/ E'| | | | | | --- x --- , --- ADr --- , --- AD'/ F'| | | | | | | --- x --- , --- AU --- , --- ADR'/ G'| | | | | | | | --- Function , Function , --- x'/ H'| | | | | | | | |'/ I'm l k j M L K J 1 logical') 1061 format( 1'v u t s V U T S 2 character'/ 2'i h g f I H G F 3 Integer'/ 3'r q p o R Q P O 4 Real (single precision)'/ 4'd c b a D C B A 5 Double precision'/ 5'z y x w Z Y X W 6 Complex'/ 6'e E e is an external, E is a subroutine'/) c c ****************** Start of Executable Code ************************** c if (OUTFIL .eq. ' ') then if (KACT .le. 3) then OUTFIL = 'gldiagg' else OUTFIL = 'glstuff' end if open (8, FILE=OUTFIL(1:index(OUTFIL, ' ')-1)) end if do 20 K = len(ERRTXT), 2, -1 if (ERRTXT(K:K) .ne. ' ') go to 30 20 continue 30 if (ERRNAM(1:1) .eq. ' ') then if (ERRNAM .ne. ' ') then if (ERRNAM .eq. ' 2') then write (8, '(6X, A)') ERRTXT(1:K) return else if (ERRNAM .eq. ' 3') then if (NOERR) then c Put out the header text. NOERR = .false. write(8, 1060) write(8, 1061) end if end if write (8, '(1X, A)') ERRTXT(1:K) return else J = 0 if (K .eq. 1) then write(8, '(1X)') return end if end if else do 50 J = len(ERRNAM), 2, -1 if (ERRNAM(J:J) .ne. ' ') go to 60 50 continue end if 60 if (J .ne. 0) then write (8, '(1X, 2A)') ERRNAM(1:J), ERRTXT(1:K) else write (8, '(1X, A)') ERRTXT(1:K) end if return c End of TXTOUT end c subroutine WAIT return end