procom.for

这是一个Linux下的集成开发环境

      SUBROUTINE PROCOM
*-----------------------------------------------------------------------
*
*   Processes common blocks: collects name lists,
*   marks the variables referenced in each routine
*
*-----------------------------------------------------------------------
      include 'param.h'
      include 'alcaza.h'
      include 'class.h'
      include 'flags.h'
      include 'cursta.h'
      include 'flwork.h'
      include 'state.h'
      LOGICAL RANGE
      CHARACTER*(mxnmch) SCB
*--- get external statement number
      ICLE=ISTMDS(6,ICURCL(1))
      IF(ICLE.EQ.12)  THEN
*--- common block
         IV=0
         ICOMMB=ISTMDS(17,ICURCL(1))
         ICOMMV=ISTMDS(21,ICURCL(1))
   10    CONTINUE
*--- find c.b. name, and first and last variable in this c.b.
         IF(ITBIT(NAMTYP(ISNAME+IV+1),ICOMMB).EQ.0) THEN
*--- first name not c.b. name ---> blank common
            SCB='BLANKCOM'
         ELSE
            SCB=SNAMES(ISNAME+IV+1)
            IV=IV+1
         ENDIF
*--- last var. in this c.b. is min. pos. of '//', or c.b. name
         IPT=NSSTRT(IV+1)-1
         INS=INDEX(SSTA(IPT+1:NCHST),'//')
         IND=INDEX(SSTA(IPT+1:NCHST),'/ /')
         IF(IND.GT.0) THEN
            IF(INS.GT.0) THEN
               INS=MIN(IND,INS)
            ELSE
               INS=IND
            ENDIF
         ENDIF
         IF(INS.GT.0) THEN
            INS=IPT+INS
         ELSE
            INS=NCHST+1
         ENDIF
*--- collect variable name ref.s in IWS
         N=0
         ILOW=IV+1
         DO 20 I=ILOW,NSNAME
            K=ISNAME+I
            NT=NAMTYP(K)
            IF(ITBIT(NT,ICOMMB).NE.0) GOTO 30
            IF(NSSTRT(I).GT.INS) GOTO 30
            IF(ITBIT(NT,ICOMMV).NE.0) THEN
               IF(NCBVAR+N.EQ.MXNAME) GOTO 180
               N=N+1
               SCBVAR(NCBVAR+N)=SNAMES(K)
            ENDIF
            IV=I
   20    CONTINUE
   30    CONTINUE
*--- store in name list for this common block
         IF(N.GT.0) THEN
            CALL LSORT(SCBVAR(NCBVAR+1),IWS,.FALSE.,N)
*--- look for name in c.b. name table
            CALL NAMSRC(SCB,SCBNAM,NCBNAM,IPOS,LAST)
            IF(IPOS.EQ.0) THEN
*--- not in table - add to existing
               IF(NCBNAM.EQ.MAXGRP) GOTO 190
               DO 40 I=NCBNAM,LAST+1,-1
                  SCBNAM(I+1)=SCBNAM(I)
                  NCBGRP(I+1)=NCBGRP(I)
                  KCBGRP(I+1)=KCBGRP(I)
   40          CONTINUE
               NCBNAM=NCBNAM+1
               SCBNAM(LAST+1)=SCB
               NCBGRP(LAST+1)=N
               KCBGRP(LAST+1)=NCBVAR
            ELSE
*--- already in table - add in place, and merge
               CALL NAMOVE(SCBVAR,KCBGRP(IPOS)+NCBGRP(IPOS),NCBVAR,N)
               CALL LMERGE(SCBVAR,IWS,.FALSE.,KCBGRP(IPOS),NCBGRP(IPOS),
     +         N)
               DO 50 I=1,NCBNAM
                  IF(KCBGRP(I).GT.KCBGRP(IPOS)) KCBGRP(I)=KCBGRP(I)+N
   50          CONTINUE
               DO 60 I=1,NEQNAM
                  IF(KEQGRP(I).GT.KCBGRP(IPOS)) KEQGRP(I)=KEQGRP(I)+N
   60          CONTINUE
               NCBGRP(IPOS)=NCBGRP(IPOS)+N
            ENDIF
            NCBVAR=NCBVAR+N
         ENDIF
         IF(IV.LT.NSNAME) GOTO 10
      ELSEIF(ICLE.EQ.30)  THEN
*--- EQUIVALENCE
         IV=0
         IPT=0
   70    CONTINUE
         ILB=INDEX(SSTA(IPT+1:NCHST),'(')
         IF(ILB.GT.0) THEN
            ILB=ILB+IPT
            CALL SKIPLV(SSTA,ILB+1,NCHST,.FALSE.,IRB,ILEV)
            IF(IRB.GT.0) THEN
               IPT=IRB
