SUBROUTINE RDOPEN( Unit, Fil, Aksess ,Stat) C C.. open RDM file and prepare for reading and writing of records. C C fil = name of RDM file (14 characters). C funit = unit number to associate fil with in open. C C Access = 0 for READONLY C (Aksess) 1 Shared/Update C 2 Exclusive (currently required for ADD) C +8 display trace information C C Stat = 0 if everything worked C If file is opened Read/Write then Stat = Return code from C Tsx file locking call C 1 - file was not open 2 - Too many shared channels C 3 - Too many shared files 4 - Protection Conflict C 5 - Too many files (>Maxfiles) 6 - Too many fields (>Maxfld) C C.. Note: if you are serious about reading this program, it would be helpful C to have the "RDM Programmers Reference Manual" in hand C C Walt Shpuntoff Institute for Resource Management C 2666 Riva Road - Suite 360 C Annapolis, MD 21401 C (301) 266 - 9216 C C RDM is a copyright of Interactive Technology, Inc C TSX+ is a copyright of S&H Computer Systems, Inc C IMPLICIT INTEGER*2 (A-Z) Character*1 Bell Data Bell/7/ INCLUDE 'RDMBUF' INCLUDE 'RDMCOM' CHARACTER fil*14 Integer*2 Funit,Stat,Unit, Aksess, fldindx, indx Logical*1 Trace C C.. variables for reversing words on "Longs" C Integer*4 Long Integer*2 Short(2) Equivalence (Long,Short) C C.. record retrieval declarations C INTEGER begrec,endrec C C preamb is record for preamble record; C hashrc is record for hash table C dicrec is record for any dictionary records (fieldnodes) C BYTE hashrc(64),dicrec(64) C C.. RDM disk resident data structures C Include 'Rdprem' C C.. Hash record (record number 9), 1st record of 2nd block C this is a simple alphabetical index to the data dictionary C BYTE Hash(52) !the record is an array of byte pairs C ! each pair corresponds to a letter C !of the alphabet(26 letters, 52 bytes) C !1st byte of pair=starting rec. number C !2nd byte of pair=ending rec. number C !for names in dictionary starting with C !that letter of the alphabet. C !ex., Hash(1)=1st rec starting with A C ! Hash(2)=last rec starting with A EQUIVALENCE( hashrc,hash ) C C.. Dictionary record declaration (record number 10-??) C each dictionary record contains the specific information about the C field it describes: position of field in data record, data type, C field size in bytes, dictionary sequence number, etc. C INTEGER xDisp, !24 Displacement in bytes of this C ! field from beginning of record 1 ySize !32 size of this field in bytes BYTE DatTyp !21 RDM data type LOGICAL*2 Recfld, !22 for RECORD data types, seq. C ! number of 1st field of rec. 1 Nxtseq, !28 header record number of next C ! field in dictionary seq. order 2 Fstat, !36 display option bits; option bits C ! are defined in order in which the C ! options appear on the Dictionary C ! Editor Advanced screen 3 Scalrc, !40 not used (Scalarec) 4 Prvseq !62 header record number of previous C ! field in dictionary seq. order CHARACTER*20 Name, !0 Field name 1 Pictur !42 not used CHARACTER xSeq, !20 dictionary sequence number(1..220) 2 xSort, !26 CHR(xSort) is the sort level of C ! this field; =0 if not sort field 3 xStat, !27 not used 4 Nele, !30 for array fields: no. of elements 5 xLevel, !31 security level of field(0..255) 6 Dfield, !34 format size for printing 7 Dplace, !35 digits to rt. of decimal or bit C ! position for bit data type 8 xSep1, !38 for record data types: record C ! separator character 9 xSep2 !39 for record data types: C ! ORD(xSep2)=alternate separator by C ! data size EQUIVALENCE( dicrec(1), Name ) EQUIVALENCE( dicrec(21), xSeq ) EQUIVALENCE( dicrec(22), DatTyp ) EQUIVALENCE( dicrec(23), Recfld ) EQUIVALENCE( dicrec(25), xDisp ) EQUIVALENCE( dicrec(27), xSort ) EQUIVALENCE( dicrec(28), xStat ) EQUIVALENCE( dicrec(29), Nxtseq ) EQUIVALENCE( dicrec(31), Nele ) EQUIVALENCE( dicrec(32), xLevel ) EQUIVALENCE( dicrec(33), ySize ) EQUIVALENCE( dicrec(35), Dfield ) EQUIVALENCE( dicrec(36), Dplace ) EQUIVALENCE( dicrec(37), Fstat ) EQUIVALENCE( dicrec(39), xSep1 ) EQUIVALENCE( dicrec(40), xSep2 ) EQUIVALENCE( dicrec(41), Scalrc ) EQUIVALENCE( dicrec(43), Pictur ) EQUIVALENCE( dicrec(63), Prvseq ) C D Type *,' Rdopen> File=',fil,' Unit =',Unit D Type *,' on entry, Nfiles=',Nfiles,' Nfields=',Nfields C C.. Let's start w/ bad status C Stat = 1 C C.. check to make sure there is room in the file table C If (Nfiles.Lt.0) Nfiles = 0 Nfiles = Nfiles + 1 If (Nfiles.Gt.Maxfile) Then Type *,' Rdopen> file capacity exceeded ' Stat = 5 Return Endif C C.. set pointers for current file C Curfil = Nfiles funit = unit Units(Curfil) = funit If (Nfiles.Eq.1) Then Fldofs(Curfil) = 0 Nfields = 0 Else Fldofs(Curfil) = Nfields Endif C C.. Unpack the Tracer flag C Trace = (Aksess.And.8).ne.0 If (Trace) Aksess = Aksess - 8 D If (Trace) Type *,' Rdopen> --- Trace Enabled ---' C C.. Open the data file C C..NOTE: F77 opens unformatted direct access file with double words C so Recl=128 gives effective recl of 512 bytes C RDMnam(Curfil) = fil Access(Curfil) = Aksess funit = unit C C.. readonly C IF (Aksess.Eq.0) THEN OPEN(UNIT=funit,FILE=fil,FORM='UNFORMATTED',RECL=128, 1 ACCESS='DIRECT',STATUS='OLD',READONLY) ELSE C C.. Shared / Exclusive C OPEN(UNIT=funit,FILE=fil,FORM='UNFORMATTED',RECL=128, 1 ACCESS='DIRECT',STATUS='OLD',Err=999) Ich = ILUN(funit) Ichan(Curfil) = Ich If (Access(Curfil).Eq.1) Iacs = 5 ! Shared Access If (Access(Curfil).Eq.2) Iacs = 0 ! Exclusive Access Ierr = Idclsf(Ich,Iacs) If (Ierr.NE.-1) Then C C. File Lock Error Messages C Type *,' *** Warning *** File Access Problem',bell Type *,' File # =',fil,' Code= ',Ierr If (Ierr.Eq.4) Type *,' Unable to get requested access to file' Type 1 1 Format(' Press RETURN to continue...',$) Accept 2,nb,Junk 2 Format(q,A) Stat = Ierr Return Endif ENDIF C C.. read 1st block & load preamble record C READ(funit'1) block DO 30 k=1,64 preamb(k) = block(k) 30 Continue C C.. Somebody at RDM decided to do Integer*4 Non-Standard C (The words are reversed) If this gets changed there will be C a bit in the Header block to let us all know C C.. reassemble some counters from the header C Short(1) = xRnum2 Short(2) = xRnum1 xRnum(Curfil) = Long ! number of records Short(1) = xSnum2 Short(2) = xSnum1 xSnum(Curfil) = Long ! number sorted records Hnum(Curfil) = xHnum ! number of blocks in header Short(1) = Encry2 Short(2) = Encry1 Encryp = Long Rsize(Curfil) = xRsize C C.. Starting w/ v4.0 there are now external Indexes available C. When indexes are in use, we need to know. Check the Bit in DBStat C Indexed(Curfil) = (DBStat.And.2).Ne.0 C C.. tracers display everything we just got from the header block C D If (Trace) WRITE(5,40) xRnum(Curfil),xSnum(Curfil),Dbtype,fill, D 1 xRsize,xHnum,xExtra,nFlds,xDbslv,Recoff,IndexR,Synrec,Seqord, D 2 Namord,Dellst,DBStat,Encryp,Chnged,FilFlg,SrtOrd D 40 FORMAT(/,' xRnum=',I10,' xSnum=',I10,' Dbtype=',A,' fill=',A, D 1 /,' xRsize=',I10,' xHnum=',I10,' xExtra=',I10,' NumberFields=',I10, D 2 /,' xDbslevel=',I10,' Recoffset=',A,' Indexrec=',I10,' Synrec=',I10, D 3 /' Seqorder=',I10,' Nameorder=',I10,' Delist=',I10,' DBStatus=',I10, D 4 /,' Encryption=',I10,' Changed=',L,' FillFlag=',L, D 5 /,' Sortorder=',2(/5(1X,I5))) C C.. always save the (physical) sort order in dictionary in sort(1,..) C Sort(1,Curfil) = SrtOrd(1) + fldofs(Curfil) C C.. read 2nd block, hash record and beginning of dictionary C READ(funit'2) block C C.. Load the hash buffer C DO 50 k=1,64 hashrc(k) = block(k) 50 Continue D If (Trace) WRITE(5,60) Hash D 60 FORMAT(/,' =Hash Array=', D 1/,' A=',I3,',',I3,' B=',I3,',',I3,' C=',I3,',',I3,' D=',I3,',',I3, D 2/,' E=',I3,',',I3,' F=',I3,',',I3,' G=',I3,',',I3,' H=',I3,',',I3, D 3/,' I=',I3,',',I3,' J=',I3,',',I3,' K=',I3,',',I3,' L=',I3,',',I3, D 4/,' M=',I3,',',I3,' N=',I3,',',I3,' O=',I3,',',I3,' P=',I3,',',I3, D 5/,' Q=',I3,',',I3,' R=',I3,',',I3,' S=',I3,',',I3,' T=',I3,',',I3, D 6/,' U=',I3,',',I3,' V=',I3,',',I3,' W=',I3,',',I3,' X=',I3,',',I3, D 7/,' Y=',I3,',',I3,' Z=',I3,',',I3 ) C C.. Load RecDef array with values from the dictionary declarations. C xHnum = # blocks in header (includes block for Preamble record) C block 2 to xHnum has the dictionary records (64 byte records) C DO 70 elemnt=1,52,2 !search through alphabet begrec = Hash(elemnt) !first rec. starting with letter endrec = Hash(elemnt+1) !last rec. starting with letter IF (begrec.EQ.0) GOTO 70 !no records starting with letter oldblk = 2 !already read in block 2, for RDGET C C.. Load all the fields for this hash record C DO 100 hrecno = begrec,endrec blk = (hrecno*63)/512+1 !find block number for record def C C.. Check for header bigger than specified in preamble (just for grins) C IF (blk.GT.xHnum) THEN WRITE(5,92) blk, xHnum 92 FORMAT(/,' OOPS, blkno for dictionary =',I10,' xHnum=',I10) STOP ENDIF C C.. read next block if needed C IF( blk.NE.oldblk) READ(funit'blk) block oldblk = blk !also for RDGET C C.. read dictionary record C i = 1 start = (hrecno-(blk*8-7))*64+1 DO 200 k= start,start+63 dicrec(i) = block(k) i = i + 1 200 CONTINUE C C.. tracers display dictionary record C D If (Trace) WRITE(5,95) Name,ICHAR(xSeq),DatTyp,Recfld, D 2 xDisp,ICHAR(xSort),ICHAR(xStat),Nxtseq,ICHAR(Nele), D 3 ICHAR(xLevel),ySize,ICHAR(Dfield),ICHAR(Dplace),Fstat, D 4 ICHAR(xSep1),ICHAR(xSep2),Scalrc,Prvseq,hRecno D 95 FORMAT(/,' Name=',A,' xSeq=',I10,' DatTyp=',I8,' Recfld=',I8, D 1 /' xDisp=',I8,' xSort=',I8,' xStat=',I8,' Nxtseq=',I8, D 2 ' Nele=',I8,/' xLevel=',I8,' ySize=',I8,' Dfield=',I8, D 3 ' Dplace=',I8,' Fstat=',I8,/' xSep1=',I8,' xSep2=',I8, D 4 ' Scalrc=',I8,' Prvseq=',I8,' Recno=',I3) C C.. save needed data for RDGET into RecDef C special problems with datatypes of array and record C recdef(..,5) = table entry of "next" dictionary entry C fldindx = ICHAR( xSeq ) + fldofs(Curfil) !dict sequence number If (fldindx.Gt.Maxfld) Then Stat = 6 Type *,' Rdopen> field capacity exceeded' Return Endif RecDef( fldindx, 1 ) = DatTyp RecDef( fldindx, 2 ) = xDisp RecDef( fldindx, 3 ) = ySize !save size of field RecDef( fldindx, 4 ) = ICHAR(Nele) !if array, # of elements Recdef( fldindx, 5 ) = Imax0((Nxtseq-9),0) + fldofs(Curfil) C C.. set up Translation table for Dictionary vs File Header order C. DicTab(1) = field # of Dictionary record # 10 (first header record) c (Namord+1) C DicTab((HRecno-9)+fldofs(Curfil)) = fldindx C C.. Increment the field counter C Nfields = Nfields + 1 100 CONTINUE 70 CONTINUE C C.. if primary sort field is record then C.. first field w/in record is implied sort C If ( Recdef(Sort(1,Curfil),1).Eq.5) Then Sort(2,Curfil) = Dictab( Recdef( Sort(1,Curfil), 5)) Endif C C.. Reset the Record Pointer to allow Rdnxt to read first record (# 0) C recno(Curfil) = -1 Recnum = 0 Nrec = xRnum(Curfil) D If (Trace) Type *,' on exit, Nfiles=',Nfiles,' Nfields=',Nfields Stat = 0 Return C C.. File Problem Exit Point C 999 Continue Stat = 1 Return END