Subroutine RDGREC(funit,JRecord,Option,Stats) C C.. This routine will Get a record from RDM by Physical Record Number C C. 11OCT85 wms C Option = 1 Lock this block C 2 unlock previously locked blocks C (options may be added) C C Stats = 0 Record retrieved C 1 Unable to retrieve C 2 Unknown file (Funit) C C Walt Shpuntoff Institute for Resource Management C 2666 Riva Road - Suite 360 C Annapolis, MD 21401 C (301) 266 - 9216 C Implicit Integer*2 (A-Z) Integer*4 JRecord,Jblock,nrecs,Jindx,Jrec Logical*1 Lock,Unlock d Logical*1 Trace Include 'Rdmcom' Include 'Rdmbuf' C C.. unpack the options C Lock = (Option.And.1).Ne.0 Unlock = (Option.And.2).Ne.0 d Trace = (Option.And.8).Ne.0 If (Lock) Lock = Access(Curfil).Eq.1 ! locking just for shared file If (Unlock) Unlock = Access(Curfil).Eq.1 C C.. See if unit number has changed since last RDM call C If (Curfil.Le.0.Or.(funit.Ne.Units(Curfil))) Then d If (Trace) Type *,'Rdgrec> file change' C C.. search the table for the right file index (curfil) C Do 20 I = 1, Nfiles Curfil = I If (Units(I).Eq.funit) Goto 30 20 Continue C C.. not in table C Stats = 2 Return C C.. Got it C 30 Continue Ich = Ichan(Curfil) Endif D Type *,' Rdgrec> record ',Jrecord,' requested ' D Type *,' max in file (xRnum) ',xRnum(Curfil) D Type *,' file #=',Curfil,' Option=',option C C.. unlock all locked blocks C If (Unlock) Then d If (Trace) type *,' unlocking...' Call Iualbk(Ich,Ierr) d If (Trace) Type *,' return code from iualbk=',Ierr If (Ierr.Ne.-1) Pause 'Rdgrec> failed to unlock block' Endif C C.. Record # is used as offset in file, start with 0 C Jrec = Jrecord - 1 C C.. is it w/in bounds of file C If (JRec.Gt.xRnum(Curfil)) Goto 900 C C.. initialize some things C stats = 0 !assume everything will go O.K. nrecs = 512/Rsize(Curfil) !number of records per block C C.. calculate block # with RDM record. Note: Hnum = # blocks in header C blocks = JRec / nrecs ! block # w/in data area of file tsxblk = blocks + Hnum(Curfil) blkno = tsxblk + 1 ! F77 counts start w/ 1 C C.. lock the block C If (Lock) Then Ierr = Lkblk(Ich,Tsxblk) If (Ierr.ne.-1) pause ' rdgrec> failed to lock block ' Endif C C.. Read the block C READ(funit'blkno,Err=900) block C C.. Figure out which record w/in the block C Jindx = Jrec - ((Jrec/nrecs)*nrecs) Indx = Jindx Recptr = Indx * Rsize(Curfil) C C.. load it into the common area one byte at a time & set record pointers C Do 100 I = 1, Rsize(Curfil) rec(I) = Block(Recptr + I) 100 Continue Recnum = Jrecord Recno(Curfil) = Jrec d If (Trace) Type *,' Rdgrec> Recno(Curfil)=',Recno(Curfil) d If (Trace) Type *,' Rdgrec> Curfil>',Curfil,' Recnum=',Recnum C C. This must be the end C Return C C.. Just in case there are problems C 900 Continue d If (Trace) Type *,' rdgrec> bad return status' Stats = 1 Return End