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 / oldstript.f < prev    next >
Text File  |  1996-09-28  |  4KB  |  130 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 line(80),endu(3),endl(3),name(20),blank,parn,istat,
  19.      $          for(9),funl(8),funu(8),sl,su
  20. c
  21.       character*16 names,filen
  22.       data endl/1he,1hn,1hd/,
  23.      $     endu/1hE,1HN,1HD/,
  24.      $     blank/1h /,
  25.      $     parn/1h(/,
  26.      $     name/1hu,1hs,1hr,1h:,1hm,1ha,1hi,1hn,1h.,1hf,
  27.      $          1ho,1hr,1h ,1h ,1h ,1h ,1h ,1h ,1h ,1h /,
  28.      $     for/1h.,1hf,1h ,1h ,1h ,1h ,1h ,1h ,1h /
  29.       data funl/1hf,1hu,1hn,1hc,1ht,1hi,1ho,1hn/,
  30.      $     funu/1HF,1HU,1HN,1HC,1HT,1HI,1HO,1HN/,
  31.      $     sl/1hs/,
  32.      $     su/1hS/
  33. c
  34.       write(6,6969)
  35.  6969 format(' input the file name')
  36.       read(5,6968) filen
  37.  6968 format(a)
  38.       open(unit=9,file=filen,iostat=istat)
  39.       write(6,*)' file open name=',filen
  40.       if( istat .ne. 0 ) write(6,10) istat
  41.    10 format(' error from call to file on unit 9 ',i4)
  42.       rewind 9
  43.       go to 3000
  44.    30 continue
  45.       read(9,40,end=999)(line(i),i=1,80)
  46.    40 format(80a1)
  47. c      write(6,41)(line(i),i=1,80)
  48. c   41 format(' **',80a1)
  49.       do 45 ib = 1,80
  50.          j = 80 - ib + 1
  51.          if( line(j) .ne. blank ) go to 46
  52.    45 continue
  53.    46 continue
  54.       j = j + 1
  55.       write(4,40)(line(i),i=1,j)
  56.       IF( LINE(10) .NE. BLANK ) GO TO 30
  57.       if( line(7) .ne. endl(1) .and. line(7) .ne. endu(1) ) go to 30
  58.       if( line(8) .ne. endl(2) .and. line(8) .ne. endu(2) ) go to 30
  59.       if( line(9) .ne. endl(3) .and. line(9) .ne. endu(3) ) go to 30
  60.       close(unit=4)
  61.  3000 continue
  62.       read(9,40,end=999)(line(i),i=1,80)
  63. c
  64. c      check if subroutine
  65. c
  66.       if( line(7) .ne. sl .and. line(7) .ne. su ) go to 1111
  67.       i1 = 18
  68.       i2 = 23
  69.       go to 49
  70. c
  71. c     look for a function
  72. c
  73.  1111 continue
  74.       iscan = 7
  75.       do 374 k = 1,8
  76.          last = 62 + k
  77.          do 372 i = iscan,last
  78.             iscan = i + 1
  79.             if( line(i) .eq. funl(k) .or. line(i) .eq. funu(k) ) 
  80.      $            go to 374
  81.   372    continue
  82. c         write(6,373)(line(i),i=1,80)
  83. c  373    format(' *****error line is not a function or  sub. after end'/
  84. c     $           1x,80a1)
  85.          go to 3000
  86.   374 continue
  87.       i1 = iscan + 1
  88.       i2 = iscan + 6
  89.    49 continue
  90.       j = 4
  91.       ij = 0
  92.       do 50 i = i1,i2
  93.          j = j + 1
  94.          if( line(i) .eq. blank ) go to 60
  95.          if( line(i) .eq. parn ) go to 60
  96.          name(j) = line(i)
  97.          ij = ij + 1
  98.          names(ij:ij) = char(line(i))
  99.    50 continue
  100.       j = j + 1
  101.    60 continue
  102.       i2 = j - 1
  103.       names(ij+1:ij+2) = '.f'
  104.       ij = ij + 3
  105.       do 61 i = ij,16
  106.          names(i:i) = ' '
  107.    61 continue
  108.       do 70 i = 1,9
  109.          name(j) = for(i)
  110.          j = j + 1
  111.    70 continue
  112.       write(6,88) names
  113.    88 format(' processing ',a)
  114.       close(unit=4)
  115.       open(unit=4,file=names)
  116.       rewind 4
  117.       do 80 ib = 1,80
  118.          j = 80 - ib + 1
  119.          if( line(j) .ne. blank ) go to 85
  120.    80 continue
  121.    85 continue
  122.       j = j + 1
  123.       write(4,40)(line(i),i=1,j)
  124.       go to 30
  125.   999 continue
  126.       write(6,1000)
  127.  1000 format(' all done')
  128.       stop
  129.       end
  130.