Article 12868 of alt.sources:
Path: nntpd.lkg.dec.com!crl.dec.com!pa.dec.com!news1.digital.com!uunet!in2.uu.net!news.sprintlink.net!howland.reston.ans.net!news.cac.psu.edu!news.math.psu.edu!ra.nrl.navy.mil!mitch.nrl.navy.mil!grunes
From: grunes@news.nrl.navy.mil (Mitchell R Grunes)
Newsgroups: alt.sources
Subject: diagramf diagramming program updated for Fortran 90/95
Date: 30 Sep 1995 00:11:48 GMT
Organization: AlliedSignal Technical Services Corp.
Lines: 822
Message-ID: <grunes.358.0@news.nrl.navy.mil>
NNTP-Posting-Host: mitch.nrl.navy.mil

Archive-name: diagramf
Submitted-by: grunes@nrlvax.nrl.navy.mil (Mitchell R Grunes)

****diagramf: Simple Diagrammer for Fortran Language Programs****

The most recent changes: Updated to diagram Fortran 90 and 95 source code.

If you like or dislike it, send e-mail.  DON'T POST to alt.sources.
Sorry, little or no help can be provided for this program, and
I can't find problems without an example of where it failed.
Early versions were called "diagram".

CONTENTS:
  diagramf.for     Fortran language source code.
  diagramf.bat     Sample MS-DOS procedure to run without answering
                   questions, on card format programs.
                   Executable must be in c:\grunes.
  diagram9.bat     Same, for free format programs.

---diagramf.for--------------CUT HERE-----------------------------
c EXAMPLE OF OUTPUT (looks better if you choose IBM PC line graphics):

c      +---------------- subroutine a(x)             |   1
c      |+--------------- do i=1,5                    |   2
c      ||+---------------- if(i/2*2.eq.i)then        |   3
c      |||                   x(i)=1                  |   4
c      ||+---------------- else                      |   5
c      |||                   x(i)=2                  |   6
c      ||+---------------- endif                     |   7
c      |+--------------- enddo                       |   8
c      +---------------- end                         |   9

c Diagrams FORTRAN if-else-elseif-endif, do-enddo and case constructs,
c  start and end of routines, type definitions, modules and interfaces;
c  puts a * next to goto, return, cycle, exit, stop, end= and err=.

c Program by Mitchell R Grunes, ATSC/NRL (grunes@nrlvax.nrl.navy.mil).
c Revision date: 9/29/95.
c If you find it useful, or find a problem, please send me e-mail.

c This program was written in FORTRAN, the One True Language.

