Liren Large Software Subsidy 10/10.iso/l/l320/2.img/EXAMPLES/BINWRITE.F

Text File | 1989-10-12 | 7.0 KB | 203 lines

c This is an example of how to write sequentially to a file
c without the bothersome 4-byte header and footer information.
c Written by David Rapier, MicroWay, Inc.
c Permission to use text and ideas in this file is granted.
c
    Program noheader

c L is the size of the buffer being used in the direct access file.
c It may be set to any number.  The larger L is, the fewer times
c the disk will be read.  The smaller L is, the less the file will
c be padded at the end (the file will be padded with blanks at the
c end).
c
    Parameter (L=512)

c The program will write three pieces of information to the file:
c a 400-byte string, a 200-byte string, and a 10-byte number.
c These are just examples -- the subroutine will handle any size
c string.
c
    character*400 A400
    character*200 A200
    character*10  A10
    Data A400 / 'This is a 400-byte piece of information.' /
    Data A200 / 'This is a 200-byte piece of information.' /

c The open statement may be on any legal unit number.
c It must include ACCESS='DIRECT' and RECL=L.
c
    open (7,file='fort.7',status='new',access='direct',recl=L)

c Writing character strings to the file is straightforward.
c Pass the number of the file (must be the same throughout)
c and the actual string to be written.
c
    Call BIN_WRITE(7,a400)
    Call BIN_WRITE(7,a200)

c To write numbers to the file, convert them first to strings.
c This can be done using an internal write statement.
c
    X = 17.0
    WRITE(A10,900) X
900    Format(F9.3)

c Then pass the resulting string variable to the subroutine.
c
    Call BIN_WRITE(7,a10)

c To finish writing the file, pass "char(0)" as an argument.
c This is necessary to flush the buffer.
c
    Call BIN_WRITE(7,char(0))
    Close (7)
    End

c---------------------------------------------------------------c
c Subroutine BIN_WRITE handles all WRITEs to the designated file.
c Input arguments:  FILENUM = Integer*4, file number.
c                   CHARSTR = Character string to be written
c
c Variables: BUFFER  = Character string buffer
c            CONNECT = Connect status to ensure FILENUM is really open.
c            FILECONST Check to ensure that FILENUM is the same
c                      throughout the program.
c            IO      = Check during write to ensure IOSTAT is okay.
c            L       = Length of buffer.  Same as in main program.
c            LENGTH  = Length of character string passed.
c            NUMBER  = Number of times this routine is called.
c            POINTER = Shows place in buffer.
c            RECORD  = Number of record presently being filled.
c            TEMP    = Temporary pointer during write.
c
c Output:    Incoming arguments are never changed.
c            Either the write will occur or program will halt.
c
    Subroutine    BIN_WRITE( FILENUM,CHARSTR )
    Parameter     (L=512)
    Integer*4     POINTER, NUMBER, LENGTH, RECORD, IO, TEMP
    Integer*4     FILENUM, FILECONST
    Character*(L) BUFFER
    Character*(*) CHARSTR
    Logical*4     CONNECT
    Data POINTER, NUMBER, RECORD, FILECONST / 0, 0, 0, 0 /
    Data BUFFER / ' ' /

c Increment number of times routine is called.  This variable is used
c in error messages to help debug the main program.
c
    NUMBER = NUMBER + 1

c Although LENGTH starts out as the length of the string, it ends
c up as the length remaining to write, if the string is larger than
c the buffer being written into.
c
    LENGTH = len(CHARSTR)

