home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / fortran / library / library / libry5a.doc < prev    next >
Text File  |  1989-11-10  |  7KB  |  277 lines
  1. .de
  2. .pa
  3.                      EXAMPLE USING ASCII FILE PROCEDURES
  4.  
  5.  
  6. $STORAGE:2
  7.       PROGRAM EXAMPLE1
  8. C
  9. C  IN THIS EXAMPLE ONE FILE WILL BE COPIED INTO ANOTHER
  10. C
  11.       IMPLICIT INTEGER*2 (I-N)
  12.       CHARACTER CBUF*80,INFILE*12,OUTFILE*12,ANS
  13.       DATA LINES/0/
  14. C
  15.       CALL WRTTY('EXMPL/V1.0: example using file procedures<')
  16.       CALL WRTTY(' (copying one file into another)<')
  17. C
  18. C  FETCH FILE NAMES FROM RUNTIME STRING
  19. C
  20.       CALL RRPAR(1,INFILE)
  21.       CALL RRPAR(2,OUTFILE)
  22. C
  23. C  CHECK FOR MISSING FILE NAMES
  24. C
  25.       IF(INFILE.NE.' '.AND.OUTFILE.NE.' ') GO TO 100
  26.       CALL WRTTY('missing file names... try something like<')
  27.       CALL WRTTY(' EXMPL infile outfile<')
  28.       GO TO 999
  29. C
  30. C  OPEN INFILE (NOTE: NEW='-1')
  31. C
  32.   100 CALL FOPEN1(INFILE,-1,IERR)
  33.       IF(IERR.EQ.0) GO TO 110
  34.       CALL WRTTY('unable to access infile<')
  35.       GO TO 999
  36. C
  37. C  OPEN OUTFILE, FIRST CHECK FOR ALREADY EXIST (NOTE: NEW=-1)
  38. C  IF YOU DON'T CARE TO CHECK FOR OVERWRITE JUST SET NEW=0
  39. C
  40.   110 CALL FOPEN2(OUTFILE,-1,IERR)
  41.       IF(IERR.NE.0) GO TO 120
  42.       CALL FCLOS2
  43. C
  44.   111 CALL WRTTY('outfile already exists... overwrite?(Y/N)_')
  45.       CALL READ1(ANS)
  46.       IF(ANS.EQ.'Y') GO TO 112
  47.       IF(ANS.EQ.'N') GO TO 900
  48.       CALL BEEP
  49.       CALL CLEAR1
  50.       GO TO 111
  51. C
  52.   112 CALL CLEAR1
  53.       CALL FOPEN2(OUTFILE,0,IERR)
  54.       IF(IERR.NE.0) GO TO 900
  55.       GO TO 200
  56. C
  57. C  OPEN OUTFILE, CREATE (NOTE: NEW=1)
  58. C
  59.   120 CALL FOPEN2(OUTFILE,1,IERR)
  60.       IF(IERR.EQ.0) GO TO 200
  61.       CALL WRTTY('unable to access outfile<')
  62.       GO TO 900
  63. C
  64. C  READ INFILE
  65. C
  66.   200 CALL FREAD1(CBUF,80,LREC,IERR,IEND)
  67.       IF(IERR.NE.0) GO TO 400
  68.       IF(IEND.NE.0) GO TO 300
  69.       LINES=LINES+1
  70. C
  71. C  COPY TO OUTFILE
  72. C
  73.       CALL FWRIT2(CBUF,LREC,IERR)
  74.       IF(IERR.NE.0) GO TO 500
  75.       GO TO 200
  76. C
  77. C  END OUTFILE
  78. C
  79.   300 CALL FENDF2
  80.       WRITE(CBUF,3000) LINES
  81.  3000 FORMAT('lines copied ',I5,'<')
  82.       CALL WRTTY(CBUF)
  83.       GO TO 900
  84. C
  85. C  READ ERROR
  86. C
  87.   400 WRITE(CBUF,4000) LINES
  88.  4000 FORMAT('infile read error at line ',I5,'<')
  89.       CALL WRTTY(CBUF)
  90.       GO TO 900
  91. C
  92. C  WRITE ERROR
  93. C
  94.   500 WRITE(CBUF,5000) LINES
  95.  5000 FORMAT('outfile write error at line ',I5,'<')
  96.       CALL WRTTY(CBUF)
  97. C
  98. C  CLOSE FILES
  99. C
  100.   900 CALL FCLOS2
  101.       CALL FCLOS1
  102.   999 STOP
  103.       END
  104. .pa
  105.                   EXAMPLE USING DIRECTORY SEARCH PROCEDURES
  106.  
  107.  
  108. $STORAGE:2
  109.       PROGRAM EXAMPLE2
  110. C
  111. C  IN THIS EXAMPLE THE DIRECTORY SEARCH ROUTINES WILL BE ILLUSTRATED
  112. C
  113.       IMPLICIT INTEGER*2 (I-N)
  114.       CHARACTER NAME*12,CBUF*3
  115. C
  116.   100 CALL WRTTY('<')
  117.       CALL WRTTY('enter file mask _')
  118.       CALL READC(NAME,12,IERR)
  119.       IF(IERR.NE.0) GO TO 999
  120.       IF(NBUFC1(NAME,12).EQ.0) GO TO 999
  121. C
  122. C  SET DIRECTORY SEARCH IN DOS
  123. C
  124.       NFILE=0
  125.       CALL DIRSET(NAME)
  126. C
  127. C  NO AVAILABLE FILES
  128. C
  129.       IF(NAME.EQ.' ') THEN
  130.         IF(NFILE.NE.0) GO TO 999
  131.         CALL WRTTY('Sorry, there are no files matching this mask.<')
  132.         GO TO 100
  133.       ENDIF
  134. C
  135.       CALL WRTTY('The matching files are:<')
  136.       GO TO 120
  137. C
  138. C  GET NEXT DIRECTORY ENTRY
  139. C
  140.   110 CALL DIRNXT(NAME)
  141.       IF(NAME.EQ.' ') GO TO 100
  142. C
  143. C  LIST FILE NAME
  144. C
  145.   120 NFILE=NFILE+1
  146.       WRITE(CBUF,'(I3)') NFILE
  147.       CALL WRTTY(CBUF//'  '//NAME//'<')
  148.       GO TO 110
  149. C
  150.   999 STOP
  151.       END
  152. .pa
  153.                      EXAMPLE USING BINARY FILE PROCEDURES
  154.  
  155.  
  156. $STORAGE:2
  157.       PROGRAM EXAMPLE3
  158. C
  159. C  the purpose of this program is to fix up a totally messed up file
  160. C
  161.       IMPLICIT INTEGER*2(I-N)
  162.       INTEGER*4 LREAD,LWRIT
  163.       PARAMETER (LBUF=4096)
  164.       CHARACTER CBUF(LBUF),DBUF(LBUF),C80*80
  165.       DATA JBUF,LREAD,LWRIT/3*0/
  166. C
  167.       CALL WRTTY('opening input file<')
  168.       CALL BOPEN('LOST'C,0,IHAND1,IERR)
  169.       IF(IERR.NE.0) THEN
  170.         CALL WRTTY('unable to open input file<')
  171.         GO TO 999
  172.       ENDIF
  173. C
  174.       CALL WRTTY('purging old output file<')
  175.       CALL BPURGE('FOUND'C)
  176. C
  177.       CALL WRTTY('creating new output file<')
  178.       CALL BCREAT('FOUND'C,0,IHAND2,IERR)
  179.       IF(IERR.NE.0) THEN
  180.         CALL WRTTY('unable to create new output file<')
  181.         CALL BCLOSE(IHAND1)
  182.         GO TO 999
  183.       ENDIF
  184. C
  185.   100 CALL BREAD(IHAND1,LBUF,CBUF,KBUF,IERR)
  186.       IF(IERR.NE.0) THEN
  187.         CALL WRTTY('error reading input file<')
  188.         CALL BCLOSE(IHAND1)
  189.         CALL BCLOSE(IHAND2)
  190.         GO TO 999
  191.       ENDIF
  192.       LREAD=LREAD+INT4(KBUF)
  193.       CALL CLEAR1
  194.       WRITE(C80,'(A,I8,1H_)') 'bytes read=',LREAD
  195.       CALL WRTTY(C80)
  196.       WRITE(C80,'(A,I8,1H_)') '   bytes written=',LWRIT
  197.       CALL WRTTY(C80)
  198. C
  199.       IBUF=0
  200.   110 IBUF=IBUF+1
  201.       IF(IBUF.GT.KBUF) GO TO 120
  202. C
  203.       JBUF=JBUF+1
  204.       IF(JBUF.GT.LBUF) THEN
  205.         CALL BWRITE(IHAND2,LBUF,DBUF,IERR)
  206.         IF(IERR.NE.0) THEN
  207.           CALL WRTTY('error writing output file<')
  208.           CALL BCLOSE(IHAND1)
  209.           CALL BCLOSE(IHAND2)
  210.           GO TO 999
  211.         ENDIF
  212.         LWRIT=LWRIT+INT4(LBUF)
  213.         CALL CLEAR1
  214.         WRITE(C80,'(A,I8,1H_)') 'bytes read=',LREAD
  215.         CALL WRTTY(C80)
  216.         WRITE(C80,'(A,I8,1H_)') '   bytes written=',LWRIT
  217.         CALL WRTTY(C80)
  218.         JBUF=1
  219.       ENDIF
  220. C
  221.       IF(CBUF(IBUF).EQ.CHAR(13)) THEN
  222.         DBUF(JBUF)=CBUF(IBUF)
  223.         JBUF=JBUF+1
  224.         IF(JBUF.GT.LBUF) THEN
  225.           CALL BWRITE(IHAND2,LBUF,DBUF,IERR)
  226.           IF(IERR.NE.0) THEN
  227.             CALL WRTTY('error writing output file<')
  228.             CALL BCLOSE(IHAND1)
  229.             CALL BCLOSE(IHAND2)
  230.             GO TO 999
  231.           ENDIF
  232.           LWRIT=LWRIT+INT4(LBUF)
  233.           CALL CLEAR1
  234.           WRITE(C80,'(A,I8,1H_)') 'bytes read=',LREAD
  235.           CALL WRTTY(C80)
  236.           WRITE(C80,'(A,I8,1H_)') '   bytes written=',LWRIT
  237.           CALL WRTTY(C80)
  238.           JBUF=1
  239.         ENDIF
  240.         DBUF(JBUF)=CHAR(10)
  241.       ELSE
  242.         IF(CBUF(IBUF).GE.CHAR(32).AND.CBUF(IBUF).LE.CHAR(127)) THEN
  243.           DBUF(JBUF)=CBUF(IBUF)
  244.         ELSE
  245.           DBUF(JBUF)=' '
  246.         ENDIF
  247.       ENDIF
  248.       GO TO 110
  249. C
  250.   120 IF(KBUF.EQ.LBUF) GO TO 100
  251. C
  252.       IF(JBUF.GT.0) THEN
  253.         CALL BWRITE(IHAND2,JBUF,DBUF,IERR)
  254.         IF(IERR.NE.0) THEN
  255.           CALL WRTTY('error writing output file<')
  256.           CALL BCLOSE(IHAND1)
  257.           CALL BCLOSE(IHAND2)
  258.           GO TO 999
  259.         ENDIF
  260.         LWRIT=LWRIT+INT4(JBUF)
  261.         CALL CLEAR1
  262.         WRITE(C80,'(A,I8,1H_)') 'bytes read=',LREAD
  263.         CALL WRTTY(C80)
  264.         WRITE(C80,'(A,I8,1H_)') '   bytes written=',LWRIT
  265.         CALL WRTTY(C80)
  266.       ENDIF
  267.       CALL WRTTY('<')
  268. C
  269.       CALL WRTTY('closing input file<')
  270.       CALL BCLOSE(IHAND1)
  271.       CALL WRTTY('closing output file<')
  272.       CALL BCLOSE(IHAND2)
  273. C
  274.   999 STOP
  275.       END
  276. .ee
  277.