C     GXREF% EDIT GLOBAL CROSS REFERENCE LISTING. PRODUCES
C     TWO LISTINGS, DEPENDING ON WHICH ENTRY POINT IS USED
C     (GXREFB LISTS BY BLOCK)
       SUBROUTINE GXREF   @   INTENDED AS FIRST ENTRY
        IMPLICIT INTEGER (A-Z)
          COMMON/ITEM/NAME,BLOCK,W3,ELT,VERS,DEFNAM,ELT2,VERS2
        DEFINE FLAG = FLD(15,3,W3)
        DEFINE SEQ = FLD(0,15,W3)
        DEFINE RSQ = FLD(18,18,W3)
      DEFINE MFL = FLD(0,6,BLOCK) @ ZERO FOR MODULE CHECKER
      DEFINE MID = FLD(6,6,BLOCK) @ SUBTYPE FOR MODULE CHECKING
      DEFINE MSEQ = FLD(0,18,W3) @ SEQUENCE NUMBER FOR MODULE CHECKING
      LOGICAL SVZ
      DEFINE SVZ(I,J) = I/BOOL(2**J)
      DEFINE MARNO = FLD(18,18,W3) @ ARGUMENT NUMBER FOR MODULE CHECKING
      DEFINE MTY = FLD(18,3,BLOCK) @ TYPE OF ARGUMENT FOR MODULE CHECKING
      DEFINE MSID = FLD (21,3,BLOCK) @ DEFINES MODE OF ARGUMENT
      DEFINE MFMD = FLD(30,3,BLOCK) @ DEFINES MODE OF FNC/SUB/ENT
      INTEGER FNCNME(2,3)/'SUBROU','TINE','ENTRY ',' ','FUNCTI','ON'/
      INTEGER TLT(7) /'Y','I','R','D','C','L','B'/
      INTEGER RLT(7) /'Y','V','A','C','AE','EX','FN'/
      INTEGER FTYPE(2,7) /'UNREFE','RENCED','INTEGE','R','REAL',' '
     *,'DOUBLE',' PREC', 'COMPLE','X','LOGICA','L','BOOLEA','N'/
      INTEGER FMODE(2,6) /'LABEL',' ','VARIAB','LE','ARRAY ','  ',
     * 'FUNCTI','ON','*VARIA','BLE*','*ARRAY','*'/
                    INTEGER IDTB(7)/O1,O22,O44,O2,O66,O2,O10/
        INTEGER BUF(30),WDX,CHX
      PARAMETER MAXWDX = 21
        DATA O1000,O10000/O1000,O10000/
C-----
C     INITIALIZE
C-----
      ASSIGN 200 TO NEWITM
        WRITE(6,5000)  'NAME'
        GO TO 100
C-----
C     ENTRY POINT FOR BLOCK LIST
C-----
       ENTRY GXREFB
        ASSIGN 250 TO NEWITM
       WRITE (6,5000) 'BLOCK'
C
100      CONTINUE
       GENERATE (P,1,1,4)   BUF(P) = ' '
      OLDN = -1
      OLDB = -1
      OLDR = -1
        WDX = 1
150    CALL GETITM(NAME,$950)
       RSA = RSQ
      GO TO NEWITM         @ START DOING IT
C----
C     GET NEW BY-NAME ITEM
C----
200   IF(FLD(0,12,BLOCK).EQ.10) GO TO 610 @ REFERENCE
      IF(FLD(0,12,BLOCK).EQ.8) GO TO 620 @ DEFINITION
      IF(NAME.EQ.OLDN.AND.BLOCK.EQ.OLDB.AND.RSA.EQ.OLDR) GO TO 400
      STARS = ' '        @   ASSUME NAME UNIQUE
      IF(NAME.EQ.OLDN)   STARS = '**'       @     NAME WAS REUSED
        WRITE(6,6000) (BUF(I),I=1,WDX)
        IF(BLOCK.NE.0) WRITE(6,5100) STARS,NAME,BLOCK,RSA
       IF(BLOCK.EQ.0) WRITE(6,5200) STARS,NAME
      GO TO 300
C-----
C      GET NEW BY-BLOCK ITEM.
C-----
250   IF(FLD(0,12,BLOCK).EQ.10) GO TO 150 @ REFERENCE
      IF(FLD(0,12,BLOCK).EQ.8) GO TO 150 @ DEFINITION
      IF(NAME.EQ.OLDN.AND.BLOCK.EQ.OLDB.AND.RSA.EQ.OLDR) GO TO 400
      STARS = ' '
       IF(BLOCK.EQ.OLDB.AND.RSA.EQ.OLDR) STARS = '**'   @   RENAMED STORAGE
       WRITE(6,6000) (BUF(I),I=1,WDX)
      IF(BLOCK.NE.0)  WRITE(6,5300) STARS,BLOCK,RSA,NAME
      IF(BLOCK.EQ.0)   WRITE(6,5400) STARS,NAME