c FILENUM will differ from FILECONST in two situations.
c (1) First time the subroutine is called.
c     If FILECONST=0 this is true.  In this case,
c     FILECONST is set equal to FILENUM and the status of the
c     file number is checked.  If the file is not open, a message
c     is given and the file is properly opened, with default
c     file name.
c (2) User is trying to use subroutine for TWO files.
c     In this case, an error message is given with information to
c     help the programmer find the problem.
c
    If (FILENUM.ne.FILECONST) then
      If (FILECONST.eq.0) then
        FILECONST = FILENUM
        Inquire(FILENUM,opened=CONNECT)
        If (.not. CONNECT) then
          Print "(' *** OPENING FILE #',i4,'***')", FILENUM
          Print "(' [Call #   1 of BIN_WRITE]')"
          Open(FILENUM, Status='Direct',Recl=L)
         End if
       else
        Print "(' This subroutine is designed to allow binary')"
        Print "(' access to ONE file number only.  File number')"
        Print "(' is INCONSISTANT on call number',i4)", NUMBER
        Print "(' of BIN_WRITE.  Please change program.')"
        Print "(' File number     =',i4)", FILENUM
        Print "(' Number expected =',i4)", FILECONST
        Stop
       End if
     End if

c These lines check to ensure the file is still open.
c If the file is closed, it will be reopened using a default
c file name and a warning message will be given.
c
    inquire(FILENUM,opened=CONNECT)
    if (.NOT. CONNECT) then
      Print "(' *** REOPENING FILE #',i4,'***')", FILENUM
      Print "(' [Call #',i4,'of BIN_WRITE]')", NUMBER
      Open(FILENUM, Status='Direct',Recl=L)
     End If

c CHARSTR=char(0) will flush the buffer and prepare the file for
c closing.  All write statements check iostatus, error status.
c
    if (LENGTH.eq.1 .AND. CHARSTR.eq.char(0)) then
      BUFFER(POINTER+1:L) = ' '
      RECORD = RECORD + 1
      POINTER = 0
      Write (FILENUM, iostat=IO, err=100, rec=RECORD) BUFFER
      if (IO .ne. 0) GoTo 101
      Return
     end if

c TEMP is the amount of CHARSTR already written.
c TEMP + LENGTH will always be the length of CHARSTR.
c
    TEMP = 0

c POINTER is how much buffer is already filled.
c L-POINTER is how much buffer is left.
c If LENGTH is greater than L-POINTER, part of CHARSTR
c is read into BUFFER, BUFFER is written, and
c the comparison is made again.
c
    do 10 while (LENGTH.gt.L-POINTER)
      BUFFER(POINTER+1:L) = CHARSTR(TEMP+1:TEMP+L-POINTER)
      RECORD = RECORD + 1
      TEMP = TEMP+L-POINTER
      LENGTH = LENGTH-L+POINTER
      POINTER = 0
      Write (FILENUM, iostat=IO, err=100, rec=RECORD) BUFFER
      if (IO .ne. 0) GoTo 101
10     Continue

c By this point, the amount left in CHARSTR is either
c smaller than the buffer or the same length.
c If smaller, then the buffer is partially filled.
c If the same length, the buffer is filled and writes to disk.
c
    If (LENGTH.lt.L-POINTER) then
      BUFFER(POINTER+1:POINTER+LENGTH) = CHARSTR(TEMP+1:TEMP+LENGTH)
      POINTER = POINTER+LENGTH
     else
      BUFFER(POINTER+1:L) = CHARSTR(TEMP+1:TEMP+L-POINTER)
      POINTER = 0
      RECORD = RECORD + 1
      Write (FILENUM, iostat=IO, err=100, rec=RECORD) BUFFER
      If (IO .ne. 0) GoTo 101
     End if
    Return

c These are diagnostic lines in case any write statement
c gives an error.
c
101    Print "(' IOSTAT ERROR.  IOSTAT =',i4)",   IOSTAT
100    Print "(' Error in invocation #',i4,$)",   NUMBER
    Print "(' of WRITE to File #',i4,':')" ,   FILENUM
    Print "(' Record #',i4,', Pointer =',i4)", RECORD, POINTER
    Print "(' Length =',i4,', ',$)",           LEN(CHARSTR)
    Print "(' Remaining length =',i4)",        LENGTH
    Print "(' Buffer size =',i4,', ',$)",      L
    Print "(' TEMP =',i4)",                    TEMP
    Stop
    End