dbcreate.pro

basic median filter simulation

pro dbcreate,name,newindex,newdb,maxitems,EXTERNAL=EXTERNAL, Maxentry=maxentry
;+
; NAME: 
;       DBCREATE
; PURPOSE:      
;       Create a new data base (.dbf), index (.dbx) or description (.dbh) file
; EXPLANATION:
;       A database definition (.dbd) file must already exist in the current
;       directory or in a ZDBASE directory.    The new .dbf, .dbx and/or .dbh
;       files will be written to the same directory.   So if the .dbd file is 
;       in a ZDBASE directory, then the user must have write privilege to that 
;       directory
;
; CALLING SEQUENCE:     
;       dbcreate, name,[ newindex, newdb, maxitems]  [,/EXTERNAL, MAXENTRY=]  
;
; INPUTS:       
;       name- name of the data base (with no qualifier), scalar string. 
;               The description will be read from the file "NAME".dbd 
;
; OPTIONAL INPUTS:      
;       newindex - if non-zero then a new index file is created,
;               otherwise it is assumed that changes do not affect the
;               index file. (default=0)
;       newdb - if non-zero then a new data base file (.dbf) will
;               be created. Otherwise changes are assumed not to affect
;               the file's present format.
;       maxitems - maximum number of items in data base.
;               If not supplied then the number of items is
;               limited to 200.
;
; OUTPUTS:
;       NONE.
;
; OPTIONAL INPUT KEYWORDS:       
;
;       external - If set, then the database is written with an external data
;               representation.  This allows the database files to be used on
;               any computer platform, e.g. through NFS mounts, but some
;               overhead is added to reading the files.  The default is to
;               write the data in the native format of the computer being used.
;
;               This keyword is only paid attention to if NEWDB or NEWINDEX
;               are nonzero.  Otherwise, the database is opened to find
;               out if it uses external representation or not.
;
;               Extreme caution should be used if this keyword is used with
;               only NEWINDEX set to a nonzero value.  This mode is allowed so
;               that databases written on machines which already use the
;               external data representation format, e.g. Sun workstations, to
;               be marked external so that other machines can read them.
;
;
;       MAXENTRY - positive integer giving the maximum number of entries in the
;               database (needed to adjust the size of the index file).   This
;               keyword can be used to supercede the  #maxentries line in the 
;               .dbd file (the larger of the two numbers will be used).
; PROCEDURE CALLS:      
;       GETTOK(), FIND_WITH_DEF(), HOST_TO_IEEE, ZPARCHECK
;
; RESTRICTIONS: 
;       If newdb=0 is not specified, the changes to the .dbd file can
;       not alter the length of the records in the data base file.
;       and may not alter positions of current fields in the file.
;       permissible changes are:
;               1) utilization of spares to create a item or field
;               2) change in field name(s)
;               3) respecification of index items
;               4) changes in default print formats
;               5) change in data base title
;               6) changes in pointer specification to other data
;                       data bases
;
;       !priv must be 2 or greater to execute this routine.
;
; SIDE EFFECTS:  
;       data base description file ZDBASE:name.dbh is created
;       and optionally ZDBASE:name.dbf (data file) and
;       ZDBASE.dbx (index file) if it is a new data base.
;
; REVISION HISTORY:     
;       D. Lindler, GSFC/HRS, October 1987
;       Modified:  Version 1, William Thompson, GSFC, 29 March 1994
;                  Version 2, William Thompson, GSFC/CDS (ARC), 28 May 1994
;                  Added EXTERNAL keyword.
;       Version 4, William Thompson, GSFC, 3 November 1994
;                       Modified to allow ZDBASE to be a path string.
;       8/14/95  JKF/ACC - allow EXTERNAL data for newindex OR newdb modes.
;       Make sure all databases closed before starting W. Landsman June 1997
;       Added new unsigned and 64 bit integer datatypes W. Landsman July 2001
;       Make sure to use lowercase filenames on Unix W. Landsman May 2006
;       Added MAXENTRY keyword   W. Landsman July 2006
;       Assume since V5.5, remove obsolete keywords to OPEN W. Landsman Sep2006
;       No longer required to be a ZDBASE directory  W. Landsman Feb 2008
;       Fix Feb 2008 bug when files are in current dir W. L.  May 2008
;       Fix May 2008 bug when files are not in current dir W. L. 17 Aug 2008
;-
;----------------------------------------------------------
 On_error,2                         ;Return to caller
 compile_opt idl2

if N_Params() LT 1 then begin
      print,'Syntax - dbcreate, name, [ newindex, newdb, maxitems ]'
      print,'  Input Keywords:         /EXTERNAL, MAXENTRY= '
      print,'  !PRIV must be 2 or greater to execute this routine'
      return
endif
;
; check privilege
;
if !priv LT 2 then  $
        message,'!PRIV must be 2 or greater to execute this routine'