C-----
C     FINISH CHANGE OF ENTITY
C----
300   OLDN = NAME
      OLDB=BLOCK
      OLDR =RSA
      GO TO 410     @ BYPASS TEST AND FLUSH
C    NORMAL NEW REFERENCE
C----
400    IF(ELT.EQ.OLDE.AND.VERS.EQ.OLDV)    GO TO 450
        IF(IZ.EQ.1)    WRITE(6,6000) (BUF(I),I=1,WDX)
        IZ=0
       OLDE = ELT
      OLDV = VERS
410   WDX = 1
                                       @   SET UP FIRST LINE
      CHX = -6                         @ FOR ELEMENT
       CALL ENAME (ELT)
          IF(ELT2.NE.' ') CALL ENAME(ELT2)
       IF(VERS.EQ. ' ')   GO TO 420
       CALL PC(1R/)
       CALL ENAME (VERS)
          IF(VERS2.NE.' ') CALL ENAME(VERS2)
420   CALL PC(1R )
       CALL PC(1R )
       GO TO 470                   @  BY PASS COMMA
C----
C   EDIT A REFERENCE
C----
450   SVWDX = WDX
          IF(FLAG.EQ.1) IZ = 1
451
        SVCHX = CHX
        CALL PC(1R,)
        CALL PC(1R )
470       IF(FLAG.GT.1) CALL PC(1R*)     @ DEFN POINT
       SB= 27                     @   SEQUENCE NUMBER
       IF(SEQ.GT.O1000)   SB = 24
        IF(SEQ.GT.O10000)    SB=21
        DO 480 I=SB,33,3
480     CALL PC(FLD(I,3,SEQ)+1R0)
       IF(DEFNAM.EQ.0)   GO TO 490
        CALL PC(1R()      @    EDIT DEFINE NAME
        CALL ENAME(DEFNAM)
      CALL PC(1R))
490    IF(WDX-MAXWDX)   150,500,510
500    IF(CHX.LT.30)    GO TO 150
510     WDX = SVWDX         @   MUST START NEW LINE
       CHX = SVCHX
        DO 520 I=1,6
520       CALL PC(1R )
        WRITE(6,6000) ( BUF(I),I=1,SVWDX)
       BUF(1) = ' '
        WDX = 1
       CHX = 18
        GO TO 470       @  REDO IT GUARANTEED NO OVERFLOW
  950 WRITE (6,6000)(BUF(I),I=1,WDX)
        RETURN
C
620   CONTINUE @ PROCESS DEFINITION HERE
      IF(RFLG.NE.0)
      WRITE(6,6000) (BUF(I),I=1,WDX) @ CLOSE OUT LAST LINE
      ENDIF
      IF(NAME.NE.SNAME)
      WDX = 1 ; CHX = -6
      CALL ENAME(FNCNME(1,MFMD))  ; CALL ENAME(FNCNME(2,MFMD))
      CALL PC (1R )  ; CALL PC (1R )
      CALL ENAME(NAME) ; CALL PC(1R ) ; CALL PC(1R )
      CALL ENAME('AT') ; CALL PC(1R )
      SB = 27
      IF(MSEQ.GT.01000)  SB = 24
      IF(MSEQ.GT.010000) SB = 21
      DO 625 I = SB,33,3
625   CALL PC(FLD(I,3,MSEQ)+1R0)
      CALL PC (1R ) ; CALL ENAME('IN') ; CALL PC (1R )
      CALL ENAME(ELT) ; IF(ELT2.NE.' ') CALL ENAME(ELT2)
      IF(VERS.NE.' ')
      CALL PC(1R/) ; CALL ENAME(VERS)
      IF(VERS2.NE.' ') CALL ENAME(VERS2)
      ENDIF
      DO I = 1,6
      CALL PC(1R )
      ENDLOOP
      WRITE(6,6000) (BUF(I),I=1,WDX)
      ENDIF
      ARNO = MARNO @ SAVE ARGUMENT NUMBER
      SNAME = NAME @ SAVE NAME
      STYPE = MTY @ SAVE TYPE OF DEFINITION
      SMODE = MSID @ SAVE MODE OF DEFINITION
      IF(ARNO.EQ.0)  RFLG = 0 ; ERFL = 0 ; GO TO 150
      WDX = 2 @ SET TO COLUMN 6
      CHX = -6
      BUF(1) = ' ' ; BUF(2) = ' '
      CALL ENAME('ARGUM')
      CALL ENAME('ENT')
      CALL PC(1R )
      CALL PC(1R )
      CALL PC(1R )
      IF(ARNO.LE.9)
      CALL PC(MOD(ARNO,10)+1R0)
      ELSE
      CALL PC(ARNO/10+1R0)
      CALL PC(MOD(ARNO,10)+1R0)
      ENDIF
      CALL PC(1R )
      CALL PC(1R )
      CALL PC(1R )
      CALL ENAME (FTYPE(1,MTY+1)) ; CALL ENAME (FTYPE(2,MTY+1))
      CALL PC(1R/)
      CALL ENAME (FMODE(1,MSID+1)) ; CALL ENAME(FMODE(2,MSID+1))
      RFLG = 0   @ FORCE DEFINITION TO NEW LINE
      ERFL = 0  @  SHOW DEFINITION OCCURRED
      WRITE(6,6000) (BUF(I),I=1,WDX) @ CLOSE OUT LAST LINE
      GO TO 150                          @ GET NEXT GROUP
