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