;
; check parameters
;
zparcheck, 'DBCREATE', name, 1, 7, 0, 'Database Name'
if N_params() LT 2 then newindex = 0
if N_params() LT 3 then newdb = 0
if N_params() LT 4 then maxitems = 200
if not keyword_set(maxentry) then maxentry = 1
filename = strlowcase(strtrim(name,2))

 dbclose                         ;Close any databases already open
 ;
; open .dbd file
;
get_lun, unit                   ;get free unit number
dbdname =  find_with_def(filename+'.dbd', 'ZDBASE')
fdecomp,dbdname,disk,dir
zdir = disk+ dir 
if zdir EQ '' then cd,current=zdir
zdir = zdir + path_sep()
if not file_test(zdir,/write) then message, $
   'ERROR - must have write privileges to directory ' + zdir
openr, unit, dbdname,error=err
if err NE 0 then goto, Bad_IO
On_ioerror, BAD_IO              ;On I/O errors go to BAD_IO

;
; Decide whether or not external data representation should be used.
;   8/14/95  JKF/ACC - allow EXTERNAL data for newindex OR newdb modes.
;
if ((newindex ne 0) or (newdb ne 0)) or $
                ((file_search(zdir+ filename+'.dbh'))[0] eq '') then begin
        extern = keyword_set(external)
end else begin
        openr,tempunit,filename+'.dbh',/get_lun
        point_lun,tempunit,119
        extern = 0b
        readu,tempunit,extern
        free_lun,tempunit
endelse
;
; set up data buffers
;
names = strarr(maxitems)                        ;names of items
numvals = intarr(maxitems)+1S                   ;number of values
type = intarr(maxitems)                         ;data type
nbytes = intarr(maxitems)                       ;number of bytes in item
desc = strarr(maxitems)                         ;descriptions of items
sbyte = intarr(maxitems)                        ;starting byte position
format = strarr(maxitems)                       ;print formats
headers = strarr(3,maxitems)                    ;print headers
headers[*,*]='               '                  ;init headers
title = ''                                      ;data base title
index = intarr(maxitems)                        ;index type
pointers = strarr(maxitems)                     ;pointer array
npointers = 0
maxentries = 30000L
alloc = 100L
;
; first item is always entry number
;
names[0] = 'ENTRY'
type[0] = 3             ;longword integer
nbytes[0] = 4           ;four bytes
desc[0] = 'Entry or Record Number'
format[0] = 'I8'
headers[1,0] = 'ENTRY'
nitems = 1S             ;Short integer
nextbyte = 4            ;next byte position in record

;
; read and process input data
;
block='TITLE'                           ;assume first block is title
inputst=''
while not eof(unit) do begin            ;loop on records in the file
;
; process next line of input
;
    readf,unit,inputst
    print,inputst
    st=gettok(inputst,';')
    if strtrim(st,2) eq '' then goto,next       ;skip blank lines
    if strmid(st,0,1) eq '#' then begin
        block=strupcase(strmid(st,1,strlen(st)-1));begin new block
        goto,next
    end
;
    case strtrim(block,2) of

        'TITLE' : title=st

        'MAXENTRIES' : maxentries=long(strtrim(st,2)) > maxentry

        'ITEMS' : begin
;
;               process statement in form
;                       <itemname> <datatype> <description>
;
                item_name=" "
                item_name=strupcase(gettok(st,' '))
                st = strtrim(st, 1)
                item_type = " "
                item_type=gettok(st,' ')
                st = strtrim(st, 1)
                desc[nitems]=st
                if item_name eq '' then $
                        message,'Invalid item name',/IOERROR
                names[nitems]=gettok(item_name,'(')
                if item_name ne '' then $               ;is it a vector
                        numvals[nitems]=fix(gettok(item_name,')')) 
                if item_type eq '' then $
                  message,'Item data type not supplied for item ' + $
                          strupcase(item_name),/IOERROR
                data_type=strmid(strupcase(gettok(item_type,'*')),0,1)
                num_bytes=item_type
                if num_bytes eq '' then num_bytes='4'
                if (data_type eq 'R') or (data_type eq 'I') or $
                   (data_type eq 'U') then $
                                data_type=data_type+num_bytes
                case data_type of
                        'B' : begin & idltype= 1 & nb=1 & ff='I6' & end
                        'L' : begin & idltype= 1 & nb=1 & ff='I6' & end
                        'I2': begin & idltype= 2 & nb=2 & ff='I7' & end
                        'I4': begin & idltype= 3 & nb=4 & ff='I11' & end
                        'I8': begin & idltype= 14 & nb=8 & ff='I22' & end
                        'R4': begin & idltype= 4 & nb=4 & ff='G12.6' & end
                        'R8': begin & idltype= 5 & nb=8 & ff='G20.12' & end
                        'U2': begin & idltype= 12 & nb=2 & ff='I7' & end
                        'U4': begin & idltype= 13 & nb=4 & ff='I11' & end
                        'U8': begin & idltype= 15 & nb=8 & ff='I22' & end
                        'C' : begin
                                idltype = 7
                                nb=fix(num_bytes)
                                ff='A'+num_bytes
                              end