610   CONTINUE @ PROCESS REFERENCE HERE
      IF(NAME.NE.SNAME) GO TO 630
      IF(MARNO.NE.ARNO) GO TO 640
615   IF(RFLG.NE.0)
           IF(WDX.GT.15)
               WRITE(6,6000) (BUF(I) ,I=1,WDX)
                  WDX = 3  ; CHX = -6
            ELSE
            CALL PC(1R,)
             ENDIF
           ELSE
           WDX = 3  @ SKIP TO COLUMN 18
           CHX = -6
           BUF(1) = ' ' ; BUF(2) = ' '
           ENDIF
      SB = 27
      IF(MSEQ.GT.01000) SB = 24
      IF(MSEQ.GT.010000) SB = 21
      DO I = SB,33,3
      CALL PC(FLD(I,3,MSEQ)+1R0)
      ENDLOOP
      CALL PC(1R()
      CALL ENAME(ELT)
      IF(ELT2.NE.' ') CALL ENAME(ELT2)
      IF(VERS.NE.' ') CALL PC(1R/) ; CALL ENAME(VERS)
     * ; IF(VERS2.NE.' ') CALL ENAME (VERS2)
      CALL PC(1R))
      IF(ARNO.EQ.0) RFLG = 1 ; GO TO 150
      ITF = ' '  @ SET TO ASTERISK IF TYPES DO NOT MATCH
      IMF = ' '  @ SET TO ASTERISK IF MODES DO NOT MATCH
      CALL PC(1R )
      CALL PC(1R )
      IF(MTY.NE.STYPE) ITF = 1R*
      CALL PC(FLD(0,6,TLT(MTY+1))) @ LETTER DEFINING TYPE
      CALL PC(1R/)
      CALL PC(FLD(0,6,RLT(MSID+1)))
      CALL PC(FLD(6,6,RLT(MSID+1)))   @ LETTER DEFINING MODE
      IF(.NOT.SVZ(IDTB(SMODE),MSID)) IMF = 1R*
      IF(ERFL.NE.0) IMF = 1R  ; ITF = 1R
      CALL PC(ITF) @ FLAG FOR TYPE MISMATCH
      CALL PC(ITF) @ FLAG FOR MODE MISMATCH
      RFLG= 1   @  SHOW AT LEAST ONE DEFINITION PRINTED
       GO TO 150 @  GET NEXT ITEM
630   CONTINUE
      IF(RFLG.NE.0) WRITE(6,6000) (BUF(I),I=1,WDX)
     * ;WDX = 3 ; CHX = -6
      WRITE(6,6300) NAME
6300  FORMAT(' REFERENCE TO UNDEFINED FUNCTION ',A6)
635   CONTINUE
      ARNO = MARNO ; SNAME = NAME
      RFLG = 0
      EFRL = 1
       GO TO 615
640   CONTINUE
      IF(RFLG.NE.0) WRITE(6,6000) (BUF(I),I=1,WDX)
     *  ;WDX = 3 ;  CHX = -6
      WRITE(6,6400) MARNO
6400   FORMAT(' NO DEFINITION FOR ARGUMENT ',I4)
      GO TO 635
5000  FORMAT ('1  GLOBAL CROSS-REFERENCE BY ',A6//)
5100  FORMAT ('0',A2,1X,A6,' /',A6,'/ ',O6/)
5200  FORMAT ('0',A2,1X,A6,'(EXTERNAL)'/)
5300  FORMAT ('0',A2,' /',A6,'/ ',O6,' = ',A6/)
5400  FORMAT ('0',A2,' (EXTERNAL) ',A6/)
6000  FORMAT (7X,20A6,A5)
C
      SUBROUTINE PC(C)
      CHX=CHX+6
       IF(CHX.NE.36) GO TO 10
       CHX = 0
        WDX = WDX +1
      BUF(WDX) = ' '
10      FLD(CHX,6,BUF(WDX))   =   C
      RETURN
C
       SUBROUTINE ENAME (N)
       DO 10 I=0,30,6
10      IF(FLD(I,6,N).NE.1R ) CALL PC(FLD(I,6,N))
       RETURN
C
      END
