Here is my code for using Windows API for accessing big files >>4GB. I have
now used this to substitute for most standard disk I/O.
This only works on Windows 2000 and Windows XP: earlier versions of Windows do not support files larger than 4GB and report "SetFilePointerEx does not exist in Kernel32.dll"
File "iocommon.inc":
C AREA FOR 40 OUTPUT FILES USING WINAPI ACCESS
C THIS ALLOWS US TO USE BIG FILES FOR OUTPUT
C the structure to read a file directly
C allows positioning to suit ourselves
INTEGER *4 FILECOUNT, BUFSIZE, IOS
PARAMETER (FILECOUNT=40, BUFSIZE=80)
STRUCTURE /APIFILEINFO/
C THE HANDLE GOES HERE
INTEGER*4 FILELIST
C CURRENT POINTER IN RECORD
INTEGER*4 bpointer
C BYTES READ IN
INTEGER*4 bread
C IOS FOR NEXT TIME, E.G., END-OF-FILE
INTEGER*4 NEXTIOS
C FOR RANDOM ACCESS: RECORD SIZE
INTEGER*4 RECSIZE
C READ BUFFER
CHARACTER*(BUFSIZE) buffer
END STRUCTURE
record /APIFILEINFO/ fp(FILECOUNT)
C HOLD TO CHECK VALIDITY
INTEGER*4 iocommonF, OLDFNUM
CHARACTER*8 OLDFTYPE
CHARACTER*260 iocommonP
COMMON /OVERINC/ IOS, fp, iocommonF, iocommonP, OLDFNUM, OLDFTYPE
I/O ROUTINES:
c 3.56.2 problem with file names in FULLPATH
***************************************************
*
* Various file and API routines
*
global define
include "windef.inc"
include "winuser.inc"
include "commdlg.inc"
include "winbase.inc"
include "winreg.inc"
EXTERNAL AITOCFN, ITOCFN
CHARACTER*12 AITOCFN, ITOCFN
end
***************************************************
*
* OPENREADR - open readING random
*
subroutine OPENREADR (fnumber, pathin, reclen)
c the file handle is stored in ohandle
IMPLICIT NONE
AUTOMATIC
include "iocommon.inc"
integer*4 fnumber, ohandle, reclen
CHARACTER*(*) pathin
CHARACTER*(260) pathname
integer CreateFileA ! avoids using wrapper "winbase.f"
stdcall external CreateFileA
IOS = 0
OLDFNUM = fnumber
OLDFTYPE = 'OPNREADR'
IF ((fnumber.lt.1).or.(fnumber.gt.FILECOUNT)) then
c file number out of range: programming bug
IOS = 1 !incorrect function
ELSEIF (fp(fnumber).FILELIST.NE.INVALID_HANDLE_VALUE) THEN
C THIS FILE NUMBER IS STILL OPEN
CALL WRITESUB ('OPEN FILE FOR READ RANDOM: FILE HANDLE '
+ //TRIM(AITOCFN(fnumber))//' ALREADY IN USE: '//TRIM(pathin))
IOS = 85
ELSE
pathname = trim(pathin)//char(0)
ohandle = CreateFileA(
+ val(loc(pathname)),
+ val(GENERIC_READ),
+ val(FILE_SHARE_READ.OR.FILE_SHARE_WRITE),
+ val(0),
+ val(OPEN_EXISTING),val(FILE_FLAG_RANDOM_ACCESS),
+ val(0))
C SAVE HANDLE
fp(fnumber).FILELIST = ohandle
if (ohandle == INVALID_HANDLE_VALUE) then
C ERROR RETURNS IN IOS
IOS = GetLastError()
ENDIF
c nothing in the input buffer yet. No error message waiting.
fp(fnumber).bpointer=0
fp(fnumber).bread=0
fp(fnumber).NEXTIOS = 0
fp(fnumber).buffer=' '
fp(fnumber).RECSIZE=reclen
endif
END
***************************************************
*
* CLOSEFILE
* the old CLOSEFILE IS fnumber = 40
*
subroutine CLOSEFILE (fnumber)
c the file handle is stored in
IMPLICIT NONE
AUTOMATIC
include "iocommon.inc"
integer iostat, fnumber, ohandle
IOS=0
OLDFNUM = fnumber
OLDFTYPE = 'CLOSE'
if ((fnumber.ge.0).and.(fnumber.le.FILECOUNT)) then
ohandle = fp(fnumber).FILELIST
fp(fnumber).buffer=' '
fp(fnumber).bpointer=0
fp(fnumber).bread=0
fp(fnumber).NEXTIOS = 0
if (ohandle == INVALID_HANDLE_VALUE) then
c nothing is open
else
c flag nothing in the buffer
iostat = CloseHandle(val(ohandle))
if (iostat == 0) then
IOS = GetLastError()
endif
C SHOW THAT NOTHING IS OPEN
fp(fnumber).FILELIST = INVALID_HANDLE_VALUE
endif
endif
end
***************************************************
*
* OPENWRITES (pathin, fnumber)
*
* OPEN WRITE SEQUENTIAL
*
* use 40 for old unnumbered OPENFILE
SUBROUTINE OPENWRITES (fnumber, pathin)
IMPLICIT NONE
AUTOMATIC
include "iocommon.inc"
character*(*) pathin
character*260 pathname
integer *4 fnumber, ohandle
integer CreateFileA ! avoids using wrapper "winbase.f"
stdcall external CreateFileA
C SHOW NO ERROR
IOS = 0
OLDFNUM = fnumber
OLDFTYPE = 'OPNWRITS'
IF ((fnumber.lt.1).or.(fnumber.gt.FILECOUNT)) then
c file number out of range: programming bug
IOS = 1 ! incorrect function
ELSEIF (fp(fnumber).FILELIST.NE.INVALID_HANDLE_VALUE) THEN
C THIS FILE NUMBER IS STILL OPEN
CALL WRITESUB ('OPEN FILE FOR WRITE SEQUENTIAL: FILE HANDLE '
+ //TRIM(AITOCFN(fnumber))//' ALREADY IN USE: '//TRIM(pathin))
IOS = 85
ELSE
pathname = trim(pathin)//char(0)
ohandle = CreateFileA(
+ val(loc(pathname)),
+ val(GENERIC_WRITE),
+ val(FILE_SHARE_READ.OR.FILE_SHARE_WRITE),
+ val(0),
+ val(CREATE_ALWAYS),val(FILE_FLAG_SEQUENTIAL_SCAN),
+ val(0))
if (ohandle == INVALID_HANDLE_VALUE) then
IOS = GetLastError()
ENDIF
C ERROR RETURNS IN IOS
c nothing in the input buffer yet. No error message waiting.
fp(fnumber).FILELIST = ohandle
fp(fnumber).bpointer=0
fp(fnumber).bread=0
fp(fnumber).NEXTIOS = 0
fp(fnumber).buffer=' '
ENDIF
END
***************************************************
*
* OPENREADS - SEQUENTIAL
*
subroutine OPENREADS (fnumber, pathin)
c the file handle is stored in ohandle
IMPLICIT NONE
AUTOMATIC
include "iocommon.inc"
integer*4 fnumber, ohandle
CHARACTER*(*) pathin
CHARACTER*(260) pathname
integer CreateFileA ! avoids using wrapper "winbase.f"
stdcall external CreateFileA
IOS = 0
OLDFNUM = fnumber
OLDFTYPE = 'OPNREADS'
IF ((fnumber.lt.1).or.(fnumber.gt.FILECOUNT)) then
c file number out of range: programming bug
IOS = 1 !incorrect function
ELSEIF (fp(fnumber).FILELIST.NE.INVALID_HANDLE_VALUE) THEN
C THIS FILE NUMBER IS STILL OPEN
CALL WRITESUB ('OPEN FILE FOR READ SEQUENTIAL: FILE HANDLE '
+ //TRIM(AITOCFN(fnumber))//' ALREADY IN USE: '//TRIM(pathin))
IOS = 85
ELSE
pathname = trim(pathin)//char(0)
ohandle = CreateFileA(
+ val(loc(pathname)),
+ val(GENERIC_READ),
+ val(FILE_SHARE_READ.OR.FILE_SHARE_WRITE),
+ val(0),
+ val(OPEN_EXISTING),val(FILE_FLAG_SEQUENTIAL_SCAN),
+ val(0))
C SAVE HANDLE
if (ohandle == INVALID_HANDLE_VALUE) then
C ERROR RETURNS IN IOS
IOS = GetLastError()
ENDIF
c nothing in the input buffer yet. No error message waiting.
fp(fnumber).FILELIST = ohandle
fp(fnumber).bpointer=0
fp(fnumber).bread=0
fp(fnumber).NEXTIOS = 0
fp(fnumber).buffer=' '
endif
END
***************************************************
*
* WRITEMORES - WRITING MORE SEQUENTIAL
* to output without writing an crlf MARKER
*
subroutine WRITEMORES (fnumber, wbuffer)
IMPLICIT NONE
AUTOMATIC
include "iocommon.inc"
character*(*) wbuffer
integer ohandle, fnumber
c m is the number of bytes written
integer m, iostat
C SHOW NO ERROR
IOS = 0
OLDFNUM = fnumber
OLDFTYPE = 'WRTMORES'
IF ((fnumber.lt.1).or.(fnumber.gt.FILECOUNT)) then
c file number out of range: programming bug
IOS = 1 ! incorrect function
ELSE
ohandle = fp(fnumber).FILELIST
IF (ohandle == INVALID_HANDLE_VALUE) THEN
C THIS FILE NUMBER IS not OPEN
IOS = 114
ELSE
C CHANGE TO LENGTH BUFFER - TO ALLOW INTERMEDIATE BLANKS 3.49
iostat = WriteFile(val(ohandle),val(loc(wbuffer)),
+ val(len(wbuffer)),val(loc(m)),val(0))
if (iostat == 0) then
IOS = GetLastError()
endif
endif
endif
end
***************************************************
*
* WRITES : WRITE SEQUENTIAL WITH CRLF
*
subroutine WRITES (fnumber, wbuffer)
IMPLICIT NONE
AUTOMATIC
include "iocommon.inc"
character*(*) wbuffer
integer ohandle, fnumber
integer m, iostat
C SHOW NO ERROR
IOS = 0
OLDFNUM = fnumber
OLDFTYPE = 'WRITSEQU'
IF ((fnumber.lt.1).or.(fnumber.gt.FILECOUNT)) then
c file number out of range: programming bug
IOS = 1 ! incorrect function
ELSE
ohandle = fp(fnumber).FILELIST
if (ohandle == INVALID_HANDLE_VALUE) then
IOS = 114
else
if (len_trim(wbuffer).eq.0) then
c always write out at least one blank
iostat = WriteFile(val(ohandle),val(loc(" ")),
+ val(1),val(loc(m)),val(0))
else
c else write out the value
iostat = WriteFile(val(ohandle),val(loc(wbuffer)),
+ val(len_trim(wbuffer)),val(loc(m)),val(0))
endif
if (iostat == 0) then
IOS = GetLastError()
return
endif
c value is little-endian
iostat = WriteFile(val(ohandle),val(loc(z'0a0d')),
+ val(2),val(loc(m)),val(0))
if (iostat == 0) then
IOS = GetLastError()
return
endif
endif
endif
end
***************************************************
*
SUBROUTINE REWINDFILE (fnumber)
c restart the text input file
IMPLICIT NONE
AUTOMATIC
include "iocommon.inc"
integer *4 fnumber, iostat, ohandle
integer*4 SetFilePointer
stdcall external SetFilePointer
c CALL WRITESUB ('rewindfile'//AITOCFN( fnumber))
IOS = 0
OLDFNUM = fnumber
OLDFTYPE = 'REWIND'
IF ((fnumber.lt.1).or.(fnumber.gt.FILECOUNT)) then
c file number out of range: programming bug
IOS = 1 ! incorrect function
ELSE
ohandle = fp(fnumber).FILELIST
if (ohandle == INVALID_HANDLE_VALUE) then
IOS = 114
else
iostat = SetFilePointer
+ (val(ohandle),
+ val(0),val(0),
+ val(FILE_BEGIN))
endif
endif
C NOT SURE ABOUT THE ERROR MESSAGE HERE ....
fp(fnumber).bpointer =0
fp(fnumber).bread = 0
fp(fnumber).NEXTIOS = 0
fp(fnumber).buffer = " "
END
***************************************************
*
* READS READING SEQUENTIAL WITH EOL CODES
* BYPASS EOF CODE
* 0 for datalen
subroutine READS (fnumber, data)
c datalen is number of bytes input
c data is the buffer to put them in
c if datalen=0, then we have reached end-of-file
c this never returns null records!
c the file handle is stored in
c fp(fnumber).buffer has what is left over in the buffer
c buffer(bpointer) is the next byte in the buffer to read
c buffer(bread) is the last byte in the buffer
IMPLICIT NONE
AUTOMATIC
include "iocommon.inc"
character*(*) data
integer p_buffer, datalen
EXTERNAL ITOCFN
CHARACTER*12 ITOCFN
integer iostat, lNEXTIOS
logical eoline, crlffound
integer*4 a, d, bend, fnumber, ohandle, lbread, lbpointer, bincr, datamax
CHARACTER*(BUFSIZE) lbuffer
POINTER (plbuffer,lbuffer), (plbread, lbread), (plbpointer,lbpointer)
pointer (plNEXTIOS, lNEXTIOS)
datalen=0
IOS=0
OLDFNUM = fnumber
OLDFTYPE = 'READSEQU'
datamax=len(data)
c initialize
data = ' '
crlffound = .FALSE.
C SHOW NO ERROR
IF ((fnumber.lt.1).or.(fnumber.gt.FILECOUNT)) then
c file number out of range: programming bug
IOS = 1 ! incorrect function
ELSE
ohandle = fp(fnumber).FILELIST
IF (ohandle == INVALID_HANDLE_VALUE) THEN
C THIS FILE NUMBER IS not OPEN
IOS = 114
ELSE
p_buffer = loc(fp(fnumber).buffer)
plbuffer = loc(fp(fnumber).buffer)
plbread = loc(fp(fnumber).bread)
plbpointer = loc(fp(fnumber).bpointer)
plNEXTIOS = loc(fp(fnumber).NEXTIOS)
IF (lNEXTIOS.NE.0) THEN
C READING IN A RECORD LAST TIME THAT WAS AN ERROR OR eof THIS TIME
IOS = lNEXTIOS
GOTO 100
ENDIF
eoline=.FALSE.
c loop until we hit the end-of-line
do while (.not.eoline)
if ((lbpointer.lt.1).or.
+ (lbpointer.gt.lbread)) then
c we need to readING another record into the buffer
lbuffer(1:BUFSIZE) =" "
lbread=0
lNEXTIOS=0
iostat = ReadFile(val(ohandle),val(p_buffer),
+ val(BUFSIZE), lbread,val(0))
if (iostat == 0) then
c an error was encountered: report next time?
lNEXTIOS = GetLastError()
eoline=.true.
lbpointer=0
elseif (lbread.eq.0) then
c end-of-file encountered
lNEXTIOS = -1
eoline=.true.
lbpointer=0
ENDIF
c what do we find? - if it is 0a or 0d, we are at eofline
c empty buffer from bread onwards - to clear the problem
lbpointer=1
endif
c let's look for the next 0a or 0d
c look for next line in current buffer
do while ((lbpointer.le.lbread).and.(.not.eoline))
a = index(lbuffer(lbpointer:lbread),char(10)) !LF
d = index(lbuffer(lbpointer:lbread),char(13)) !CR
if ((a.eq.0).and.(d.eq.0)) then
if (lbread.ge.lbpointer) then
if (datalen+1.le.datamax) then
data(datalen+1:) = lbuffer(lbpointer:lbread)
datalen = min(datamax, datalen + lbread - lbpointer + 1)
endif
endif
lbpointer = lbread+1
else
crlffound = .TRUE.
c we found an end of line
bincr=1
if (a.eq.0) then
bend = d
elseif (d.eq.0) then
bend = a
else
bend = min(a,d)
c 2 codes next to each other
if ((a.eq.d+1).or.(a+1.eq.d)) bincr=2
endif
c point to byte before EOL code
bend = bend + lbpointer - 2
if (bend.ge.lbpointer) then
if (datalen+1.le.datamax) then
data(datalen+1:) = lbuffer(lbpointer:bend)
datalen = min(datamax,datalen + bend - lbpointer + 1)
endif
endif
c skip an eol codes
lbpointer = bend + bincr +1
c is the next one at the start of the next record?
if ((bincr.eq.1).and.(lbpointer.eq.BUFSIZE+1)
+ .and.(IOS.eq.0).and.(lNEXTIOS.eq.0)) then
c readING in the next record and check the first character
c we may have overshot the butter!
c next record may start with an EOL code!
c readING it into the buffer
lbuffer(1:BUFSIZE) =" "
lbread = 0
lbpointer=0
iostat = ReadFile(val(ohandle),val(p_buffer),
+ val(BUFSIZE), lbread,val(0))
if (iostat == 0) then
c nothing was readING in
lNEXTIOS = GetLastError()
lbpointer=0
elseif (lbread.eq.0) then
lNEXTIOS = -1
lbpointer=0
elseif
+ (((lbuffer(1:1).eq.char(10)).and.(a.eq.0)) .or.
+ ((lbuffer(1:1).eq.char(13)).and.(d.eq.0))) then
c the other of a pair
c skip an eol code
lbpointer=2
else
lbpointer=1
endif
endif
eoline = .TRUE.
endif
enddo
enddo
C DID WE HAVE A LAST LINE THAT CONCLUDES WITH CHAR(26)
c if we are at the end-of-file is char(26) the last byte: DOS EOF
if (.not.crlffound) then
c last record of the file
if (datalen.gt.0) then
if (data(datalen:datalen).eq.char(26)) then
data(datalen:datalen)=' '
datalen=datalen-1
endif
endif
c nothing in the line, so end-of-file after CRLF
if (datalen.eq.0) IOS=lNEXTIOS
endif
endif
endif
100 CONTINUE
end
***************************************************
*
* OPENWRITER - OPEN WRITE RANDOM
*
subroutine OPENWRITER (fnumber, pathin, reclen)
c the file handle is stored in ohandle
IMPLICIT NONE
AUTOMATIC
include "iocommon.inc"
integer*4 fnumber, ohandle, reclen
CHARACTER*(*) pathin
CHARACTER*(260) pathname
integer CreateFileA ! avoids using wrapper "winbase.f"
stdcall external CreateFileA
IOS = 0
OLDFNUM = fnumber
OLDFTYPE = 'OPNWRITR'
IF ((fnumber.lt.1).or.(fnumber.gt.FILECOUNT)) then
c file number out of range: programming bug
IOS = 1 !incorrect function
ELSEIF (fp(fnumber).FILELIST.NE.INVALID_HANDLE_VALUE) THEN
C THIS FILE NUMBER IS STILL OPEN
CALL WRITESUB ('OPEN FILE FOR WRITE RANDOM: FILE HANDLE '
+ //TRIM(AITOCFN(fnumber))//' ALREADY IN USE: '//TRIM(pathin))
IOS = 85
ELSE
pathname = trim(pathin)//char(0)
ohandle = CreateFileA(
+ val(loc(pathname)),
+ val(GENERIC_WRITE),
+ val(FILE_SHARE_READ.OR.FILE_SHARE_WRITE),
+ val(0),
+ val(CREATE_ALWAYS),val(FILE_FLAG_RANDOM_ACCESS),
+ val(0))
if (ohandle == INVALID_HANDLE_VALUE) then
C ERROR RETURNS IN IOS
IOS = GetLastError()
ENDIF
c nothing in the input buffer yet. No error message waiting.
fp(fnumber).FILELIST = ohandle
fp(fnumber).bpointer=0
fp(fnumber).bread=0
fp(fnumber).NEXTIOS = 0
fp(fnumber).buffer=' '
fp(fnumber).RECSIZE=reclen
endif
END
***************************************************
*
* WRITER WRITING RANDOM
* to output a fixed length random record
* wbuffer - what to write
* fnumber - the file number
* rnumber - the record number
subroutine WRITER (fnumber, wbuffer, rnumber)
IMPLICIT NONE
AUTOMATIC
include "iocommon.inc"
character*(*) wbuffer
integer ohandle, fnumber
c m is the number of bytes written
integer m, iostat, rnumber, reclen, TYPE
c these are 8 bit characters
c fset(1) is the low order: fset(2) is the high order
c the computation wraps the negative!
integer*4 fset(2), fplace(2)
integer*4 SetFilePointerEx
stdcall external SetFilePointerEx
integer*4 SetFilePointer
stdcall external SetFilePointer
C SHOW NO ERROR
IOS = 0
OLDFNUM = fnumber
OLDFTYPE = 'WRITERAN'
IF ((fnumber.lt.1).or.(fnumber.gt.FILECOUNT)) then
c file number out of range: programming bug
IOS = 1 ! incorrect function
ELSE
ohandle = fp(fnumber).FILELIST
IF (ohandle == INVALID_HANDLE_VALUE) THEN
C THIS FILE NUMBER IS not OPEN
IOS = 114
ELSE
fplace(1)=0
fplace(2)=0
reclen = fp(fnumber).RECSIZE
c multiply the record length by the record number by the
CALL MULT (reclen, rnumber, fset(1),TYPE)
IF (TYPE.EQ.0) THEN
C 32-bit address
iostat = SetFilePointer
+ (val(ohandle),
+ val(fset(1)),val(0),
+ val(FILE_BEGIN))
ELSE
c produces reclen*(rnumber-1)+1 - 64 BIT ADDRESS
iostat = SetFilePointerEx
+ (val(ohandle),
+ val(fset(1)),val(fset(2)),
+ val(loc(fplace(1))),
+ val(FILE_BEGIN))
ENDIF
c
c ok don't overshoot reclen
iostat = WriteFile(val(ohandle),val(loc(wbuffer)),
+ val(reclen),val(loc(m)),val(0))
if (iostat == 0) then
IOS = GetLastError()
endif
endif
endif
end
***************************************************
*
* READR
* to input a fixed length random record
* wbuffer - where to store the readING material
* fnumber - the file number
* rnumber - the record number
*
subroutine READR (fnumber, wbuffer, rnumber)
IMPLICIT NONE
AUTOMATIC
include "iocommon.inc"
character*(*) wbuffer
integer ohandle, fnumber
c m is the number of bytes written
integer iostat, rnumber, reclen, lbread, TYPE
c these are 8 bit characters
c fset(1) is the low order: fset(2) is the high order
c the computation wraps the negative!
integer*4 fset(2), fplace(2)
integer*4 SetFilePointerEx
stdcall external SetFilePointerEx
integer*4 SetFilePointer
stdcall external SetFilePointer
c CALL WRITESUB ('readr'//AITOCFN( fnumber))
cc READ (5,'(A)') TLINE
C SHOW NO ERROR
IOS = 0
OLDFNUM = fnumber
OLDFTYPE = 'READRAND'
IF ((fnumber.lt.1).or.(fnumber.gt.FILECOUNT)) then
c file number out of range: programming bug
IOS = 1 ! incorrect function
ELSE
ohandle = fp(fnumber).FILELIST
IF (ohandle == INVALID_HANDLE_VALUE) THEN
C THIS FILE NUMBER IS not OPEN
IOS = 114
ELSE
C CHANGE TO LENGTH BUFFER - TO ALLOW INTERMEDIATE BLANKS 3.49
c ok - position correctly
c we have trouble incrementing
c fset(1)=0
c fset(2)=0
fplace(1)=0
fplace(2)=0
reclen = fp(fnumber).RECSIZE
c multiply the record length by the record number by the
CALL MULT (reclen, rnumber, fset(1), TYPE)
IF (TYPE.EQ.0) THEN
C 32-bit address: maintains compatibility with Windowss-98
iostat = SetFilePointer
+ (val(ohandle),
+ val(fset(1)),val(0),
+ val(FILE_BEGIN))
ELSE
c produces reclen*(rnumber-1)+1
iostat = SetFilePointerEx
+ (val(ohandle),
+ val(fset(1)),val(fset(2)),
+ val(loc(fplace(1))),
+ val(FILE_BEGIN))
ENDIF
c ok don't overshoot reclen
iostat = ReadFile(val(ohandle),val(loc(wbuffer)),
+ val(reclen), lbread, val(0))
if (iostat == 0) then
IOS = GetLastError()
endif
endif
endif
end
*************************************************************************
*
* MULT 32 x 32 to 64
*
c produces reclen*(rnumber-1)+1
c Y32-1 z32-1
SUBROUTINE MULT (Y32,Z32, X64, TYPE)
IMPLICIT NONE
AUTOMATIC
C THIS MULTIPLES TWO 32-BITS INTO A 64-BIT
INTEGER*4 X64(2), Y32, Z32
C THE INPUT VALUES
INTEGER*4 Z1, Y1
C INTEGER*32 BIT32
CHARACTER*4 Z1C, Y1C
EQUIVALENCE (Z1C, Z1)
EQUIVALENCE (Y1C, Y1)
C THE OUTPUT VALUES
INTEGER*4 H(2), TYPE
CHARACTER*8 H64
EQUIVALENCE (H(1), H64)
C INTERMEDIATE VALUES
INTEGER*4 W1, W2, W3, W4
CHARACTER*4 W1C, W2C, W3C, W4C
EQUIVALENCE (W1C, W1)
EQUIVALENCE (W2C, W2)
EQUIVALENCE (W3C, W3)
EQUIVALENCE (W4C, W4)
c STDCALL EXTERNAL UInt32x32To64
c INTEGER*4 UInt32x32To64
C POINTERS
INTEGER*4 I1, I2, I3, I11,I12
INTEGER*4 MAX32
PARAMETER (MAX32 = 2147483647)
C WHEN WE FIND OUT HOW TO ACTION THIS!
c INTEGER*4 LONGLONG(2)
c LONGLONG(1) = UInt32x32To64 (val(Y),val(Z))
C TRANSFER INPUT VALUES
Y1=Y32
c subtract 1 from the record number
Z1=Z32-1
C INITIALIZE THE FIELDS
C CAN WE DO A 32-BIT OPERATION?
W1 = MAX32 / Y1
IF (Z1.LE.W1) THEN
C WE CAN DO 32-BIT MULTIPLICATION!
X64(1)=Y1*Z1
TYPE = 0
C THIS IS A 32-BIT ADDRESS: FOR WINDOWS-98
RETURN
ENDIF
C FOR 64 BIT MULTIPLICATION
TYPE = 1
H(1)=0
H(2)=0
W1=0
W2=0
c the first byte is byte 0
W3=0
W4=0
C OK THE MULTIPLICATION IS IN 8 BIT ARITHMETIC
C GO DOWN IN SUMMING PAIRS
c start by adding 1
DO 1 I1 = 2, 8
I11 = MAX(1,I1-4)
I12 = MIN(4,I1-1)
DO 2 I2 = I11,I12
I3 = I1-I2
C GO DOWN Y FIELD
W1C(1:1) = Y1C(I2:I2)
C GO DOWN Z FIELD
W2C(1:1) = Z1C(I3:I3)
C MULTIPLY - W3 NO HAS 16 BITS ACTIVE
W3 = W3 + W1 * W2
2 CONTINUE
C TRANSFER TO THE 64 BIT VALUE
IF (W3.GT.0) THEN
H64(I1-1:I1-1) = W3C(1:1)
C FOR WHAT CARRIES OVER
W4C(1:3) = W3C(2:4)
W3 = W4
ENDIF
1 CONTINUE
X64(1)=H(1)
X64(2)=H(2)
END
***************************************************
*
* OPENREADWR - open read-write random
*
subroutine OPENREADWR (fnumber, pathin, reclen)
c the file handle is stored in ohandle
IMPLICIT NONE
AUTOMATIC
include "iocommon.inc"
integer*4 fnumber, ohandle, reclen
CHARACTER*(*) pathin
CHARACTER*(260) pathname
integer CreateFileA ! avoids using wrapper "winbase.f"
stdcall external CreateFileA
IOS = 0
OLDFNUM = fnumber
OLDFTYPE = 'OPENRDWR'
IF ((fnumber.lt.1).or.(fnumber.gt.FILECOUNT)) then
c file number out of range: programming bug
IOS = 1 !incorrect function
ELSEIF (fp(fnumber).FILELIST.NE.INVALID_HANDLE_VALUE) THEN
C THIS FILE NUMBER IS STILL OPEN
CALL WRITESUB ('OPEN FILE FOR READ-WRITE RANDOM: FILE HANDLE '
+ //TRIM(AITOCFN(fnumber))//' ALREADY IN USE: '//TRIM(pathin))
IOS = 85
ELSE
pathname = trim(pathin)//char(0)
ohandle = CreateFileA(
+ val(loc(pathname)),
+ val((GENERIC_READ).or.(GENERIC_WRITE)),
+ val(FILE_SHARE_READ.OR.FILE_SHARE_WRITE),
+ val(0),
+ val(OPEN_ALWAYS),val(FILE_FLAG_RANDOM_ACCESS),
+ val(0))
C SAVE HANDLE
fp(fnumber).FILELIST = ohandle
if (ohandle == INVALID_HANDLE_VALUE) then
C ERROR RETURNS IN IOS
IOS = GetLastError()
ENDIF
c nothing in the input buffer yet. No error message waiting.
fp(fnumber).bpointer=0
fp(fnumber).bread=0
fp(fnumber).NEXTIOS = 0
fp(fnumber).buffer=' '
fp(fnumber).RECSIZE=reclen
endif
END
***************************************************
*
* OPENWRITESA (pathin, fnumber)
*
* OPEN WRITE SEQUENTIAL APPEND
*
SUBROUTINE OPENWRITESA (fnumber, pathin)
IMPLICIT NONE
AUTOMATIC
include "iocommon.inc"
character*(*) pathin
character*260 pathname
integer *4 fnumber, ohandle, iostat
integer CreateFileA ! avoids using wrapper "winbase.f"
stdcall external CreateFileA
integer*4 SetFilePointer
stdcall external SetFilePointer
C SHOW NO ERROR
IOS = 0
OLDFNUM = fnumber
OLDFTYPE = 'OPENWRSA'
IF ((fnumber.lt.1).or.(fnumber.gt.FILECOUNT)) then
c file number out of range: programming bug
IOS = 1 ! incorrect function
ELSEIF (fp(fnumber).FILELIST.NE.INVALID_HANDLE_VALUE) THEN
C THIS FILE NUMBER IS STILL OPEN
CALL WRITESUB ('OPEN FILE FOR READ SEQUENTIAL APPEND: FILE HANDLE '
+ //TRIM(AITOCFN(fnumber))//' ALREADY IN USE: '//TRIM(pathin))
IOS = 85
ELSE
pathname = trim(pathin)//char(0)
ohandle = CreateFileA(
+ val(loc(pathname)),
+ val(GENERIC_WRITE),
+ val(FILE_SHARE_READ.OR.FILE_SHARE_WRITE),
+ val(0),
+ val(OPEN_ALWAYS),val(FILE_FLAG_SEQUENTIAL_SCAN),
+ val(0))
if (ohandle == INVALID_HANDLE_VALUE) then
IOS = GetLastError()
ENDIF
C ERROR RETURNS IN IOS
c nothing in the input buffer yet. No error message waiting.
fp(fnumber).FILELIST = ohandle
fp(fnumber).bpointer=0
fp(fnumber).bread=0
fp(fnumber).NEXTIOS = 0
fp(fnumber).buffer=' '
C NOW WE NEED TO POSITION AT EOF: COMPATIBLE WITH WINDOWS-98
iostat = SetFilePointer
+ (val(ohandle),
+ val(0),val(0),
+ val(FILE_END))
ENDIF
END
***************************************************
*
* DELETEFILE
*
subroutine DELETEFILE (pathin)
c the file handle is stored in
IMPLICIT NONE
AUTOMATIC
CHARACTER*(*) pathin
CHARACTER*261 pathname
integer iostat
integer DeleteFile
stdcall external DeleteFile
c CALL WRITESUB ('deletefile: '//trim(pathin))
pathname = trim(pathin)//char(0)
iostat = DeleteFile (val(loc(pathin)))
END
***************************************************
*
* INQUIREFILE - does file exist
*
LOGICAL FUNCTION INQUIREFILE (pathin)
C LOGICAL INQUIREFILE
C EXTERNAL INQUIREFILE
IMPLICIT NONE
AUTOMATIC
CHARACTER*(*) pathin
CHARACTER*261 pathname
integer iostat
c CALL WRITESUB ('INQUIREfile: '//trim(pathin))
pathname = trim(pathin)//char(0)
iostat = GetFileAttributes (val(loc(pathname)))
if (iostat.EQ.-1) THEN
INQUIREFILE = .FALSE.
ELSE
INQUIREFILE = .TRUE.
ENDIF
END
***************************************************
*
* SIZEFILE - does file exist
*
INTEGER*4 FUNCTION SIZEFILE (pathin)
C INTEGER*4 SIZEFILE
C EXTERNAL SIZEFILE
IMPLICIT NONE
AUTOMATIC
CHARACTER*(*) pathin
CHARACTER*261 pathname
integer iostat, ohandle, high
integer CreateFileA ! avoids using wrapper "winbase.f"
stdcall external CreateFileA
pathname = trim(pathin)//char(0)
C TRY TO OPENTHE FILE
ohandle = CreateFileA(
+ val(loc(pathname)),
+ val(GENERIC_READ),
+ val(FILE_SHARE_READ.OR.FILE_SHARE_WRITE),
+ val(0),
+ val(OPEN_EXISTING),val(FILE_ATTRIBUTE_NORMAL),
+ val(0))
if (ohandle == INVALID_HANDLE_VALUE) then
c show zero length
iostat = 0
else
iostat = GetFileSize (val(ohandle), val(loc(high)))
if (iostat.eq.-1) then
c probably an error
iostat = GetLastError()
if (iostat.eq.NO_ERROR) then
c non-zero size
iostat = 1
else
iostat = 0
endif
endif
c we don't want this return code to foul things up
high = CloseHandle(val(ohandle))
c iostat has a size indicator
endif
SIZEFILE = iostat
END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
c
CHARACTER*12 FUNCTION AITOCFN (IFIELD)
IMPLICIT NONE
AUTOMATIC
c SET UP THE CONVERSION AS A FUNCTION
C LEFT ADJUSTS
C EXTERNAL AITOCFN
C CHARACTER*12 AITOCFN
C AITOCFN(IFIELD)
CHARACTER*12 OFIELD
INTEGER*4 IFIELD
CALL IEDIT (IFIELD, OFIELD)
AITOCFN = ADJUSTL(OFIELD)
END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
c **
* Subroutines for internal writes which cause problems!
* THIS RIGHT-ALIGNS AN INTEGER FROM IFIELD INTO OFIELD
*
SUBROUTINE IEDIT (IFIELD, OFIELD)
IMPLICIT NONE
AUTOMATIC
C EXAMPLE
C CALL IEDIT (SC+MINSCORE,WORKP(1:6))
INTEGER*4 IFIELD, POINTER, IWORK, IHOLD, DIGIT, ISIGN
CHARACTER*(*) OFIELD
CHARACTER*10 DIGITS
REAL*8 OMAX, OMIN
C X changed to * in 2.42
DATA DIGITS/'0123456789'/
IF ((IFIELD.GT.0).AND.(LEN(OFIELD).LT.10)) THEN
C IN CASE OVERFLOW PLUS
OMAX = 10**LEN(OFIELD)
IF (IFIELD.GE.OMAX) THEN
OFIELD = REPEAT('9',LEN(OFIELD))
RETURN
ENDIF
ELSEIF ((IFIELD.LT.0).AND.(LEN(OFIELD).LT.11)) THEN
C IN CASE OVERFLOW MINUS
OMIN = -10**(LEN(OFIELD)-1)
IF (IFIELD.LE.OMIN) THEN
OFIELD = '-'//REPEAT('9',LEN(OFIELD)-1)
RETURN
ENDIF
ENDIF
OFIELD = ' '
IHOLD = ABS(IFIELD)
* NOW PICK UP THE DIGITS
DO 10 POINTER = LEN(OFIELD),1,-1
IWORK = IHOLD/10
DIGIT = IHOLD - IWORK*10 +1
OFIELD(POINTER:POINTER) = DIGITS(DIGIT:DIGIT)
IHOLD=IWORK
IF (IHOLD.EQ.0) EXIT
10 CONTINUE
IF (IFIELD.LT.0) THEN
POINTER = MAX(1, POINTER-1)
OFIELD(POINTER:POINTER) = '-'
ENDIF
END
