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 / newst.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.