c+ c c BLKIO Routines -- Support for direct disk QIO into regular or virtual arrays c c Authors: Joanne Vinton & Larry Baker c Modified by: Tim MacDonald, Howard Bundock, & Gary Maxwell c c Contact: U.S. Geological Survey c National Strong Motion Data Center c 345 Middlefield Road, Mailstop 977 c Menlo Park, California 94025 c c Note: This has been designed to be a general package. For other applications, c please consider using the GETVIR routine (for virtual arrays) and your c own I/O support code to get the best possible performance. c c Although this code performs well at our installation, it has not been c tested rigorously. No warranties are expressed or implied as to the c fitness and usability of this code. The user assumes all risk from c possible errors causing program failure and/or loss of data. c c If you are creating a new file, or are extending an old file, please c note that the file must be allocated or extended explicitly (see label c 1035). When direct QIO's are used, file extension is not performed c automatically! c c You must also either declare a MAXBUF of 512 or disable Error 37 c by calling ERRSET. c c- Subroutine OPNBLK (block,kblk,kerr,fname,nrec,nbperr, 1 itype,ishare,iread,ierr) integer*2 block(53) Character fname*40 integer*2 kblk,kerr,nrec,nbperr,itype,ishare,iread,ierr c c+ c c OPNBLK -- opens a file for Block I/O. c c block - a 53 element integer*2 array. Space is c provided by the user, but OPNBLK fills it in. c kblk - the Block I/O file logical unit number c kerr - the error message logical unit number c fname - the file name the user is giving to the Block I/O file c nrec - the number of records in the file c nbperr - the number of bytes per record (multiple of 512) c itype - = -1 to extend the length of an existing file c = 0 to create a new file c = 1 to open an old file c = 2 to open 'UNKNOWN' c ishare - = 0 to open the file without 'shared' c = 1 to open the file 'shared' c iread - = 0 to open without 'readonly' c = 1 to open with 'readonly' c ierr - = 0 if no errors, 1 if open error; c if ierr = 1, then block contains the input c from the calling sequence (depending on how far c the routine got), plus a FORTRAN error number, if c the open failed: c c (block (1),kblk), c (block (2),kerr), c (block (3),0 or FORTRAN error number 29 or 43), c (block (4),number of disk blocks per record), c (block (5),pointer to most recently used IOSB in block) c (block (6-8),IOSB and in-use flag for 1st get or put), c (block (9-53), 7 more IOSBs and in-use flags), c c- c Integer DISKBL Parameter (DISKBL = 512) Parameter (NMIOSB = 16) C C Note: Ideally, the following parameter should be provided as input C to this routine! C Parameter (IRECLN = 128) ! Recordsize (4 byte units) C integer*4 ilast, isize c c... Calls to inhibit open failure messages c... No such file call errset (29,.true.,.false.,.true.,.false.,15) c... Open failure call errset (30,.true.,.false.,.true.,.false.,15) c... File name spec error call errset (43,.true.,.false.,.false.,.false.,15) c ierr = 0 jerror = 0 c... Initialize block do 100 i = 1,53 100 block (i) = 0 c... Get Block I/O file lun block(1) = kblk if (block(1) .le. 0) goto 8900 c... Get error file lun block(2) = kerr if (block(2) .le. 0) goto 8900 c... Validate the dimension if (nrec .le. 0) go to 8900 c... Get blocksize in bytes and make sure it is a multiple c... of DISKBL bytes (one disk block) for disk i/o if (nbperr .lt. DISKBL) go to 8900 if (mod(nbperr,DISKBL) .ne. 0) go to 8900 block(4) = nbperr / DISKBL if (itype .lt. -1 .or. itype .gt. 2) go to 8900 block(5) = NMIOSB isize = nrec * block (4) ! Number of blocks for file ilast = isize * (DISKBL/(IRECLN*4)) ! Last record in the file itry = 0 c... Clear any previous error call errsns c 1000 if (itype .ne. -1) go to 1005 c... Extend old file open(unit=block(1),type='old',access='direct', 1 recordsize=IRECLN,name=fname,err=1100,initialsize=isize) go to 1035 1005 if (itype .ne. 0) go to 1010 c... New file open(unit=block(1),type='new',access='direct', 1 recordsize=IRECLN,name=fname,err=1100,initialsize=isize) go to 1035 c 1010 if (itype .ne. 2)go to 1060 c... Unknown open(unit=block(1),type='old',access='direct',READONLY, 1 recordsize=IRECLN,name=fname,err=1030,initialsize=isize) go to 1050 c... Could not open old "unknown" so create a new one 1030 open(unit=block(1),type='new',access='direct', 1 recordsize=IRECLN,name=fname,err=1100,initialsize=isize) c c... Processing comes here for new files. Since we are doing our own c... I/O, the file will not be extended automatically as it would using c... FCS. So, while we are using FCS, we hit the last record in the c... file, which forces the file to be fully allocated. c 1035 write (block(1)'ilast,err=8900) ierr c c... Close file and re-open for direct operating system i/o c... (avoids the overhead of FORTRAN and FCS) 1050 close(unit=block(1)) c 1060 continue If (iread .eq. 0) Then If (ishare .eq. 0) Then open(unit=block(1),type='old',access='direct', 1 name=fname,buffercount=-1,err=8900) Else open(unit=block(1),type='old',access='direct', 1 name=fname,buffercount=-1,shared,err=8900) End If Else If (ishare .eq. 0) Then open(unit=block(1),type='old',access='direct', 1 name=fname,buffercount=-1,readonly,err=8900) Else open(unit=block(1),type='old',access='direct', 1 name=fname,buffercount=-1,shared,readonly,err=8900) End If End If c... Reset open failure defaults call errset (29,.true.,.true.,.true.,.true.,15) call errset (30,.true.,.true.,.true.,.true.,15) call errset (43,.true.,.true.,.false.,.true.,15) go to 9000 c c... Initial open failure? 1100 call errsns (jerror) if (jerror .eq. 29 .or. jerror .eq. 43) go to 8950 if (itry .ne. 0) goto 8950 c... Yes, try for non-contiguous space allocation itry = 1 isize = -isize goto 1000 c entry clsblk (block,idisp) c c... Closes the block io file c if (idisp .ne. 0) close (unit=block(1),disp='delete') if (idisp .eq. 0) close (unit=block(1),disp='save') go to 9000 c 8900 call errsns (jerror) 8950 ierr = 1 block (3) = jerror 9000 return c end c subroutine vgetbl (block,irec,kbuf,index,nbytes,ierr) c c+ c c VGETBL -- loads working virtual arrays from disk file/core buffers c c block - 53 word block that describes the open file c c irec - record number to be read or written c c kbuf - NOTE!! An I*4 buffer used for block i/o; c specify name only!! When you pass an index, be c sure that it corresponds to an I*4 array (for c non-virtual arrays only)!! c c index - index into kbuf, where read or write should start c c nbytes - the number of bytes to read or write. NOTE!! If c you are reading or writing more than "maxbyt"'s c bytes, then multiple QIO's will be issued and c you should call WAITBL with "iwait" = 0; i.e. c wait for all QIO's to complete. c c Note: Please consult the source listing for GETVIR (GETVIR.MAC) for c possible "unanticipated" behaviours. You may want to modify c the calling sequence to GETVIR to guarantee correct mapping. c c- c Integer DISKBL Parameter (DISKBL = 512) Parameter (MAXBYT = 8192) Parameter (NMIOSB = 16) C C... Operating system Read/Write and I/O success codes (octal) C Parameter (IORVB = '10400'O) Parameter (IOWVB = '11000'O) Parameter (ISSUC = 1 ) C c... 32 bit file block number integer*4 iblock, nbytes, kbuf(1), i c... Operating system i/o parameter and status blocks integer*2 ioparm(6,NMIOSB), block(53), getvir, tsize dimension itemp (2) c equivalence (itemp(1), iblock) c ivirt = 1 go to 500 c c... GETBLK -- Entry point for non-virtual arrays c entry getblk (block,irec,kbuf,index,nbytes,ierr) c ivirt = 0 c c... Set up i/o command for read virtual block 500 iocmnd = IORVB goto 1000 c c... VPUTBL -- Entry point for writing to virtual array c entry vputbl (block,irec,kbuf,index,nbytes,ierr) c ivirt = 1 go to 800 c c... PUTBLK -- Entry point for non-virtual arrays c entry putblk (block,irec,kbuf,index,nbytes,ierr) c ivirt = 0 c c... Set up i/o command for write virtual block 800 iocmnd = IOWVB c... Validate index and record number 1000 if (index .le. 0 .or. irec .le. 0) go to 9800 c jrec = irec ndex = index iopind = 0 c... Process a maximum of MAXBYT bytes at a time tsize = MAXBYT Do 2500 i = 1,nbytes,MAXBYT iopind = iopind + 1 if (iopind .gt. NMIOSB) go to 9700 If (i+MAXBYT .gt. nbytes+1) Then tsize = (nbytes+1) - i End If c... Load buffer address in I/O parameter list if (ivirt .eq. 0) then c... For non-virtual arrays call getadr (kadr,kbuf(ndex)) if (mod(kadr,2) .ne. 0) goto 9800 ioparm(1,iopind) = kadr else c... For virtual arrays ioparm (1,iopind) = getvir (kbuf,ndex,kbytes,ierr) if (ierr .ne. 0) then write (block(2),610) 610 format (' Error from GETVIR.') go to 9000 end if end if c c... Load transfer size in i/o parameter list 2000 ioparm(2,iopind) = tsize ioparm(3,iopind) = 0 c... Calculate disk block address relative to the start iblock = (jrec - 1) * block (4) + 1 ioparm (4,iopind) = itemp (2) ioparm (5,iopind) = itemp (1) c... Compute index into block that will be the iosb for this call ind = block (5) ind = ind + 1 if (ind .gt. NMIOSB) ind = 1 iosb = ind * 3 + 5 if (block (iosb) .ne. 0) go to 9700 block (iosb) = 1 block (5) = ind c... Issue operating system i/o call call qio(iocmnd,block(1),block(1),,block(iosb-2), 1 ioparm(1,iopind),ierr) c... Check error status if (ierr .ne. ISSUC) goto 9800 c jrec = jrec + (tsize / (DISKBL * block (4))) if (ivirt .eq. 0) then c... For non-virtual arrays ndex = ndex + tsize / 4 else c... For virtual arrays ndex = ndex + tsize / kbytes end if 2500 continue c ierr = 0 9000 return c 9700 write (block(2),600) NMIOSB 600 format (/' More than ',i2,' consecutive I/O calls--error.') go to 9000 C 9800 ierr = 1 write (block(2),605) (block (i), i=iosb-2,iosb-1) 605 format (' The index, record number, or QIO has an error.'/, 1 ' 53 word block:',/,2o7) go to 9000 c end c subroutine waitbl (block,iwait,ierr) c c+ c c waitbl -- waits for disk i/o to complete, in the order the c gets or puts were made. c c iwait = 0 -- waitbl will wait for all QIO's. c = 1 -- waitbl will wait for only for the c oldest QIO. c- Parameter (NMIOSB = 16) Parameter (ISSUC = 1) C integer block (53) c ierr = 0 c... Infin is used as a counter to prevent infinite looping infin = 0 c... Block (5) is the index into the most recently used iosb in block ind = block (5) C 100 infin = infin + 1 if (infin .gt. NMIOSB) go to 9100 ind = ind + 1 if (ind .gt. NMIOSB) ind = 1 iosb = ind * 3 + 5 c... Find first get or put in queue if (block (iosb) .eq. 0) go to 100 c... Iosb-2 points to the iosb of the first get or put made if (block (iosb-2) .ne. 0) go to 400 c... I/O is not complete, so wait 300 call waitfr (block(1),ids) If (ids .ne. ISSUC) Then write(block(2),5000) ids 5000 format (/' WAITFR directive status: ',O8) ierr = 1 End If C... If the event flag was set for a different QIO, wait for a significant C... event (e.g., I/O completion) and try again If (block(iosb-2) .eq. 0) Then Call WFSNE Goto 300 End If c c... Check for successful completion 400 if (block (iosb-2) .eq. ISSUC) go to 420 write(block(2),5002) block (iosb-2), block (IOSB-1) 5002 format (/' I/O Status block = ', 2O8,' (octal)') ierr = 1 c 420 do 500 j = iosb-2, iosb 500 block (j) = 0 c if (iwait .eq. 0) go to 100 c 9100 return c END