stadef.for

This Source-Navigator, an IDE for C/C++/Fortran/Java/Tcl/PHP/Python and a host of other languages.

      DATA SDESCR( 57)/'54 0 PRINT                   DITO               DEF
     [phone]  0  0'/                          DEF
      DATA SDESCR( 58)/'52 0 PARAMETER               DITO               DEF
     [phone]  0'/                          DEF
      DATA SDESCR( 59)/'53 0 PAUSE                   DITO               DEF
     [phone]  0'/                          DEF
      DATA SDESCR( 60)/'55 0 PROGRAM                 DITO               DEF
     [phone]  0  0'/                          DEF
      DATA SDESCR( 61)/'56 0 PUNCH                   DITO               DEF
     [phone]  0  0'/                          DEF
      DATA SDESCR( 62)/'58 0 READ(                   DITO               DEF
     [phone]  0  0'/                          DEF
      DATA SDESCR( 63)/'57 0 READ                    DITO               DEF
     [phone]  0  0'/                          DEF
      DATA SDESCR( 64)/'60 0 REALFUNCTION            DITO               DEF
     [phone]  2  0 19'/                          DEF
      DATA SDESCR( 65)/'59 0 REAL                    REAL*@             DEF
     [phone]  0  0  0'/                          DEF
      DATA SDESCR( 66)/'59 0 REAL                    DITO               DEF
     [phone]  0  0  0'/                          DEF
      DATA SDESCR( 67)/'61 0 RETURN                  DITO               DEF
     [phone]  0'/                          DEF
      DATA SDESCR( 68)/'62 0 REWIND                  DITO               DEF
     [phone]  0  0'/                          DEF
      DATA SDESCR( 69)/'63 0 SAVE                    DITO               DEF
     [phone]  0'/                          DEF
      DATA SDESCR( 70)/'65 0 STOP                    DITO               DEF
     [phone]  0'/                          DEF
      DATA SDESCR( 71)/'66 0 SUBROUTINE              DITO               DEF
     [phone] 19  0  0'/                          DEF
      DATA SDESCR( 72)/'68 0 WRITE                   DITO               DEF
     [phone]  0  0'/                          DEF
      DATA SDESCR( 73)/' 2 5 ASSIGNMENT              ?=                 DEF
     + 0 0 0 1 2 0 0  1  1  0  2  0 17  0  0'/                          DEF
      DATA SDESCR( 74)/' 2 6 ASSIGNMENT              ?(>)=              DEF
     + 0 0 0 1 2 0 0  1  2  0 10  2  0 17  0'/                          DEF
      DATA SDESCR( 75)/' 2 7 ASSIGNMENT              ?(>)(>)=           DEF
     + 0 0 0 1 2 0 0  1  1  0  2  0 17  0  0'/                          DEF


      DATA SLAST/' '/
      DATA DOITFL/.TRUE./
      include 'condat.h'
*
*--- do it only once
*
      IF(DOITFL)  THEN
         DOITFL=.FALSE.
         NHEADR=0
         NPRIOR=0
         NPNAM=0
         NPSTM=0
         NCLASS=MXSTAT
         DO 10 I=1,53
            IALPHA(1,I)=0
            IALPHA(2,I)=-1
   10    CONTINUE
c
         iif = 0
         iend = 0
         iformt = 0
         ill = 0
         iretur = 0
c
         DO 30 I=1,MXSTAT
            READ (SDESCR(I),'(2I2,44X,7I2,8i3)',err=88)
     &           (ISTMDS(J,I),J=6,MCLASS)
            NP=ISTMDS(7,I)
            IF (NP.GT.0.AND.NP.LE.NCLASS)  THEN
               NPRIOR=NPRIOR+1
               IPRIOR(NP)=I
            ENDIF
            READ (SDESCR(I),'(5X,A24,A20)') STR1,STR2
            NST1=INDEX(STR1,' ')-1
            NST2=INDEX(STR2,' ')-1
            SNAM(NPNAM+1:NPNAM+NST1)=STR1
            ISTMDS(1,I)=NPNAM+1
            NPNAM=NPNAM+NST1
            ISTMDS(2,I)=NPNAM
            IF (NST2.EQ.0)  THEN
*--- statement descriptor blank - indicate
               ISTMDS(3,I)=0
               IF (ISTMDS(6,I).EQ.69.and.ill.eq.0) ILL=I
            ELSEIF (STR2(1:4).EQ.'DITO')  THEN
*--- use name as descriptor
               SSTM(NPSTM+1:NPSTM+NST1)=STR1
               ISTMDS(3,I)=NPSTM+1
               NPSTM=NPSTM+NST1
               ISTMDS(4,I)=NPSTM
            ELSE
               SSTM(NPSTM+1:NPSTM+NST2)=STR2
               ISTMDS(3,I)=NPSTM+1
               NPSTM=NPSTM+NST2
               ISTMDS(4,I)=NPSTM
            ENDIF
*--- set some class references
            IF (ISTMDS(6,I).EQ.40.and.iif.eq.0)  THEN
*--- logical IF
               IIF=I
            ELSEIF (ISTMDS(6,I).EQ.26.and.iend.eq.0)  THEN
*--- END statement
               IEND=I
            ELSEIF (ISTMDS(6,I).EQ.33.and.iformt.eq.0)  THEN
*--- FORMAT
               IFORMT=I
            ELSEIF (ISTMDS(6,I).EQ.61.and.iretur.eq.0)  THEN
*--- RETURN
               IRETUR=I
            ENDIF
*--- get start of alphabetic group
            STEMP=SSTM(ISTMDS(3,I):ISTMDS(3,I))
            IF (ISTMDS(3,I).NE.0)  THEN
               IF (STEMP.NE.SLAST)  THEN
                  IF (SPECCH(STEMP))  THEN
                     K=53
                  ELSE
                     K=ICVAL(STEMP)
                  ENDIF
                  IALPHA(1,K)=I
                  IF (SLAST.NE.' ')  THEN
                     K=ICVAL(SLAST)
                     IALPHA(2,K)=I-1
                  ENDIF
                  SLAST=STEMP
               ENDIF
            ENDIF
            K=ISTMDS(3,I)-1
*--- find and store last alphabetic ch. in descr.
            DO 20 J=ISTMDS(3,I),ISTMDS(4,I)
               IF (ALPHCH(SSTM(J:J))) K=J
   20       CONTINUE
            ISTMDS(5,I)=K
*--- routine headers
            IF (ISTMDS(14,I).NE.0)  THEN
               NHEADR=NHEADR+1
               IHEADR(NHEADR)=I
            ENDIF
   30    CONTINUE
         IALPHA(2,53)=NCLASS
*--- end of IF(DOITFL)  following
      ENDIF
      return
   88 write(mpunit,'(A)') ' Error in STADEF ... Abort'
      END