*--- only names outside brackets (inside each group)
               CALL GETRNG(ILB+1,IRB-1,IWS)
               ILOW=IV+1
               N=0
               DO 80 I=ILOW,NSNAME
                  IF(NSSTRT(I).GT.IRB) GOTO 90
                  IF(.NOT.RANGE(NSSTRT(I),IWS)) THEN
                     IF(NCBVAR+N.EQ.MXNAME) GOTO 180
                     N=N+1
                     SCBVAR(NCBVAR+N)=SNAMES(ISNAME+I)
                  ENDIF
                  IV=I
   80          CONTINUE
   90          CONTINUE
               IF(N.GT.0) THEN
                  IF(NEQNAM.EQ.MAXGRP) GOTO 200
                  CALL LSORT(SCBVAR(NCBVAR+1),IWS,.FALSE.,N)
                  NEQNAM=NEQNAM+1
                  KEQGRP(NEQNAM)=NCBVAR
                  NEQGRP(NEQNAM)=N
                  NCBVAR=NCBVAR+N
               ENDIF
               IF(IPT.LT.NCHST) GOTO 70
            ENDIF
         ENDIF
      ELSEIF(ICLE.EQ.16.OR.ISTMDS(11,ICURCL(1)).EQ.1)  THEN
*--- DATA statement, or executable, i.e. start of routine
         IF(.NOT.STATUS(13)) THEN
*--- merge all equiv. groups with common blocks
            STATUS(13)=.TRUE.
  100       CONTINUE
            DO 150 IE=1,NEQNAM
               KEQ=KEQGRP(IE)
               NEQ=NEQGRP(IE)
               DO 140 IEI=1,NEQ
                  DO 130 IC=1,NCBNAM
                     CALL NAMSRC(SCBVAR(KEQGRP(IE)+IEI),SCBVAR(KCBGRP
     +               (IC)+1), NCBGRP(IC),IPOS,LAST)
                     IF(IPOS.NE.0) THEN
*--- equiv. group var. is in this c.b., add complete group
                        CALL NAMOVE(SCBVAR,KCBGRP(IC)+NCBGRP(IC),KEQ,
     +                  NEQ)
                        KCB=KCBGRP(IC)
                        DO 110 I=1,NCBNAM
                           IF(KEQ.LT.KCB) THEN
                              IF(KCBGRP(I).LE.KCB.AND.KCBGRP(I).GT.KEQ)
     +                        KCBGRP(I)=KCBGRP(I)-NEQ
                           ELSE
                              IF(KCBGRP(I).GT.KCB.AND.KCBGRP(I).LT.KEQ)
     +                        KCBGRP(I)=KCBGRP(I)+NEQ
                           ENDIF
  110                   CONTINUE
                        DO 120 I=1,NEQNAM
                           IF(KEQ.LT.KCB) THEN
                              IF(KEQGRP(I).LE.KCB.AND.KEQGRP(I).GT.KEQ)
     +                        KEQGRP(I)=KEQGRP(I)-NEQ
                           ELSE
                              IF(KEQGRP(I).GT.KCB.AND.KEQGRP(I).LT.KEQ)
     +                        KEQGRP(I)=KEQGRP(I)+NEQ
                           ENDIF
  120                   CONTINUE
                        CALL LMERGE(SCBVAR,IWS,.FALSE.,KCBGRP(IC),NCBGRP
     +                  (IC),NEQ)
                        CALL SUPMUL(SCBVAR,IWS,.FALSE.,KCBGRP(IC),
     +                  NCBGRP(IC)+NEQ,N)
                        NCBGRP(IC)=N
                        NEQGRP(IE)=0
*--- restart search
                        GOTO 100
                     ENDIF
  130             CONTINUE
  140          CONTINUE
  150       CONTINUE
         ENDIF
*--- look for any name in statement being in a c.b.
         DO 170 I=1,NSNAME
            DO 160 IC=1,NCBNAM
               CALL NAMSRC(SNAMES(ISNAME+I),SCBVAR(KCBGRP(IC)+1),NCBGRP
     +         (IC), IPOS,LAST)
               IF(IPOS.GT.0) THEN
*--- name is in this c.b. - set flag, count
                  IF(LCBVAR(KCBGRP(IC)+IPOS).EQ.0)
     +            LCBNAM(IC)=LCBNAM(IC)+1
                  LCBVAR(KCBGRP(IC)+IPOS)=LCBVAR(KCBGRP(IC)+IPOS)+1
                  GOTO 170
               ENDIF
  160       CONTINUE
  170    CONTINUE
      ENDIF
      GOTO 999
*--- error - name buffer overflow
  180 CONTINUE
      STATUS(12)=.TRUE.
      WRITE(MPUNIT,10000) MXNAME,SCROUT(:lenocc(scrout))
      GOTO 999
  190 CONTINUE
      STATUS(12)=.TRUE.
      WRITE(MPUNIT,10010) MAXGRP,SCROUT(:lenocc(scrout))
      GOTO 999
  200 CONTINUE
      STATUS(12)=.TRUE.
      WRITE(MPUNIT,10020) MAXGRP,SCROUT(:lenocc(scrout))
10000 FORMAT(/' +++++++++ WARNING - more than',I8,' variable names',
     +' in COMMON and EQUIV., routine ',A,' skipped')
10010 FORMAT(/' +++++++++ WARNING - more than',I8,' common block names',
     +', routine ',A,' skipped')
10020 FORMAT(/' +++++++++ WARNING - more than',I8,' groups',
     +' in EQUIVALENCE, routine ',A,' skipped')
  999 END