home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / eispack-1.0-src.tgz / tar.out / contrib / eispack / ex / stript.f < prev    next >
Text File  |  1996-09-28  |  3KB  |  134 lines
  1. c
  2. c     this program will strip off subroutines and functions
  3. c     from a sequencial file. 
  4. c     this program will create files with the names of the 
  5. c     subprograms as the file names. 
  6. c     uses fortran 77 (works fine on unix)
  7. c
  8. c     comments should be directed to:
  9. c
  10. c        jack dongarra
  11. c        mathematics and computer science division
  12. c        argonne national laboratory
  13. c        argonne, illinois 60439
  14. c
  15. c        phone: 312-972-7246
  16. c        arpanet: dongarra@anl-mcs
  17. c
  18.       integer istat
  19.       character line*80,blank*1,parn*1,endu*3,endl*3
  20.       character funl*8,funu*8,sl*1,su*1
  21.       character name*20,for*9
  22. c
  23.       character*16 names,filen
  24. c
  25.       name = 'usr:main.f          '
  26.       for = '.f       '
  27.       sl = 's'
  28.       su = 'S'
  29.       funl = 'function'
  30.       funu = 'FUNCTION'
  31.       endl = 'end'
  32.       endu = 'END'
  33.       parn = '('
  34.       blank = ' '
  35.       write(6,6969)
  36.  6969 format(' input the file name')
  37.       read(5,6968) filen
  38.  6968 format(a)
  39.       open(unit=9,file=filen,iostat=istat)
  40.       write(6,*)' file open name=',filen
  41.       if( istat .ne. 0 ) write(6,10) istat
  42.    10 format(' error from call to file on unit 9 ',i4)
  43.       rewind 9
  44.       go to 3000
  45.    30 continue
  46.       read(9,40,end=999)(line(i:i),i=1,80)
  47.    40 format(80a1)
  48. c      write(6,41)(line(i:i),i=1,80)
  49. c   41 format(' **',80a1)
  50.       do 45 ib = 1,80
  51.          j = 80 - ib + 1
  52.          if( line(j:j) .ne. blank ) go to 46
  53.    45 continue
  54.    46 continue
  55.       j = j + 1
  56.       write(4,40)(line(i:i),i=1,j)
  57.       if( line(10:10) .ne. blank ) go to 30
  58.       if( line(7:7) .ne. endl(1:1) .and. 
  59.      $    line(7:7) .ne. endu(1:1) ) go to 30
  60.       if( line(8:8) .ne. endl(2:2) .and. 
  61.      $    line(8:8) .ne. endu(2:2) ) go to 30
  62.       if( line(9:9) .ne. endl(3:3) .and. 
  63.      $    line(9:9) .ne. endu(3:3) ) go to 30
  64.       close(unit=4)
  65.  3000 continue
  66.       read(9,40,end=999)(line(i:i),i=1,80)
  67. c
  68. c      check if subroutine
  69. c
  70.       if( line(7:7) .ne. sl .and. line(7:7) .ne. su ) go to 1111
  71.       i1 = 18
  72.       i2 = 23
  73.       go to 49
  74. c
  75. c     look for a function
  76. c
  77.  1111 continue
  78.       iscan = 7
  79.       do 374 k = 1,8
  80.          last = 62 + k
  81.          do 372 i = iscan,last
  82.             iscan = i + 1
  83.             if( line(i:i) .eq. funl(k:k) .or. line(i:i) .eq. funu(k:k) ) 
  84.      $            go to 374
  85.   372    continue
  86. c         write(6,373)(line(i:i),i=1,80)
  87. c  373    format(' *****error line is not a function or  sub. after end'/
  88. c     $           1x,80a1)
  89.          go to 3000
  90.   374 continue
  91.       i1 = iscan + 1
  92.       i2 = iscan + 6
  93.    49 continue
  94.       j = 4
  95.       ij = 0
  96.       do 50 i = i1,i2
  97.          j = j + 1
  98.          if( line(i:i) .eq. blank ) go to 60
  99.          if( line(i:i) .eq. parn ) go to 60
  100.          name(j:j) = line(i:i)
  101.          ij = ij + 1
  102.          names(ij:ij) = line(i:i)
  103.    50 continue
  104.       j = j + 1
  105.    60 continue
  106.       i2 = j - 1
  107.       names(ij+1:ij+2) = '.f'
  108.       ij = ij + 3
  109.       do 61 i = ij,16
  110.          names(i:i) = ' '
  111.    61 continue
  112.       do 70 i = 1,9
  113.          name(j:j) = for(i:i)
  114.          j = j + 1
  115.    70 continue
  116.       write(6,88) names
  117.    88 format(' processing ',a)
  118.       close(unit=4)
  119.       open(unit=4,file=names)
  120.       rewind 4
  121.       do 80 ib = 1,80
  122.          j = 80 - ib + 1
  123.          if( line(j:j) .ne. blank ) go to 85
  124.    80 continue
  125.    85 continue
  126.       j = j + 1
  127.       write(4,40)(line(i:i),i=1,j)
  128.       go to 30
  129.   999 continue
  130.       write(6,1000)
  131.  1000 format(' all done')
  132.       stop
  133.       end
  134.