c This was written in Fortran 77 (with common extensions, for portability.
c  It should also compile under Fortran 90 and Fortran 95, provided you
c  tell the compiler it is in card format.

c Note--this is a quick and dirty attempt--may not always work quite
c  right.

c It can also be confused if an INCLUDE block contains a structure that
c  begins inside and ends outside (or vice-versa).

c I hope this works for you, but bear in mind that nothing short of
c  a full-fledged language parser could really do the job.  Perhaps
c  worth about what you paid for it.    (-:

c Versions: To diagram Fortran:     diagramf.for
c                      IDL/PV-WAVE: diagrami.for
c                      C:           diagramc.for
c MS-DOS procedures to call above programs without asking so many
c  questions, append output to file diagram.out:
c                      Fortran:     diagramf.bat (card format)
c                                   diagram9.bat (free format)
c                      IDL/PV-WAVE: diagrami.bat
c                      C:           diagramc.bat

        program diagramf                        ! Diagrammer for Fortran
        character*80 filnam,filnam2

        print*,'FORTRAN source filename?'
        read(*,'(a80)')filnam
        print*,filnam

        print*,'Output file (blank=screen)?'
        read(*,'(a80)')filnam2
        print*,filnam2

        print*,'Column in which to write line #''s ',
     &   '(0 for none; 67 for 80 col screen; 73 to show card format):'
        read*,LCol
        print*,LCol

        print*,'Embed include files (0=no):'
        read*,iembed
        print*,iembed
        print*,' '
        print*,'0=Card format (cols 1-6 special, warnings past 72)'
        print*,'1=Free format'
        print*,'2=Card format (same, ignore cols past 72)'
        print*,'Format #:'
        read*,ifree
        print*,ifree

        print*,'Use IBM PC graphics characters (0=no):'
        read*,igraphics
        print*,igraphics

        call diagram(filnam,filnam2,LCol,iembed,ifree,igraphics)
        end
c-----------------------------------------------------------------------
        subroutine diagram(filnam,filnam2,LCol,iembed,ifree,igraphics)
c Program by Mitchell R Grunes, ATSC/NRL (grunes@nrlvax.nrl.navy.mil).
        character*80 filnam,filnam2
        character*160 a,b,AfterSemi
        character*5 form
        character*8 fm
        character*1 c,c2
        logical find
        external find
        common iCol,iCol1
        character*10 label(100)
        logical fout
        logical FindInclude

c Symbols which will mark block actions:
        character*1 BlockBegin    (2) /'+','+'/  ! Start of block
        character*1 BlockEnd      (2) /'+','+'/  ! End of block
        character*1 BlockElse     (2) /'+','+'/  ! Else construct
        character*1 BlockContinue (2) /'|','|'/  ! Block continues w/o change
        character*1 BlockHoriz    (2) /'-','-'/  ! Horizontal to start of line
c Same, but allows horizontal line to continue through:
        character*1 BlockBeginH   (2) /'+','+'/  ! Start of block
        character*1 BlockEndH     (2) /'+','+'/  ! End of block
        character*1 BlockElseH    (2) /'+','+'/  ! Else construct

        if(iGraphics.ne.0)then
          iGraphics=1

          BlockBegin   (1)=char(218)            ! (1)=normal
          BlockEnd     (1)=char(192)
          BlockElse    (1)=char(195)
          BlockContinue(1)=char(179)
          BlockHoriz   (1)=char(196)
          BlockBeginH  (1)=char(194)
          BlockEndH    (1)=char(193)
          BlockElseH   (1)=char(197)

          BlockBegin   (2)=char(214)            ! (2)=DO/FOR loops (doubled)
          BlockEnd     (2)=char(211)            ! (not yet used)
          BlockEnd     (2)=char(211)
          BlockElse    (2)=char(199)
          BlockContinue(2)=char(186)
          BlockHoriz   (2)=char(196)
          BlockBeginH  (2)=char(209)
          BlockEndH    (2)=char(208)
          BlockElseH   (2)=char(215)
        endif

        open(1,file=filnam,status='old')
        fout=filnam2.gt.' '
        if(fout)open(2,file=filnam2,status='unknown')
                                                ! ASCII 12 is a form feed
        if(fout)write(2,*)char(12),
     &   '=============--',filnam(1:LenA(filnam)),'--============='

        if(fout)     write(2,'(11x,a50,a49,/)')  ! Write column header
     &   '....,....1....,....2....,....3....,....4....,....5',
     &   '....,....6....,....7....,....8....,....9....,....'
        if(.not.fout)write(*,'(11x,a50,a49,/)')' ',
     &   '....,....1....,....2....,....3....,....4....,....5',
     &   '....,....6....,....7....,....8....,....9....,....'

        i1=0                                    ! # of nest levels before
                                                !  current line
        i2=0                                    ! # of nest levels on
                                                !  current line
        i3=0                                    ! # of nest levels after
                                                !  current line
        i4=0                                    ! not 0 to flag start or end
                                                !  of block
        InSub=0                                 ! Inside a subroutine,
                                                !  function or mainline
        InMod=0                                 ! Inside module or
                                                !   contains
        nMain=0                                 ! no mainline program yet
        InElse=0                                ! Found elseif, but not then
        nlabel=0                                ! # of labels for do loop
                                                !  ends
        iAlphaNum=0                             ! Last char of line is
                                                !  alpha-numeric
        iOldContinue=0                          ! Not continued line
        nline=0
        iunit=1
10      a=' '
        read(iunit,'(a160)',end=99)a
        nline=nline+1
        fm=' '
        write(fm,'(i5)')nline
        form=fm

        if(a(1:1).eq.char(12))then
          if(fout)write(2,'(a1,:)')char(12)
          if(.not.fout)print*,'------------FORM FEED------------'
          b=a(2:160)
          a=b
        endif

        b=' '                                   ! Turn tabs to spaces
        j=1
        do i=1,LenA(a)
          if(a(i:i).eq.char(9))then
            j=(j-1)/8*8+8+1
          elseif(j.le.160)then
            b(j:j)=a(i:i)
            j=j+1
          endif
        enddo

        a=' '                                   ! Pre-processed output
        i=1                                     ! Basic pre-processing
        j=1
        i72flag=0                               ! nothing over column 72
                                                ! yet
        iOldAlphaNum=iAlphaNum                  ! last line ended in
                                                ! alpha-numeric?
        iAlphaNum=0
        iContinue=iOldContinue                  ! continued line?
        if(find(b,'&',2,0))iContinue=1          !  will be changed to 2 after
                                                !  first non/blank.
        if(i.eq.6.and.c.ne.' '.and.ifree.ne.1)iContinue=1
        if(iContinue.eq.0)then
          iquote=0                              ! no ' yet
          idquote=0                             ! no " yet
        endif
        iOldContinue=0
        if(b(LenA(b):LenA(b)).eq.'&')iOldContinue=1
        j=1
                                                ! comment line
        if((b(1:1).eq.'c'.or.b(1:1).eq.'C').and.ifree.ne.1)goto 15

        FindInclude=find(a,'include ',2,0)

        do i=1,LenA(b)
          c=b(i:i)
                                                ! handle upper case
          if(c.ge.'A'.and.c.le.'Z')c=char(ichar(c)+32)
                                                ! ASCII 33 is '!'
          if(c.eq.char(33).and.iquote.eq.0.and.idquote.eq.0)goto 15

          if(i.gt.72.and.c.ne.' ')then
            if(ifree.eq.0.and.i72flag.eq.0)then
              i72flag=1
              PRINT*,'***WARNING--PAST COLUMN 72 at line',form
              print*,char(7)
            elseif(ifree.eq.2)then
              c=' '
            endif
          endif

          if(c.eq.''''.and.(i.ne.6.or.ifree.ne.0).and.idquote.eq.0)
     &     iquote=1-iquote
          if(c.eq.'"' .and.(i.ne.6.or.ifree.ne.0).and.iquote .eq.0)
     &     idquote=1-idquote
          if(iquote.eq.1)then
            if(FindInclude.and.iembed.ne.0)then
              iquote=0
              idquote=0
            endif
          endif
          if(iquote.ne.0.or.idquote.ne.0)c=' '
          if(j.gt.1)then                        ! (kill multiple spaces,
                                                !  and spaces around =)
            c2=a(j-1:j-1)
            if(c.eq.' '.and.c2.eq.' ')j=j-1
            if(c.eq.'='.and.c2.eq.' ')j=j-1
            if(c.eq.' '.and.c2.eq.'=')j=j-1
            if(c.eq.' '.and.c2.eq.'=')c='='
          endif
                                                ! Look for
                                                ! identifiers that wrap
                                                ! around lines.
          if((i.gt.6.or.ifree.ne.0).and.c.ne.' '.and.c.ne.'&')then
            iAlphaNum=0
            if((c.ge.'a'.and.c.le.'z').or.
     &       (c.ge.'0'.and.c.le.'9'))then
              iAlphaNum=1
              if(iContinue.eq.1)then
                if(iOldAlphaNum.ne.0)then
                  PRINT*,'***POSSIBLE SPLIT IDENTIFIER across line',form
                  print*,char(7)
                endif
              endif
            endif
            iContinue=2
          endif

          if(j.le.160) a(j:j)=c
          j=j+1
        enddo

15      i2=i1
        i3=i1
        i4=0
        igoto=0                                 ! no goto on line
        Main1=0                                 ! (Not mainline)
                                                ! Possible mainline start

16      AfterSemi=' '                           ! Break line at semicolons
        if(find(a,';',0,160-1))then
          AfterSemi='      '//a(icol:160)
          a=a(1:icol1-1)
        endif

        if(a.ne.' '.and.InSub.eq.0.and.InMod.eq.0)Main1=1
                                                ! Mark various types of jump
        if(find(a,'go to',8+64,0).or.find(a,'goto',8+64,0).or.
     &     find(a,'end=',16,0)   .or.find(a,'err=',16,0)  .or.
     &     find(a,'return',8+64,0).or.find(a,'cycle ',8,0).or.
     &     find(a,'exit ',8,0)   .or.find(a,'stop ',8,0))
     &   igoto=1

        if(find(a,')1',64,0).or.find(a,')2',64,0).or.
     &     find(a,')3',64,0).or.find(a,')4',64,0).or.
     &     find(a,')5',64,0).or.find(a,')6',64,0).or.
     &     find(a,')7',64,0).or.find(a,')8',64,0).or.
     &     find(a,')9',64,0))
     &   igoto=1

        if(find(a,') 1',64,0).or.find(a,') 2',64,0).or.
     &     find(a,') 3',64,0).or.find(a,') 4',64,0).or.
     &     find(a,') 5',64,0).or.find(a,') 6',64,0).or.
     &     find(a,') 7',64,0).or.find(a,') 8',64,0).or.
     &     find(a,') 9',64,0))
     &   igoto=1

        if(find(a,'::',0,0))then              ! To distinguish
          iDeclare=iCol                         !  declarations from
                                                !  keywords
        else
          iDeclare=999
        endif

        if(find(a,'include ''',2,0).and.iembed.ne.0)then
          filnam=a(iCol:160)
          if(.not.find(filnam,'''',0,0))goto 20
          filnam(iCol-1:80)=' '
          if(fout)print*,'including file ',filnam(1:50)
          close(3)
          open(3,file=filnam,status='old',err=17)
          iunit=3
          nlinesave=nline
          nline=0
          i2=i2+1
          i3=i3+1
          goto 20
17        PRINT*,'***WARNING--Missing include file***'
          print*,char(7)
        elseif(find(a,'end module ',2,0).or.
     &         find(a,'endmodule ',2,0).or.
     &         find(a,'end interface',2,0).or.
     &         find(a,'endinterface',2,0).or.
     &         find(a,'end type ',2,0).or.
     &         find(a,'endtype ',2,0))then
          i3=i3-1
          InMod=InMod-1
          if(find(a,'endmodule ',2,0).or.
     &       find(a,'end module ',2,0))then
            InMod=0
            if(InSub.gt.0.or.i3.ne.0)then
              PRINT*,'***ERROR--INVALID DIAGRAMMING INDEX line',form
              if(fout)WRITE(2,*)
     &         '***ERROR--INVALID DIAGRAMMING INDEX!***'
              print*,char(7)
            endif
          endif
          InElse=0
        elseif(find(a,'enddo ',256,0).or.
     &         find(a,'end do  ',256,0))then
          i3=i3-1
          nlabel=max(0,nlabel-1)
          InElse=0
        elseif(find(a,'endif  ',256,0).or.
     &         find(a,'end if  ',256,0).or.
     &         find(a,'endselect ',256,0).or.
     &         find(a,'end select ',256,0).or.
     &         find(a,'endforall ',256,0).or.
     &         find(a,'end forall ',256,0).or.
     &         find(a,'endforall ',256,0).or.
     &         find(a,'end where ',256,0))then
          i3=i3-1
          InElse=0
        elseif(find(a,'end  ',256,0).or.
     &         find(a,'end function ',256,0).or.
     &         find(a,'endfunction ',256,0).or.
     &         find(a,'end subroutine ',256,0).or.
     &         find(a,'endsubroutine ',256,0).or.
     &         find(a,'end program ',256,0).or.
     &         find(a,'endprogram ',256,0).or.
     &         find(a,'end block',256,0).or.
     &         find(a,'endblock',256,0))then
          i3=i3-1
          InSub=InSub-1
          if(InSub.lt.0.or.(InSub.gt.0.and.InMod.le.0))then
            PRINT*,'***ERROR--INVALID DIAGRAMMING INDEX line',form
            if(fout)WRITE(2,*)'***ERROR--INVALID DIAGRAMMING INDEX!***'
            print*,char(7)
          endif
          if(i3.eq.0)InSub=0
          InElse=0
        elseif(find(a,'elseif',128+256,0).or.
     &         find(a,'else if',128+256,0))then
          i4=max(i4,1)
          InElse=0
          if(.not.find(a,'then  ',8,0))InElse=1
        elseif(find(a,'then  ',8,0))then
          i2=i2+1
          if(InElse.eq.0)i3=i3+1
          InElse=0
        elseif( find(a,'selectcase',256,0).or.
     &          find(a,'select case',256,0))then
          i2=i2+1
          i3=i3+1
          i4=max(i4,1)
          InElse=0
        elseif(find(a,'else  ',256,0).or.
     &         find(a,'entry ',4,0).or.
     &         find(a,'case ',256,0).or.
     &         find(a,'case(',256,0).or.
     &         find(a,'contains ',2,0).or.
     &         find(a,'elsewhere  ',256,0).or.
     &         find(a,'else where  ',256,0))then
          i4=max(i4,1)
          InElse=0
          if(find(a,'contains ',2,0))then
            if(fout)print*,'Line ',form,' ',b(1:LenA(b))
            InMod=InMod+1
          endif
        elseif( find(a,'selectcase',256,0).or.
     &          find(a,'select case',256,0).or.
     &          find(a,'for all (',256,0).or.
     &          find(a,'forall (',256,0).or.
     &          find(a,'for all(',256,0).or.
     &          find(a,'forall(',256,0).or.
     &          find(a,'where (',256,0).or.
     &          find(a,'where(',256,0))then
          i2=i2+1
          i3=i3+1
          InElse=0
        elseif(find(a,'module ',2,iDeclare).or.
     &         find(a,'interface ',2,iDeclare).or.
     &        (find(a,'type ',2,iDeclare).and.
     &        .not.find(a,'(',0,iDeclare)))then
          if(fout)print*,'Line ',form,' ',b(1:LenA(b))
          i2=i2+1
          i3=i3+1
          Main1=0
          if(find(a,'module ',2,iDeclare).and.InMod.ne.0)then
            PRINT*,'***ERROR--NESTED MODULES***'
            if(fout)WRITE(2,*)'***NESTED MODULES***'
            print*,char(7)
          endif
          InMod=InMod+1
          InElse=0
        elseif(find(a,'do while',128+256,0).or.
     &         find(a,'dowhile',128+256,0))then
          i2=i2+1
          i3=i3+1
          nlabel=min(100,nlabel+1)
          label(nlabel)='####'
          InElse=0
        elseif(find(a,' do ',256,0).or.
     &   (ifree.ne.0.and.a(1:3).eq.'do '))then
         if(ifree.ne.0.and.a(1:3).eq.'do ')iCol=4
          if(iCol1.lt.7.or.a(7:max(7,iCol1)).eq.' '.or.
     &     (ifree.ne.0.and.a(1:3).eq.'do '))then
            i2=i2+1
            i3=i3+1
            iCol2=iCol
            dowhile(iCol2.lt.160.and.a(iCol2:iCol2).ge.'0'.and.
     &       a(iCol2:iCol2).le.'9')
              iCol2=iCol2+1
            enddo
            iCol2=iCol2-1
            nlabel=min(100,nlabel+1)
            if(iCol2.ge.iCol)then
              label(nlabel)=a(iCol:iCol2)
            else
              label(nlabel)='####'
            endif
          endif
          InElse=0
        elseif(find(a,': do ',0,0).or.find(a,':do ',0,0))then
          i2=i2+1
          i3=i3+1
          InElse=0
        elseif(find(a,'function ',4,iDeclare).or.
     &         find(a,'subroutine ',4,iDeclare).or.
     &         find(a,'program ',2,iDeclare) .or.
     &         find(a,'block data ',2,iDeclare).or.
     &         find(a,'blockdata ',2,iDeclare))then
          if(fout)print*,'Line ',form,' ',b(1:LenA(b))
          if(InSub.ne.0.and.InMod.eq.0)then
            PRINT*,'***ERROR--ROUTINE INSIDE ROUTINE***'
            if(fout)WRITE(2,*)'***ERROR--ROUTINE INSIDE ROUTINE***'
            print*,char(7)
          endif
          Main1=0
          InSub=InSub+1
          i2=i2+1
          i3=i3+1
          if(InSub.eq.1.and.i3.ne.1.and.InMod.le.0)then
            PRINT*,'***ERROR--INVALID DIAGRAMMING INDEX line',form
            if(fout)
     &       WRITE(2,*)'***ERROR--INVALID DIAGRAMMING INDEX!***'
            print*,char(7)
            i3=1
          endif
          InElse=0
        endif

20      if(Main1.ne.0)then                      ! Was start of mainline
          if(fout)print*,'Line ',form,' ',b(1:LenA(b))
          if(nMain.gt.0)then
            PRINT*,'***ERROR--TOO MANY MAINLINES***'
            if(fout)WRITE(2,*)'***ERROR--TOO MANY MAINLINES!***'
            print*,char(7)
          endif
          InSub=InSub+1
          nMain=nMain+1
          i2=i2+1
          i3=i3+1
        endif

21      if(b(1:5).ne.' '.or.ifree.ne.0)then     ! Search for DO labels
          iend=1
          dowhile(iend.lt.160.and.(b(iend:iend).eq.' '.or.
     &     (b(iend:iend).ge.'0'.and.b(iend:iend).le.'9')))
            iend=iend+1
          enddo
          iend=iend-1
          if(iend.ge.1.and.b(1:max(1,iend)).ne.' ')then
            do i=1,nlabel
              j=nlabel+1-i                      !  (in reverse order)
              if(find(b(1:iend),label(j)(1:LenA(label(j))),1,0))then
                i3=i3-1
                nlabel=max(0,j-1)
                goto 21
              endif
            enddo
          endif
        endif

        if(AfterSemi.ne.' ')then
          a=AfterSemi
          goto 16
        endif

        a=' '
        if(i1.lt.0.or.i2.lt.0.or.i3.lt.0.or.i4.lt.0)then
          PRINT*,'***ERROR--INVALID DIAGRAMMING INDEX line',form
          if(fout)WRITE(2,*)'***ERROR--INVALID DIAGRAMMING INDEX!***'
          print*,char(7)
          i1=max(i1,0)
          i2=max(i2,0)
          i3=max(i3,0)
          i4=max(i4,0)
        endif

        i2=max(i1,i3)                           ! # of nests on current line
        i4=max(i4,iabs(i3-i1))                  ! not 0, to flag start or
                                                !  end of block

        iBlock=1                                ! For the present version.

        a=' '                                   ! Leave space for diagram
        a(12:160)=b                             !  (must match column header)

        LastUse=1                               ! Last usable diagram col
        dowhile(LastUse.lt.160.and.a(LastUse:LastUse).eq.' ')
          LastUse=LastUse+1
        enddo
        LastUse=LastUse-2

        if(igoto.ne.0)a(1:1)='*'                ! Place * next to jumps

        if(i2.gt.0)then                         ! Draw one vertical line per
          do i=2,min(i2+1,LastUse)              !  nest level.
            a(i:i)=BlockContinue(iBlock)
          enddo
        endif

        if(i4.ne.0)then                         ! Draw horizontal lines inward
          do i=i2+2,LastUse                     !  from above.
            a(i:i)=BlockHoriz(iBlock)
          enddo
        endif

        do i=0,i4-1                             ! May need to replace some
                                                !  vertical lines with
          c=              BlockElse(iBlock)     !       else  symbol
          if(i1+i.lt.i3)c=BlockBegin(iBlock)    !  or   begin symbol
          if(i1+i.gt.i3)c=BlockEnd   (iBlock)   !  or   end   symbol
          j=max(2,min(LastUse,i2+1-i))
          a(j:j)=c
          if(a(j+1:j+1).eq.BlockElse  (iBlock)) ! Continue horizontal lines
     &       a(j+1:j+1)  = BlockElseH (iBlock)
          if(a(j+1:j+1).eq.BlockBegin (iBlock))
     &       a(j+1:j+1)  = BlockBeginH(iBlock)
          if(a(j+1:j+1).eq.BlockEnd   (iBlock))
     &       a(j+1:j+1)  = BlockEndH  (iBlock)
        enddo

        if(LCol.gt.0.and.a(max(1,LCol+8):160).eq.' ')then       ! line #
          if(form(1:1).eq.' ')form(1:1)=BlockContinue(iBlock)
          a(LCol+8:160)=form
        endif

        n=LenA(a)                               ! Output diagrammed line
        if(fout)     write(2,'(80a1,80a1)')(a(i:i),i=1,n)
        if(.not.fout)write(*,'(1x,80a1,80a1)')(a(i:i),i=1,n)

        i1=i3
        goto 10
99      if(iunit.eq.3)then
          iunit=1
          i1=i1-1
          close(3)
          nline=nlinesave
          goto 10
        endif
        if(i3.gt.0.or.InSub.ne.0)then
          PRINT*,'***WARNING--SOME NEST LEVELS LEFT HANGING AT END***'
          print*,char(7)
        endif
        end
c-----------------------------------------------------------------------
        logical function find(a,b,icond,jcol)   ! find b in a, subject
                                                !  to conditions:
                                                ! Colunn is prior to jcol
                                                !  (if jcol.ne.0)
                                                ! icond=sum of the
                                                !  following:
                                                ! 1:  Prior, if exists, must
                                                !     be blank
                                                ! 2:  Must be first non-blank
                                                ! 4:  Prior character, if
                                                !  present, must not be
                                                !  alphanumeric.
                                                ! 8:  Prior character, if
                                                !  present, must be blank
                                                !  or )
                                                ! 16: Prior character, if
                                                !  present, must be blank
                                                !  or ,
                                                ! 32: Next character not
                                                !  alphanumeric
                                                ! 64: Next character not
                                                !  alphabetic
                                                ! 128:Next character must
                                                !  be blank or (
                                                ! 256:1st non-blank,
                                                !  possibly except for
                                                !  numeric labels
                                                ! 512  Prior character, if present,
                                                !      must be blank or ) or }
                                                !      or { or ;
c Program by Mitchell R Grunes, ATSC/NRL (grunes@nrlvax.nrl.navy.mil).
c Revision date: 9/29/95.
        character*(*) a,b
        character*1   c,cNext,c2
        common iCol,iCol1
        logical result

        ii=len(a)
        jj=len(b)
        result=.false.
        jjcol=999
        if(jcol.gt.0)jjcol=jcol
        do i=1,min(ii-jj+1,jjcol)
          if(a(i:i+jj-1).eq.b)then              ! Found--Now do tests
            iCol1=i                             ! iCol1=column of item
                                                !  found
            iCol =i+jj                          ! iCol =colomn after
                                                !  item found

            c=' '
            cNext=' '
            if(iCol1.gt.1)c=a(iCol1-1:iCol1-1)
            if(iCol .le.ii)cNext=a(iCol:iCol)

            result=.true.
            if(result.and.iand(icond,1).ne.0.and.icol1.gt.1)then
              result=c.eq.' '
            endif

            if(result.and.iand(icond,2).ne.0.and.iCol1.gt.1)then
              result=a(1:iCol1-1).eq.' '
            endif

            if(result.and.iand(icond,4).ne.0)
     &       result=(c.lt.'0'.or.c.gt.'9').and.(c.lt.'a'.or.c.gt.'z')
            if(result.and.iand(icond,8).ne.0)result=c.eq.' '.or.c.eq.')'

            if(result.and.iand(icond,16).ne.0)
     &       result=c.eq.' '.or.c.eq.','

            if(result.and.iand(icond,32).ne.0)
     &       result=(cNext.lt.'0'.or.cNext.gt.'9').and.
     &              (cNext.lt.'a'.or.cNext.gt.'z')

            if(result.and.iand(icond,64).ne.0)
     &       result=(cNext.lt.'a'.or.cNext.gt.'z')

            if(result.and.iand(icond,128).ne.0)
     &       result=cNext.eq.' '.or.cNext.eq.'('

            if(result.and.iand(icond,256).ne.0.and.iCol1.gt.1)then
              do iii=1,iCol1-1
                c2=a(iii:iii)
                if((c2.lt.'0'.or.c2.gt.'9').and.c2.ne.' ')result=.false.
              enddo
            endif

            if(result.and.iand(icond,512).ne.0)result=c.eq.' '
     &       .or.c.eq.';'.or.c.eq.')'.or.c.eq.'{'.or.c.eq.'}'

            find=result
            if(result)return
          endif
        enddo
        find=result
        end
c-----------------------------------------------------------------------
        function LenA(a)                        ! Length of string, at
                                                !  least 1
c Program by Mitchell R Grunes, ATSC/NRL (grunes@nrlvax.nrl.navy.mil).
c Revision date: 9/29/95.
        character*(*) a
        n=len(a)
        dowhile(n.gt.1.and.a(n:n).eq.' ')
          n=n-1
        enddo
        LenA=n
        end
---diagramf.bat--------------CUT HERE-----------------------------
rem procedure to diagram a (card format) FORTRAN language program
rem (use diagram9.bat to diagram free format Fortran programs)

rem  by Mitchell R Grunes.

rem I assume that the executable is in directory c:\grunes on
rem  your PC.

rem Syntax:
rem     diagramf
rem to be prompted for input parameters.

rem Alternate Syntax:
rem     diagramf filename(s)
rem to append diagram of file(s) into diagram.out

if %1a == a  c:\grunes\diagramf
if %1a == a  goto quit

echo off
:loop

  echo ========================-- %1 --========================
  rem Prompt answers: input from %1, output to diagram2.sc (for now),
  rem  place numbers in column 73, embed include files, don't use free
  rem  format, use IBM PC graphics.

  echo %1          >  diagram.sc
  echo diagram2.sc >> diagram.sc
  echo 73          >> diagram.sc
  echo 1           >> diagram.sc
  echo 0           >> diagram.sc
  echo 1           >> diagram.sc
  c:\grunes\diagramf < diagram.sc
  type diagram2.sc >> diagram.out
  del diagram.sc
  del diagram2.sc
  shift
  if not %1a == a goto loop

:quit
---diagram9.bat--------------CUT HERE-----------------------------
rem procedure to diagram a (free format) FORTRAN language program
rem (use diagramf.bat to diagram card format Fortran programs)

rem  by Mitchell R Grunes.

rem I assume that the executable is in directory c:\grunes on
rem  your PC.

rem Syntax:
rem     diagramf
rem to be prompted for input parameters.

rem Alternate Syntax:
rem     diagramf filename(s)
rem to append diagram of file(s) into diagram.out

if %1a == a  c:\grunes\diagramf
if %1a == a  goto quit

echo off
:loop

  echo ========================-- %1 --========================
  rem Prompt answers: input from %1, output to diagram2.sc (for now),
  rem  place numbers in column 73, embed include files, don't use free
  rem  format, use IBM PC graphics.

  echo %1          >  diagram.sc
  echo diagram2.sc >> diagram.sc
  echo 73          >> diagram.sc
  echo 1           >> diagram.sc
  echo 1           >> diagram.sc
  echo 1           >> diagram.sc
  c:\grunes\diagramf < diagram.sc
  type diagram2.sc >> diagram.out
  del diagram.sc
  del diagram2.sc
  shift
  if not %1a == a goto loop

:quit
-----------------------------CUT HERE-----------------------------
-------------------------------------------------------------------------
Mitchell R Grunes, grunes@nrlvax.nrl.navy.mil.  Opinions are mine alone.



