SUBROUTINE RDCLOS( funit ) C C funit = unit number associated with RDM file to close C C.. this version will compress the field table to reclaim field space C.. for speed, close files in the order opposite to opening C C Walt Shpuntoff Institute for Resource Management C 2666 Riva Road - Suite 360 C Annapolis, MD 21401 C (301) 266 - 9216 C Integer*2 funit,Cfile,fpoint Byte Bell,Junk Data Bell/7/ Include 'Rdmcom.for' C C.. Preserve the "Current" File settings C d Type *,' Rdclos called for unit',funit Cfile = Curfil C C.. determine the internal file number C If (Cfile.Eq.0.Or.(funit.Ne.Units(Cfile))) Then Do 10 I = 1, Nfiles Cfile = I If (funit.Eq.Units(Cfile)) Goto 20 10 Continue Type 15,Bell 15 Format(' **** Attempt to Close file that is not Open *****',/, 1 ' nice trick.....',A1,/, 2 ' Press RETURN to Continue....') Accept 18,Junk 18 Format(A1) Goto 900 Endif 20 Continue C C.. last one is simple case; reduce file & field counters C d Type *,' Rdclos> Before - Nfiles =',Nfiles,' Nfields=',Nfields If (Cfile.Eq.Nfiles) Then Nfiles = Nfiles - 1 Nfields = fldofs(Cfile) d Type *,' Rdclos> After - Nfiles =',Nfiles,' Nfields=',Nfields If (Cfile.Eq.Curfil) Curfil = 0 Goto 800 Endif C C.. compress field table C d Type *,' Rdclos> compressing field table' nremov = fldofs(Cfile + 1) - fldofs(Cfile) fpoint = fldofs(cfile) Do 600 I = fldofs(cfile+1), Nfields fpoint = fpoint + 1 do 500 J = 1, 4 recdef(fpoint,j) = recdef(i,j) 500 Continue C C.. Recdef(..,5) & Dictab() are pointers - adjust by # fields removed C recdef(fpoint,5) = recdef(i,5) - nremov Dictab(fpoint) = Dictab(i) - nremov 600 Continue C C.. Compress the file table and reduce file counter C d Type *,' Rdclos> compressing file table' Do 700 i = (Cfile+1), Nfiles Units(I-1) = Units(I) xRnum(I-1) = xRnum(I) xSnum(I-1) = xSnum(I) recno(I-1) = recno(I) Hnum(I-1) = Hnum(I) Rsize(I-1) = Rsize(I) fldofs(I-1) = fldofs(I) ichan(I-1) = ichan(I) Access(I-1) = Access(I) sort(1,I-1) = sort(1,I) sort(2,I-1) = sort(2,I) 700 Continue Nfiles = Nfiles - 1 d Type *,' Rdclos> After - Nfiles =',Nfiles,' Nfields=',Nfields C C.. The End C 800 Continue Call CLOSE( funit ) d type *,' Rdclos> unit closed #',funit 900 Continue d Type *,' Rdclos... Return' RETURN END