SUBROUTINE RDGET( funit, munit, fldnum, aindx, option, stats ) C C retrieve a record from RDM file (funit) using map file (munit) C if mapped. C C C funit = unit number associated with opened RDM file. C munit = unit number associated with an opened map file. C - not used if mapped flag is .FALSE. or munit=0. C fieldno = number of field to perform search on (see FIELDLIST in RDM) C (fldnum) a binary search done if fieldno is master sort key or sort C key used in map file else a sequential search is done. C aindx = index in array for compare if field is array type. C (no support for arrays of RECORD, or arrays w/in RECORD) C C Option = (Options may be added) C 1 Lock this block C 2 unlock previously locked blocks C 4 Key is unique - return with first matching record C 8 Display Trace information (When compiled with Debug) C 64 Next Matching Record (from current position) C Note: Next is intended for use only with the primary key C of a sorted file to search for additional matching C records that have not yet been sorted into position C C C stats = status of RDGET operation: (Additive) C C 1 = record not retreived C 2 = bad fieldno or illegal key type C 4 = bad unit number/file C 8 = block locking failure C 16 = Binary search performed C 32 = unsorted records at eof C 64 = Unsorted section was searched C 128 = File is Empty C C value = in RDMBUF, must have contents of search key C keyval = working copy of value C keypoint = pointer to current position w/in the key (record) C rec = if record is found with value, rec will have contents of record. C else rec will be undefined. (whatever was there before) C C If the record is not found the file record pointer doesn't change. C no boolean keys, please. 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(A-Z) INCLUDE 'RDMBUF.For' !for application program INCLUDE 'RDMCOM.For' !for RDOPEN,RDCLOS, etc.. BYTE fldtmp(256) !temporary field for comparisons Byte keyval(256) !working copy of key value Integer*4 Trecno,Tmrno, 1 top,bottom !pointers for binary search C C types of comparisons that RDGET can make C REAL*8 real8,treal8 !for real4, dollar data types REAL*4 real4,treal4 !for real, longdate, time data types INTEGER*2 int2w(2) !for long, money data types integer*2 tint2w(2) !(must handle reversed words) INTEGER int2,tint2 !for integer, date, scalar data types BYTE byt,tbyt !for byte, and possibly bit data types CHARACTER*255 strng,tstrng !for char, string, numeric data types Logical*1 found !a record matches (used in resolving C !non-unique keys) Logical*1 greatr, !flag to signal > handling at end 1 array, !flag to signal array 2 lock, !signals block locking 3 unlock ! " " unlocking Byte answer Integer*4 mfrnos(128) !map file record numbers Equivalence (mfrnos,mblock) C C equivalence comparison types to value (passed by application) C EQUIVALENCE( keyval(1), real8 ) EQUIVALENCE( keyval(1), real4 ) EQUIVALENCE( keyval(1), int2w ) EQUIVALENCE( keyval(1), int2 ) EQUIVALENCE( keyval(1), byt ) EQUIVALENCE( keyval(1), strng ) EQUIVALENCE( keyval(1), inword ) C C.. Equivalence comparison types for record key buffer C EQUIVALENCE( fldtmp(1), treal8 ) EQUIVALENCE( fldtmp(1), treal4 ) EQUIVALENCE( fldtmp(1), tint2w ) EQUIVALENCE( fldtmp(1), tint2 ) EQUIVALENCE( fldtmp(1), tbyt ) EQUIVALENCE( fldtmp(1), tstrng ) EQUIVALENCE( fldtmp(1), tword ) C C.. Internal Options C INTEGER stats, CONPNT, Munit LOGICAL*1 maping, !.TRUE. if a valid munit and mapped 1 binary, !.TRUE. if going to use binary search 2 unsrtd, !.TRUE. RDM file has some unsorted records 3 recrd, !.TRUE. if search is on type Record 4 unique, !.TRUE. if key is unique 5 start, !.True. if Starting with "Current" Record 6 tail, !.True. if searching only Unsorted section 7 Next !.True. if searching for next matching record D Logical*1 trace !.True. if tracing desired (debug mode) C C.. table for handling data type RECORD C Parameter (mfrec=4) ! maximum fields w/in one record INTEGER nrf, ! number of record fields 1 rfnum(mfrec), ! field number table 2 rpoint ! pointer to current record field C C.. Clean the exhange buffer C Do 5 I = 1, 512 rec(I) = 0 5 Continue recnum = 0 Stats = 0 !assume everything will go O.K. C C.. See if unit number has changed since last RDM call C If (Curfil.Le.0.Or.(funit.Ne.Units(Curfil))) Then C C.. search the table for the right file index (curfil) C Oldblk = 0 Do 10 I = 1, Nfiles Curfil = I If (Units(I).Eq.funit) Goto 20 10 Continue C C.. not in table C Stats = Stats.Or.5 ! 1-not retreived / 4-bad unit or file Return C C.. Got it C 20 Continue Ich = Ichan(Curfil) Endif C C.. Is the file Empty? C If (xRnum(Curfil).Eq.0) Then Stats = 129 ! 1-not found + 128 - empty file Return Endif C C.. let's get started -- calculate some parameters & set up C nrecs = 512/Rsize(Curfil) !number of records per block fieldno = fldnum + fldofs(Curfil) !adjusted field number ftyp = RecDef( fieldno,1 ) !get field data type fsiz = RecDef( fieldno,3 ) !get field size D Trace = (Option.And.8).Ne.0 D if (trace) type *,' rdget> *** start ***' D if (trace) type *,' Fieldno =',Fieldno,' fsiz =',fsiz,' ftyp =',ftyp Lock = (Option.And.1).Ne.0 Unlock = (Option.And.2).Ne.0 Unique = (Option.And.4).Ne.0 Start = (Option.And.16).Ne.0 Tail = (Option.And.32).Ne.0 Next = (Option.And.64).Ne.0 D If (trace.and.Next) type *,' ....Next Option Selected' If (Next) Then Next = Recno(Curfil).Ge.0 !ignore it on first one D If (.Not.Next.And.Trace) type *,'... Next turned off' Endif C C.. check for impossible searches (boolean or bit keys, field size=0) C IF ((ftyp.EQ.3).Or.(ftyp.eq.8).OR.(fsiz.EQ.0)) THEN D If (trace) Type *,' Rdget> Impossible Search' Stats = Stats.Or.3 ! 1-not retreived/2-bad fieldno or key type RETURN ENDIF C C.. load the key value into its buffer C Do 30 I = 1, fsiz keyval(I) = value(I) 30 Continue Keypoint = 0 C C.. if dealing with an array, adjust offset W/in record for array index C array = RecDef(Fieldno,4).Ne.0 IF ( array ) THEN D If (Trace) Type *,' Rdget> setting up for array' fofs = (aindx-1)*fsiz + RecDef( fieldno,2 ) !offset in record ELSE fofs = RecDef( fieldno,2 ) If (Aindx.Ne.0) Type *,' Rdget> *** Warning *** Array index ', 1 'without Array ' ENDIF C C.. find out if using a map file C maping = mapped(Curfil).AND.(munit.GT.0) C C.. set binary search flag if fieldno is primary (or implied) sort key C using option "Next" disables binary C If (.Not.maping) Then binary = sort( 1, Curfil ).EQ.fieldno If (.Not.binary) binary = sort ( 2, Curfil).EQ.fieldno If (binary) binary = .Not.Next Else C C.. Make sure we are positioned correctly in the map table C D If (Trace) Type *,' Rdget> using a map' If (Curmap.Le.0.Or.Nmaps.Eq.0) Stop 'Rdget> No map files open' If (munit.Ne.Mapunit(1,Curmap)) Then ! change map files Do 40 Im = 1, Nmaps If (Mapunit(1,Im).Eq.munit) Then Curmap = Im Goto 50 Endif 40 Continue Type *,'Rdget> Map Unit',munit,' not open' Stop 50 Continue Endif If (Mapunit(2,Curmap).Ne.funit) Then ! wrong file Type *,' Rdget> Attempt to use map with unrelated file' Stop Endif binary = Msort(Curmap).Eq.fieldno Endif C C. binary search only first field of array C If (binary.And.array) binary = Aindx.Eq.1 D If (Trace) then D If (binary) then D Type *,' Rdget> will use Binary Search' D else D Type *,' Rdget> will use Sequential Search' D Endif D Endif C C.. test for unsorted records appended to end of file C Unsrtd = xRnum(Curfil).NE.xSnum(Curfil) If (Unsrtd) Stats = Stats.Or.32 D If (Unsrtd.And.Trace) Type *,' Rdget> unsorted records at eof' C C... if searching only unsorted portion of file dink the flags C If (Tail) Then D if (trace) type *,' ..setting up for tail search..' binary = .False. !if tail search, disable binary Stats = Stats.Or.64 !ie.. tail searched If (.Not.Unsrtd) Then !why bother Stats = Stats.Or.1 !no records = not found Return Endif Endif C C.. If we are going to search on RECORD Datatype, some setup is required C recrd = ftyp.eq.5 If (recrd) Then D If (Trace) Type *,' rdget> setup for search on type RECORD ' nrf = 0 C C.. set up table of fields that will be used in the comparisons C 51 Continue nxtseq = Recdef(fieldno,5) ! next dictionary record fieldno = Dictab(nxtseq) ! convert to field # ftyp = Recdef(fieldno,1) If (ftyp.eq.17) Goto 52 !end of record field nrf = nrf + 1 if (nrf.Gt.mfrec) Stop 'rdget> too many fields w/in record' rfnum (nrf) = fieldno Goto 51 C C.. load the first field w/in record into search buffer C 52 Continue Assign 54 to CONPNT !CONPNT = continuation point Goto 14000 Endif !record setup finished C C.. set up for the search C 54 Continue Found = .False. IF (binary) THEN !set up binary search ptrs IF (maping) THEN !use map file top = mRnum(Curmap) !end of records(elements) bottom = 0 tmrno = top/2 ELSE !use RDM file top = xSnum(Curfil) - 1 !end of sorted records bottom = 0 trecno = top/2 If (Start) trecno = Recno(Curfil) ENDIF ELSE !sequential search tmrno = 0 trecno = 0 If (Tail) trecno = xSnum(Curfil) If (Next) Then trecno = Recno(Curfil) + 1 !next physical record If (trecno.Ge.xRnum(Curfil)) Then !eof Stats = Stats.Or.1 Return Endif Endif ENDIF C C.. Get record number from map file. C 55 CONTINUE IF (maping) THEN IF (tmrno.Le.112) THEN !1st 32 words is file header mblkno = 1 mrcptr = tmrno + 16 !offset into block (skip header) ELSE mr = tmrno - 112 mblkno = mr / 128 + 2 !Calculate block # mrcptr = MOD( mr , 128 ) !array element w/in block ENDIF IF (mblkno.NE.oldmbk) READ(munit'mblkno) mblock oldmbk = mblkno trecno = mfrnos(mrcptr) ENDIF C C.. got record number, retrieve RDM record C 70 Continue D If (Trace) type *,' test record (trecno)=',trecno D If (Trace.And.Binary) type *,' -> Top =',top,' Bottom=',bottom D If (Trace.And.Recrd) type *,' rpoint=',rpoint blkno = (trecno/nrecs)+Hnum(Curfil)+1 !no block spanning records IF (blkno.NE.oldblk) READ(funit'blkno) block oldblk = blkno recptr = MOD(trecno,nrecs)*Rsize(Curfil) !offset into block greatr = .False. C C.. compare record with key value C C.. Load the field into the comparison buffer C DO 80 k=1,fsiz fldtmp(k) = block( recptr+fofs+k ) 80 Continue C Gindx = ftyp + 1 C C ftyp = 0 1 2 3 4 5 6 7 8 9 10 11 C ------------------------------------------------------ Goto (100,200,300,10000,100,10000,100,300,10000,300,300,500, 1 600,500,600,200,10000,10000,10000,200),Gindx C ------------------------------------- C 12 13 14 15 16 17 18 19 = ftyp C C Note: does not handle synonyms or nested records C C.. types Integer (0), Date (4), Scalar (6) (Integer*2) C 100 Continue D If (Trace) type *,' int2 comparison (key,rec)=',int2,tint2 D If (Trace) type 101,int2,tint2 101 Format(' in octal key>',O6.6,' Record>',o6.6) IF (int2.EQ.tint2) GOTO 9000 IF (int2.LT.tint2) GOTO 12000 GOTO 13000 C C.. types Real (1), Longdate (15), Time (19) (Real*4) C 200 Continue D If (Trace) type *,' real4 comparison (key,rec)=',real4,treal4 IF (real4.EQ.treal4) GOTO 9000 IF (real4.LT.treal4) GOTO 12000 GOTO 13000 C C.. Char (2), String(9), & Byte (7) C 300 Continue D If (Trace) type *,' string comparison key=',strng(1:fsiz) D If (Trace) Type *,' tstring >',tstrng(1:fsiz) IF (strng(1:fsiz).EQ.tstrng(1:fsiz)) GOTO 9000 IF (strng(1:fsiz).LT.tstrng(1:fsiz)) GOTO 12000 GOTO 13000 C C.. Real4 (13) & Dollar (11) (Real*8) C 500 Continue D If (Trace) type *,' real8 comparison=(key,rec)=',real8,treal8 IF (real8.EQ.treal8) GOTO 9000 !Found IF (real8.LT.treal8) GOTO 12000 !goto less than computations GOTO 13000 !goto greater than comput. C C.. types Long (14), Money (12) 2-Word integers (non-standard) C 600 Continue D If (Trace) type *,' int4 comparison (key,rec)=',int2w,tint2w Iw = 0 640 Continue Iw = Iw + 1 If (Iw.Ge.3) Goto 9000 ! both words match If (int2w(Iw).eq.tint2w(Iw)) Goto 640 ! this word matches If (int2w(Iw).Lt.tint2w(Iw)) Goto 12000 Goto 13000 C C.. End of Computed Goto C C------------------------------------- C C.. Found a record that matches C 9000 Continue D If (Trace) Type *,' Rdget> ****Match****' C C.. Handle RECORD, if necessary C If (recrd) then D If (Trace) Type *,' Rdget> in record handling ' If (rpoint.lt.nrf) Then ! we ain't done yet D If (Trace) type *,' -- loading the next field in record --' rpoint = rpoint + 1 C C.. load the next field in the record C If (keypoint.Eq.0) Keypoint = fsiz fieldno = rfnum(rpoint) ftyp = RecDef( fieldno,1 ) !get field data type fofs = RecDef( fieldno,2 ) !offset w/in data record fsiz = RecDef( fieldno,3 ) !get new field size C C.. adjust the keyvalue so we use the right comparison value C. check for word alignment unless Char(2) or Byte(7) C If ((MOD(Keypoint,2).Ne.0) !pointer not word aligned 1 .And.(ftyp.Ne.2.And.ftyp.Ne.7)) Keypoint = Keypoint + 1 Do 9050 I = 1, fsiz keypoint = keypoint + 1 keyval(i) = value(keypoint) 9050 Continue Goto 70 !do the next field Endif Endif C C.. Check to make sure it's the first one C found = .True. ! set the flag that we have found one If (Binary.And..Not.Unique) then ! it might not be the first one D If (Trace) Type *,' Modifying binary pointers for uniqueness' D If (Trace) type *,' adjusting the top ' If (.Not.recrd) Goto 12000 C C.. handle non-unique record key by reseting record to first field C Assign 12000 to CONPNT Goto 14000 Endif C C.. The End (Return point) C 10000 CONTINUE D If (Trace) Type *,' -- Welcome to the End -- ' If (binary) Stats = Stats.Or.16 C C.. failure C If (.Not.Found) Then stats = stats.Or.1 !(not found) recnum = 0 Recno(Curfil) = 0 D If (Trace) type *,'record not found' RETURN Endif C C.. success C If (Greatr) Then ! it's the Next record trecno = trecno + 1 blkno = (trecno/nrecs)+Hnum(Curfil)+1 IF (blkno.NE.oldblk) READ(funit'blkno) block oldblk = blkno recptr = MOD(trecno,nrecs)*Rsize(Curfil) Endif C C.. Load it into the buffer C DO 10120 k=1,Rsize(Curfil) rec( k ) = block( recptr+k ) 10120 Continue Recno(Curfil) = trecno ! save record number for Rdnxt recnum = trecno + 1 D If (Trace) type *,' Rdget> Recno(Curfil) =',Recno(Curfil) D If (Trace) type *,' Rdget> Curfil=',Curfil,' Recnum=',Recnum C C.. handle block locking here C If (Access(Curfil).Ne.1) Return D If (Trace) Type *,' Rdget> will try to lock record' tsxblk = blkno - 1 C C.. unlock all (previously) locked blocks on this channel C D If (Unlock) type *,' unlocking previously locked blocks' If (Unlock) Ierr = Iualbk(Ich) D if (Unlock.And.Trace) type *,' Return Code from unlock>',Ierr C C.. lock the block & Return C If (Lock) Then 10140 Continue Ierr = Lkblk(Ich,tsxblk) If (Ierr.ne.-1) Then Type 10146,7,8,8 10146 Format(' ',A1,'Rdget> Record did not lock -- ', 1 'Try Again ? [Y]',2A1,$) Accept 10147,Nb,Answer 10147 Format(Q,A) Answer = Answer.And.-33 ! Kick the Upper Case bit If (Nb.eq.0.Or.Answer.Eq.'Y') Goto 10140 Stats = Stats.Or.8 !block lock failure Endif Endif If (maping) Mrcno(Curmap) = tmrno RETURN C------------------------------------------------------- C C The Search C C target is LESS THAN current record, lower the top C 12000 Continue D If (Trace) Type *,' ** target is LESS THAN CURRENT Record ' C C.. binary C IF (binary) THEN IF (maping) THEN ! we're using a map IF (bottom.Ge.top) GOTO 10000 ! binary can't find it..finis top = tmrno - 1 ! reset binary pointers tmrno = (top + bottom)/2 ELSE !ptrs are to RDM file IF (bottom.Ge.top) THEN ! binary can't find it D if (trace) Type *,' bottom > top ' If (.Not.unsrtd) Goto 10000 ! nothing else to search If (Found) Goto 10000 D If (Trace) Type *,' start sequential search of unsrtd' binary = .FALSE. ! start seq. search trecno = xSnum(Curfil) ! with first unsorted rec. Stats = Stats.Or.32 ! set return flag ELSE D if (trace) type *,' top lowered' top = trecno - 1 ! reset binary pointers trecno = (top + bottom)/2 ENDIF ! bottom.vs.top ENDIF ! maping ELSE C C.. sequential C IF (maping) THEN !ptrs are to map file tmrno = tmrno + 1 IF (tmrno.GT.mRnum(Curmap)) GOTO 10000 ! end of (map) file ELSE !ptrs are to RDM file If (Next) Then !are we in the sorted portion D IF (Trace) type *,' ... handle Next...' If (trecno.Lt.xSnum(Curfil)) Then !yes, reset to tail D if (Trace) type *,' resetting (Next) for tail search' If (Unsrtd) Then trecno = xSnum(Curfil) ! first unsorted rec. Tail = .True. binary = .False. Stats = Stats.Or.64 !tail search status Goto 70 !retreive record Else Goto 10000 Endif Endif Endif trecno = trecno + 1 IF (trecno.Ge.xRnum(Curfil)) GOTO 10000 ! eof, bag it. ENDIF ENDIF If (recrd.and.(Rpoint.Gt.1)) Then Assign 70 to CONPNT Goto 14000 Endif GOTO 70 ! go back to comparison section C C--------------------------------------------------------------- C C target is GREATER THAN current record, raise the bottom C 13000 Continue D If (Trace) Type *,' ** target is GREATER THAN CURRENT Record ' Greatr = .True. IF (binary) THEN !modify binary search ptrs IF (maping) THEN !ptrs are to map file IF (bottom.Ge.top) GOTO 10000 bottom = tmrno + 1 tmrno = (top + bottom)/2 ELSE !ptrs are to RDM file IF (bottom.Ge.top) THEN D If (Trace) Type *,' Bottom > Top ' If (Found) Goto 10000 !no need to look IF (.Not.unsrtd) Goto 10000 !nothing to search D If (Trace) type *,' -- Switching to sequential search' binary = .FALSE. !seq. search trecno = xSnum(Curfil) ELSE bottom = trecno + 1 trecno = (top + bottom)/2 ENDIF ENDIF ELSE !modify sequential ptrs IF (maping) THEN !ptrs are to map file tmrno = tmrno + 1 IF (tmrno.GT.mRnum(Curmap)) GOTO 10000 ELSE !ptrs are to RDM file trecno = trecno + 1 IF (trecno.Ge.xRnum(Curfil)) GOTO 10000 ENDIF ENDIF If (.Not.recrd.Or.(rpoint.Eq.1)) Goto 70 Assign 70 to CONPNT C C--------------------------------------------- C Reset the Key for first field in Record C 14000 Continue D If (Trace) Type *,' Reseting the record table for first field ' rpoint = 1 fieldno = rfnum(rpoint) ftyp = RecDef( fieldno,1 ) !get field data type fofs = RecDef( fieldno,2 ) !offset w/in data record fsiz = RecDef( fieldno,3 ) !get new field size keypoint = fsiz Do 14100 I = 1, keypoint keyval(I) = value(I) 14100 Continue Goto CONPNT END