module hk_file_KEY ! Copyright (C) 1995, 1997 Garnatz and Grovender, Inc. ! ! Permission to distribute this software and its documentation within ! your department or organization, is granted only under the terms ! of our Software Licensing Agreement. A fee must be paid for use ! of this software. ! ! For a copy of the Software Licensing Agreement write to: ! ! Garnatz and Grovender, Inc. ! 5301 26th Avenue South ! Minneapolis Minnesota USA 55417-1923 ! ! This general terms of the Software Licensing Agreement provide for ! distribution of this software under what is generally called a ! "shareware" agreement. If you are using this software, you are ! requested to acquire a license to use it at one of the following ! 4 levels: ! ! INDIVIDUAL USE: ! level 0: 1 developer with source, on only 1 computer $45.00 ! MULTIPLE USE: ! level 1: 1 developer, and up to 10 runtime copies $120.00 ! level 2: up to 10 developers, and up to 100 runtime copies $350.00 ! level 3: unlimited developers, and unlimited runtime copies $2500.00 ! ! Upon payment and acceptance of the Software Licensing Agreement you ! will be entitled to many benefits, including 1) updates and bugfixes ! as needed, 2) complete documentation, 3) additional utility programs to ! inquire into the status of and repair damaged files, 4)access to fee-based ! consulting and other services. ! ! This software is provided as is and Garnatz and Grovender, Inc. disclaims ! all warranties with regard to this software, including all implied warranties ! of merchantability and fitness for a particular purpose. In no event ! shall Garnatz and Grovender, Inc. be liable for any special, indirect or ! consequential damages or any damages whatsoever resulting from loss of ! use, data or profits, whether in an action of contract, negligence or ! other tortious action, arising out of or in connection with the use or ! performance of this software. ! ------------- ! ! Customize this file by globally replacing "_KEY" with "_yourstring" identifier ! and entering your key and data fields below. ! implicit none ! public :: hk_file_create_KEY public :: hk_file_open_KEY public :: hk_file_close_KEY public :: hk_get_record_KEY public :: hk_put_new_record_KEY public :: hk_delete_record_KEY private :: hk_binary_search private :: hk_hash private :: pk_file_hkf_nhash ! private :: pk_file_create_hkf private :: pk_file_close_hkf private :: pk_get_record_hkf private :: pk_put_record_hkf private :: pk_delete_record_hkf private :: pk_file_open_hkf private :: pk_file_rdhead_hkf private :: pk_file_wthead_hkf private :: pk_new_record_hkf private :: pk_new_rec_num_hkf private :: find_unit_hkf public :: ext_err_hkf ! ! integer, parameter, private :: max_hk = 16 ! type, public :: data_record_type_KEY ! ! your key goes here character (len=8), dimension(max_hk) :: key ! ! your data goes here character (len=120), dimension(max_hk) :: your_data ! ! end of your data integer :: number_good integer :: overfl_block end type data_record_type_KEY ! type, public :: hk_record integer :: v_d_flag type (data_record_type_KEY) :: dat end type hk_record ! private hk_record ! type, public :: pk_block_defn_hkf character (len=128) :: name character (len=8) :: v_name integer :: v_num character (len=48) :: copyrt integer :: num_recs integer :: del_ptr integer :: rec_len integer :: num_indx integer :: nhash integer :: rsv2 integer :: rsv1 logical :: writable integer :: unit integer :: hdr_len integer :: first_loc end type pk_block_defn_hkf ! type, public :: hk_block_defn_KEY type (pk_block_defn_hkf), pointer :: pk_block_hkf type (data_record_type_KEY) :: data_record type (hk_record) :: pk_record_temp_hkf integer :: hk_curr_rno integer :: last_rno end type hk_block_defn_KEY ! type, public:: pk_record_hkf integer :: v_d_flag type (data_record_type_KEY) :: dat end type pk_record_hkf ! type (pk_record_hkf), private :: pk_record_temp_hkf type (pk_block_defn_hkf), pointer, private :: pk_block_hkf ! integer, public, parameter :: HKERR_ILLREC = - 11 integer, public, parameter :: HKERR_FILE = - 12 integer, public, parameter :: HKERR_MEM = - 13 integer, public, parameter :: HKERR_NOFILE = - 14 !logical, private, parameter :: INDEX_FILE_SEPARATE = .false. logical, private, parameter :: INDEX_FILE_SEPARATE = .true. ! .false. optional on some systems, like Cray and F compilers ! allows header to be at the beginning of the data file ! .true. required on some systems, like elf90 compiler ! requires header to be on a separate file ! integer, private :: last_rno integer, private :: extended_error ! integer, parameter, private, dimension(0:7) :: ipri = & (/137, 71, 127, 131, 139, 149, 151, 157/) ! contains ! ------------- subroutine hk_file_create_KEY (name, rsv1, unit, err) character(len=*), intent(in) :: name integer, optional, intent(in) :: rsv1 integer, optional, intent(in) :: unit integer, optional, intent(in out) :: err ! integer :: ierr integer :: ival integer :: i type(hk_block_defn_KEY), pointer :: hk_block ! main : do call pk_file_create_hkf (name, rsv1, unit, ierr) if(ierr /= 0) then exit main end if ! ierr = 0 nullify (hk_block) allocate(hk_block, stat=ierr) if (ierr /= 0) then exit main end if call pk_file_open_hkf(hk_block%pk_block_hkf, name, unit, "readwrite") if(.not.associated(hk_block % pk_block_hkf)) then deallocate(hk_block) exit main end if do i=1,max_hk hk_block % data_record % key(i) = " " hk_block % data_record % your_data(i) = " " end do hk_block % data_record % number_good = 0 hk_block % data_record % overfl_block = 0 ! do i=1,rsv1 call pk_new_record_hkf (hk_block%pk_block_hkf, & hk_block % data_record, ival) if(ival /= i) then ! write(unit=*, fmt=*) " hkf create error ",i,ival,ierr exit main end if end do ! call pk_file_close_hkf (hk_block%pk_block_hkf, ierr) ! write(unit=*, fmt=*) "pk_create initial write done ",ierr if(ierr /= 0) then exit main end if deallocate(hk_block, stat=ierr) if(ierr /= 0) then exit main end if err = ierr extended_error = ierr return end do main extended_error = ierr ierr = HKERR_FILE err = ierr return end subroutine hk_file_create_KEY ! subroutine hk_file_open_KEY (hk_block, name, unit, action) !function hk_file_open_KEY (name, unit, action) & ! result(hk_block) character(len=*), intent(in) :: name integer, optional, intent(in) :: unit character(len=*), optional, intent(in) :: action type(hk_block_defn_KEY), pointer :: hk_block ! integer :: ierr integer :: unitu character(len=9) :: my_action ! nullify(hk_block) main : do if (present(unit)) then unitu = unit else call find_unit_hkf (unitu) if (unitu <= 0) then ierr = HKERR_NOFILE exit main end if end if ! if (present(action)) then my_action = action else my_action = "readwrite" end if ! ierr = 0 allocate(hk_block, stat=ierr) if (ierr /= 0) then exit main end if hk_block % hk_curr_rno = 0 !hk_block % pk_block_hkf => pk_file_open_hkf (name, & ! unitu, my_action) call pk_file_open_hkf(hk_block%pk_block_hkf, name, unitu, my_action) if(.not.associated(hk_block % pk_block_hkf)) then deallocate(hk_block) exit main end if ! write(unit=*, fmt=*) " open_hkf ", ierr extended_error = ierr return end do main ! errors exit to here deallocate(hk_block, stat = ierr) nullify (hk_block) extended_error = ierr return !end function hk_file_open_KEY end subroutine hk_file_open_KEY ! subroutine hk_file_close_KEY (hk_block, err) type(hk_block_defn_KEY), pointer :: hk_block integer, optional, intent(in out) :: err ! integer :: ierr ! hk_block % hk_curr_rno = 0 call pk_file_close_hkf (hk_block%pk_block_hkf, ierr) if (ierr /= 0) then if( present(err) ) then err = HKERR_FILE extended_error = ierr end if end if return end subroutine hk_file_close_KEY ! subroutine hk_get_record_KEY (hk_block, hk_key, hk_data, err) ! type(hk_block_defn_KEY), pointer :: hk_block character(len=*), intent(in) :: hk_key character(len=*), intent (in out) :: hk_data integer, optional, intent(in out) :: err ! integer :: ierr integer :: ival integer :: pk_rno ! ierr = 0 extended_error = 0 main : do pk_rno = hk_hash(hk_key, hk_block % pk_block_hkf % nhash) ! loop33 : do if(pk_rno /= hk_block % hk_curr_rno) then call pk_get_record_hkf (hk_block%pk_block_hkf, pk_rno, & hk_block % data_record, err) if(err /= 0) then exit main end if hk_block % hk_curr_rno = pk_rno end if ival = hk_binary_search(hk_key, hk_block % data_record % key, & hk_block % data_record % number_good) if (ival > 0) then ! write(unit=*,fmt=*) " get - search found ",ival hk_data = hk_block % data_record % your_data(ival) if( present(err)) then err = ierr end if return end if ! follow link to next data block if(hk_block % data_record % overfl_block /= 0) then pk_rno = hk_block % data_record % overfl_block ! write(unit=*,fmt=*) " follow link to next data block ", pk_rno cycle loop33 end if exit loop33 end do loop33 ! ierr = HKERR_ILLREC if( present(err)) then err = ierr end if return end do main ! hk_block % hk_curr_rno = 0 extended_error = ierr ierr = HKERR_FILE if( present(err)) then err = ierr end if return end subroutine hk_get_record_KEY ! subroutine hk_put_new_record_KEY (hk_block, hk_key, hk_data, err) type(hk_block_defn_KEY), pointer :: hk_block character(len=*), intent(in) :: hk_key character(len=*), intent(in) :: hk_data integer, optional, intent(in out) :: err ! integer :: ierr integer :: ival integer :: i integer :: pk_rno integer :: ispace type(hk_block_defn_KEY) :: tmp_hk_block ! ierr = 0 ispace = 0 extended_error = 0 main : do pk_rno = hk_hash(hk_key, hk_block % pk_block_hkf % nhash) loop33: do if(pk_rno /= hk_block % hk_curr_rno) then call pk_get_record_hkf (hk_block%pk_block_hkf, & pk_rno, hk_block % data_record, ierr) if(ierr /= 0) then exit main end if hk_block % hk_curr_rno = pk_rno end if if((ispace == 0) .and. & (hk_block % data_record % number_good < max_hk)) then ispace = pk_rno end if ival = hk_binary_search(hk_key, hk_block % data_record % key, & hk_block % data_record % number_good) if (ival > 0) then ierr = HKERR_ILLREC if( present(err) ) then err = ierr end if return end if ! follow link to next data block if(hk_block % data_record % overfl_block /= 0) then ! write(unit=*,fmt=*)"new-follow link to next data block ", pk_rno pk_rno = hk_block % data_record % overfl_block cycle loop33 end if exit loop33 end do loop33 ! ival = abs(ival) ! print*," put - search not found ",ival if(ival == 0) then ival = 1 else if(hk_key > hk_block % data_record % key(ival)) then ival = ival + 1 end if ! print*," put - modified ival ",ival if((pk_rno /= ispace) .or. & (hk_block % data_record % number_good >= max_hk)) then if(ispace /= 0) then pk_rno = ispace ! some space available in an earlier block if(pk_rno /= hk_block % hk_curr_rno) then call pk_get_record_hkf (hk_block%pk_block_hkf, & pk_rno, hk_block % data_record, ierr) if(ierr /= 0) then exit main end if hk_block % hk_curr_rno = pk_rno ! set position in old block ival = hk_binary_search(hk_key, hk_block%data_record%key, & hk_block % data_record % number_good) ival = abs(ival) if(ival == 0) then ival = 1 else if(hk_key > hk_block % data_record % key(ival)) then ival = ival + 1 end if ! some space available do i = hk_block % data_record % number_good,ival,-1 hk_block % data_record % key(i+1) = & hk_block % data_record % key(i) hk_block % data_record % your_data(i+1) = & hk_block % data_record % your_data(i) end do hk_block % data_record % number_good = & hk_block % data_record % number_good + 1 hk_block % data_record % key(ival) = hk_key hk_block % data_record % your_data(ival) = hk_data end if else ! no space available - allocate new overflow block tmp_hk_block % data_record % key(1) = hk_key tmp_hk_block % data_record % your_data(1) = hk_data do i=2,max_hk tmp_hk_block % data_record % key(i) = " " tmp_hk_block % data_record % your_data(i) = " " end do tmp_hk_block % data_record % number_good = 1 tmp_hk_block % data_record % overfl_block = 0 ! call pk_new_record_hkf (hk_block % pk_block_hkf, & tmp_hk_block % data_record, & hk_block % data_record % overfl_block) ! write(unit=*, fmt=*) " add overflow block -- ",pk_rno, & ! hk_key," ",hk_block % data_record % overfl_block,ierr if(ierr /= 0) then exit main end if end if else ! some space available in current block do i=hk_block % data_record % number_good,ival,-1 hk_block % data_record % key(i+1) = hk_block % data_record % key(i) hk_block % data_record % your_data(i+1) = hk_block % data_record % your_data(i) end do hk_block % data_record % number_good = hk_block % data_record % number_good + 1 hk_block % data_record % key(ival) = hk_key hk_block % data_record % your_data(ival) = hk_data end if call pk_put_record_hkf (hk_block%pk_block_hkf, & pk_rno, hk_block % data_record, ierr) if(ierr /= 0) then exit main end if if( present(err)) then err = ierr end if return ! end do main ! hk_block % hk_curr_rno = 0 extended_error = ierr ierr = HKERR_FILE if( present(err)) then err = ierr end if return end subroutine hk_put_new_record_KEY ! subroutine hk_delete_record_KEY (hk_block, hk_key, err) type(hk_block_defn_KEY), pointer :: hk_block character(len=*), intent(in) :: hk_key integer, optional, intent(in out) :: err ! integer :: ierr integer :: pk_rno integer :: i integer :: ival ! ierr = 0 extended_error = 0 main : do pk_rno = hk_hash(hk_key, hk_block % pk_block_hkf % nhash) loop33: do if(pk_rno /= hk_block % hk_curr_rno) then call pk_get_record_hkf (hk_block%pk_block_hkf, & pk_rno, hk_block % data_record, err) if(err /= 0) then exit main end if hk_block % hk_curr_rno = pk_rno end if ival = hk_binary_search(hk_key, hk_block % data_record % key, & hk_block % data_record % number_good) if (ival > 0) then ! write(unit=*,fmt=*) " delete called",ival ! write(unit=*, fmt=*) " debug-delete ",ival, hk_block % data_record % number_good do i=ival, hk_block % data_record % number_good - 1 hk_block % data_record % key(i) = & hk_block % data_record % key(i+1) hk_block % data_record % your_data(i) = & hk_block % data_record % your_data(i+1) end do hk_block % data_record % number_good = & hk_block % data_record % number_good - 1 exit loop33 end if ! follow link to next data block if(hk_block % data_record % overfl_block /= 0) then pk_rno = hk_block % data_record % overfl_block cycle loop33 end if exit loop33 end do loop33 ! call pk_put_record_hkf (hk_block%pk_block_hkf, pk_rno, hk_block % data_record, err) return end do main ! hk_block % hk_curr_rno = 0 extended_error = ierr ierr = HKERR_FILE if( present(err)) then err = ierr end if return end subroutine hk_delete_record_KEY ! function hk_binary_search (hk_key, keys, nkeys) result(ival) character(len=*), intent(in) :: hk_key character(len=*), dimension(:), intent(in) :: keys integer, intent(in) :: nkeys ! integer :: ival integer :: is integer :: ie ! is = 1 ie = nkeys ival = 0 main : do if(nkeys == 0) then exit main end if loop33: do ival = (is+ie)/2 if(ie <= is) then exit main end if if(keys(ival) == hk_key) then exit main end if if(hk_key > keys(ival)) then is = ival + 1 else ie = ival end if end do loop33 end do main ! if( ival /= 0 ) then if(keys(ival) /= hk_key) then ival = -ival end if end if return end function hk_binary_search ! function hk_hash(hk_key, npr) result (ival) character(len=*), intent(in) :: hk_key integer, intent(in) :: npr integer :: ival ! integer :: il, ih, iv, i ! il = len_trim(hk_key) ih = 0 do i=1,il iv = ichar(hk_key(i:i)) ih = ih + ipri(modulo(i,8)) * (iv + i) end do ival = modulo(ih, npr) + 1 return end function hk_hash ! ! ---------------- a copy of pkf follows, slightly modified for hkf ----- ! function pk_file_hkf_nhash(hk_block) result (nhash) type(hk_block_defn_KEY), pointer :: hk_block integer :: nhash ! nhash = hk_block % pk_block_hkf % nhash return end function pk_file_hkf_nhash ! subroutine pk_file_create_hkf (name, nhash, unit, err) character (len=*), intent (in) :: name integer, intent (in) :: nhash integer, intent (in), optional :: unit integer, intent (out), optional :: err type (pk_record_hkf), pointer :: ptr_pk ! integer :: lenf integer :: ierr integer :: unitu integer :: lenhdr !type (hk_block_defn_KEY) :: hk_block type (pk_block_defn_hkf), pointer :: pk_block_hkf character (len=128) :: fname ! ierr = 0 extended_error = 0 nullify (ptr_pk) main: do if (present(unit)) then unitu = unit else call find_unit_hkf (unitu) if (unitu <= 0) then ierr = HKERR_NOFILE exit main end if end if allocate (ptr_pk) ptr_pk % v_d_flag = 0 inquire (iolength=lenf) ptr_pk deallocate (ptr_pk) ! write(unit=*,fmt=*) " created length is ",lenf ! nullify (pk_block_hkf) allocate (pk_block_hkf) inquire (iolength=lenhdr) pk_block_hkf pk_block_hkf%name = name pk_block_hkf%copyrt = "Copyright(c) Garnatz and Grovender, Inc. 1997." pk_block_hkf%v_name = "pk_file" pk_block_hkf%v_num = 110 pk_block_hkf%num_recs = 0 pk_block_hkf%del_ptr = 0 pk_block_hkf%rec_len = lenf pk_block_hkf%num_indx = 0 pk_block_hkf%rsv1 = 0 pk_block_hkf%rsv2 = 0 pk_block_hkf%nhash = nhash ! pk_block_hkf%rsv3 = 0 pk_block_hkf%writable = .true. pk_block_hkf%unit = - 1 pk_block_hkf%first_loc = max (1, (lenhdr-1) /lenf+1) if(INDEX_FILE_SEPARATE) then pk_block_hkf%first_loc = 0 end if pk_block_hkf%hdr_len = lenhdr ! write(unit=*,fmt=*) " created header/ first_loc ",lenhdr,pk_block_hkf % first_loc fname = trim (name) // ".hk" if(INDEX_FILE_SEPARATE) then fname = trim (name) // ".cth" end if open (unit=unitu, file=fname, status="new", access="direct", & recl=lenhdr, form="unformatted", action="write", iostat=ierr) ! write (unitu, iostat=ierr, rec=1, err=98) pk_block_hkf ierr = pk_file_wthead_hkf (unitu, 1, pk_block_hkf) close (unit=unitu, iostat=ierr) if (ierr /= 0) then extended_error = ierr ierr = HKERR_FILE if (present(err)) then err = ierr end if exit main end if deallocate (pk_block_hkf, stat=ierr) if (ierr /= 0) then extended_error = ierr ierr = HKERR_MEM exit main end if if (present(err)) then err = ierr end if return end do main if (present(err)) then err = ierr end if return end subroutine pk_file_create_hkf ! subroutine pk_file_open_hkf ( pk_block_hkf, name, unit, action) ! because F won't allow functions to do open/close/inquire operations ! this function has been converted into a subroutine - if you are ! using a compilier other than F, you may choose to convert it back !function pk_file_open_hkf (name, unit, action) result (pk_block_KEY) character (len=*), intent (in) :: name integer, intent (in), optional :: unit character (len=*), optional, intent (in) :: action type (pk_block_defn_hkf), pointer :: pk_block_hkf ! integer :: ierr integer :: unitu integer :: lenhdr character (len=128) :: fname character (len=9) :: my_action ! extended_error = 0 main : do if (present(unit)) then unitu = unit else call find_unit_hkf (unitu) if (unitu <= 0) then ierr = HKERR_NOFILE exit main end if end if ! if (present(action)) then my_action = action else my_action = "readwrite" end if ! ierr = 0 nullify (pk_block_hkf) allocate (pk_block_hkf, stat=ierr) if (ierr /= 0) then exit main end if inquire (iolength=lenhdr) pk_block_hkf ! open key file header and read control information fname = trim (name) // ".hk" if(INDEX_FILE_SEPARATE) then fname = trim (name) // ".cth" end if ! write(unit=*,fmt=*) " open header file ", lenhdr open (unit=unitu, file=fname, status="old", access="direct", & recl =lenhdr, form="unformatted", action=my_action, & iostat=ierr) ! , err=98) if (ierr /= 0) then exit main end if !read (unit=unitu, rec=1, iostat=ierr, err=98) pk_block_hkf call pk_file_rdhead_hkf(unitu, 1, pk_block_hkf, ierr) if (ierr /= 0) then exit main end if pk_block_hkf%unit = unitu pk_block_hkf%name = fname close (unit=unitu, iostat=ierr) if (ierr /= 0) then exit main end if ! open data file ! write(unit=*,fmt=*) " open data file ", pk_block_hkf%rec_len fname = trim (name) // ".hk" open (unit=unitu, file=fname, access="direct", & recl=pk_block_hkf%rec_len, form="unformatted", & action="readwrite", iostat=ierr, status="unknown") !, err=98) if (ierr /= 0) then exit main end if ! write(unit=*,fmt=*) " open data file ok" return end do main ! write(unit=*,fmt=*) " open data file bad" extended_error = ierr nullify (pk_block_hkf) return end subroutine pk_file_open_hkf !end function pk_file_open_hkf ! subroutine pk_file_rdhead_hkf(unitu, irec, pk_blk, ierr) type (pk_block_defn_hkf), intent(in out) :: pk_blk integer, intent(in) :: unitu, irec integer, intent(out) :: ierr ierr = 0 read (unit=unitu, rec=irec, iostat=ierr) pk_blk return end subroutine pk_file_rdhead_hkf ! subroutine pk_file_close_hkf (pk_block_hkf, err) integer, intent (out), optional :: err type (pk_block_defn_hkf), pointer :: pk_block_hkf ! integer :: ierr character (len=128) :: fname ! extended_error = 0 ierr = 0 last_rno = 0 main : do if ((pk_block_hkf%unit <= 0) .or. & ( .not. pk_block_hkf%writable)) then ierr = HKERR_ILLREC exit main end if ! close data file close (unit=pk_block_hkf%unit, iostat=ierr) !, err=99) if (ierr /= 0) then ierr = HKERR_FILE exit main end if ! open, update, and close control file fname = pk_block_hkf%name open (unit=pk_block_hkf%unit, file=fname, status="old", & recl=pk_block_hkf%hdr_len, access="direct", form="unformatted", & action="readwrite", iostat=ierr) !, err=99) if (ierr /= 0) then ierr = HKERR_FILE exit main end if ierr = pk_file_wthead_hkf(pk_block_hkf%unit, 1, pk_block_hkf) ! write (unit=pk_block_hkf%unit, rec=1, iostat=ierr, err=99) & ! & pk_block_hkf close (unit=pk_block_hkf%unit, iostat=ierr) !, err=99) if (ierr /= 0) then ierr = HKERR_FILE exit main end if deallocate (pk_block_hkf, stat=ierr) if (ierr /= 0) then ! write(unit=*, fmt=*) " deallocate error " exit main end if if (present(err)) then err = ierr end if ! write(unit=*, fmt=*) " close -- ok ", ierr exit main end do main extended_error = ierr if (present(err)) then err = ierr end if ! write(unit=*, fmt=*) " close -- bad ", ierr return end subroutine pk_file_close_hkf function pk_file_wthead_hkf(unitu, irec, pk_blk) result (ierr) type (pk_block_defn_hkf), intent(in) :: pk_blk integer, intent(in) :: unitu, irec integer :: ierr ! ierr = 0 write (unit=unitu, rec=irec, iostat=ierr) pk_blk return end function pk_file_wthead_hkf ! subroutine pk_get_record_hkf (pk_block_hkf, pk_rno, data_record, & err) type (pk_block_defn_hkf), pointer :: pk_block_hkf integer, intent (in) :: pk_rno type (data_record_type_KEY), intent (in out) :: data_record integer, intent (out), optional :: err ! lahey elf90 bug: does not allow intent(out) to be written only ! type (data_record_type_KEY), intent (out) :: data_record integer :: ierr ! ierr = 0 extended_error = 0 last_rno = 0 main: do if ((pk_rno <= 0) .or. (pk_rno > pk_block_hkf%num_recs)) then ierr = HKERR_ILLREC exit main end if read (unit=pk_block_hkf%unit, & rec=pk_rno+pk_block_hkf%first_loc, iostat=ierr) & pk_record_temp_hkf if (ierr /= 0) then err = HKERR_FILE exit main end if if (pk_record_temp_hkf%v_d_flag /= -1) then ierr = HKERR_ILLREC else last_rno = pk_rno data_record = pk_record_temp_hkf%dat end if if (present(err)) then err = ierr end if return end do main extended_error = ierr if (present(err)) then err = ierr end if return end subroutine pk_get_record_hkf ! subroutine pk_put_record_hkf (pk_block_hkf, pk_rno, data_record, & err) type (pk_block_defn_hkf), pointer :: pk_block_hkf integer, intent (in) :: pk_rno type (data_record_type_KEY), intent (in) :: data_record integer, intent (out), optional :: err ! integer :: ierr ! ierr = 0 extended_error = 0 main : do if ((pk_rno <= 0) .or. (pk_rno > pk_block_hkf%num_recs)) then ierr = HKERR_ILLREC exit main end if if( pk_rno /= last_rno ) then read (unit=pk_block_hkf%unit, & rec=pk_rno+pk_block_hkf%first_loc, iostat=ierr) & pk_record_temp_hkf if (ierr /= 0) then err = HKERR_FILE exit main end if if (pk_record_temp_hkf%v_d_flag /= -1) then ierr = HKERR_ILLREC exit main end if end if pk_record_temp_hkf%dat = data_record pk_record_temp_hkf%v_d_flag = - 1 write (unit=pk_block_hkf%unit, rec= & pk_rno+pk_block_hkf%first_loc, iostat=ierr) & pk_record_temp_hkf if (ierr /= 0) then err = HKERR_FILE exit main end if last_rno = pk_rno exit main end do main extended_error = ierr if (present(err)) then err = ierr end if return end subroutine pk_put_record_hkf ! subroutine pk_new_record_hkf (pk_block_hkf, data_record, rno) !function pk_new_record_hkf (pk_block_hkf, data_record) & ! result (rno) type (pk_block_defn_hkf), pointer :: pk_block_hkf type (data_record_type_KEY), intent (in) :: data_record integer, intent(out) :: rno ! integer :: ierr ! ierr = 0 extended_error = 0 last_rno = 0 rno = -1 main : do if (pk_block_hkf%del_ptr > 0) then rno = pk_block_hkf%del_ptr read (unit=pk_block_hkf%unit, rec= & rno+pk_block_hkf%first_loc, iostat=ierr) & pk_record_temp_hkf if (ierr /= 0) then exit main end if pk_block_hkf%del_ptr = pk_record_temp_hkf%v_d_flag else pk_block_hkf%num_recs = pk_block_hkf%num_recs + 1 rno = pk_block_hkf%num_recs end if ! pk_record_temp_hkf%v_d_flag = - 1 pk_record_temp_hkf%dat = data_record write (unit=pk_block_hkf%unit, rec= & rno+pk_block_hkf%first_loc, iostat=ierr) & pk_record_temp_hkf ! if (ierr /= 0) then exit main end if last_rno = rno exit main end do main extended_error = ierr return !end function pk_new_record_hkf end subroutine pk_new_record_hkf ! subroutine pk_new_rec_num_hkf (pk_block_hkf, rno) !function pk_new_rec_num_hkf (pk_block_hkf) result (rno) type (pk_block_defn_hkf), pointer :: pk_block_hkf integer, intent(out) :: rno ! integer :: ierr ! ierr = 0 extended_error = 0 last_rno = 0 rno = -1 main : do if (pk_block_hkf%del_ptr > 0) then rno = pk_block_hkf%del_ptr read (unit=pk_block_hkf%unit, rec= & rno+pk_block_hkf%first_loc, iostat=ierr) & pk_record_temp_hkf if (ierr /= 0) then rno = - 1 exit main end if pk_block_hkf%del_ptr = pk_record_temp_hkf%v_d_flag else pk_block_hkf%num_recs = pk_block_hkf%num_recs + 1 rno = pk_block_hkf%num_recs end if ! last_rno = rno return end do main extended_error = ierr return !end function pk_new_rec_num_hkf end subroutine pk_new_rec_num_hkf ! subroutine pk_delete_record_hkf (pk_block_hkf, pk_rno, err) type (pk_block_defn_hkf), pointer :: pk_block_hkf integer, intent (in) :: pk_rno integer, intent (out), optional :: err ! type (data_record_type_KEY) :: data_record integer :: ierr ! ierr = 0 main : do call pk_get_record_hkf (pk_block_hkf, pk_rno, data_record, ierr) if (ierr /= 0) then exit main end if pk_record_temp_hkf%v_d_flag = pk_block_hkf%del_ptr pk_block_hkf%del_ptr = pk_rno ! write (unit=pk_block_hkf%unit, rec= & pk_rno+pk_block_hkf%first_loc, iostat=ierr) & pk_record_temp_hkf if (ierr /= 0) then exit main end if if (present(err)) then err = ierr end if return end do main extended_error = ierr if (present(err)) then err = HKERR_FILE end if return end subroutine pk_delete_record_hkf ! subroutine find_unit_hkf (unitu) ! because F won't allow functions to do open/close/inquire operations ! this function has been converted into a subroutine - if you are ! using a compilier other than F, you may choose to convert it back !function find_unit_hkf () result (unitu) integer, intent(out) :: unitu ! integer :: ierr, i logical :: tf1, tf2 ! do i = 99, 1, -1 unitu = i inquire (unit=unitu, opened=tf1, exist=tf2, iostat=ierr) if ( .not. tf1 .and. tf2 .and. ierr==0) then return end if end do unitu = -1 return !end function find_unit_hkf end subroutine find_unit_hkf ! function ext_err_hkf() result (ierr) integer :: ierr ierr = extended_error return end function ext_err_hkf ! end module hk_file_KEY