module is_file ! ------------- ! 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 ! email: gginc@winternet.com ! ! 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, and runtime on 1 computer $95.00 ! MULTIPLE USE: ! level 1: 1 developer, and up to 10 runtime copies $250.00 ! level 2: up to 10 developers, and up to 100 runtime copies $850.00 ! level 3: unlimited developers, and unlimited runtime copies $7500.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 files 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. ! ------------- implicit none ! isf public functions: public :: is_file_create public :: is_file_open public :: is_file_close public :: is_get_record public :: is_put_record public :: is_replace_record public :: is_delete_record public :: is_pos_begin public :: is_pos_eof public :: is_get_next_record public :: is_get_prev_record ! isf private functions: private :: ixclean private :: delrec private :: putrec private :: split_block private :: findrec private :: next_rec private :: prev_rec private :: ext_err private :: find_unit ! pk_isidx functions: private :: pk_file_create_isidx private :: pk_file_close_isidx private :: pk_get_record_isidx private :: pk_put_record_isidx private :: pk_delete_record_isidx private :: pk_file_open_isidx private :: pk_file_rdhead_isidx private :: pk_file_wthead_isidx private :: pk_new_record_isidx private :: pk_new_rec_num_isidx ! pk_isdata functions: private :: pk_file_create_isdata private :: pk_file_close_isdata private :: pk_get_record_isdata private :: pk_put_record_isdata private :: pk_delete_record_isdata private :: pk_file_open_isdata private :: pk_file_rdhead_isdata private :: pk_file_wthead_isdata private :: pk_new_record_isdata private :: pk_new_rec_num_isdata ! ! Customize this file by entering your key(2x) and data fields below. ! type, public :: data_record_type_isdata character (len=8) :: key ! YOUR KEY GOES HERE character (len=120) :: data ! YOUR DATA GOES HERE end type data_record_type_isdata ! integer, parameter, private :: maxitbl = 50 ! block size on index file ! type, public :: data_record_type_isidx character(len=8), dimension(maxitbl) :: key !YOUR KEY HERE TOO integer, dimension(maxitbl) :: iindex integer :: ngood character(len=1) :: level end type data_record_type_isidx ! type, public :: ixtree type (ixtree), pointer :: next type (ixtree), pointer :: prev type (data_record_type_isidx), pointer :: ixrec integer :: ix_rno integer :: cur_pos end type ixtree ! type, public :: is_block_defn type (pk_block_defn_isdata), pointer :: pk_block type (pk_block_defn_isidx), pointer :: isidx_block type (data_record_type_isidx) :: master type (ixtree) :: head type (ixtree), pointer :: ixhead type (ixtree), pointer :: ixptr logical :: found end type is_block_defn ! logical, private, parameter :: clean = .true. logical, private, parameter :: is_debug = .false. ! ! Two copies of the "pkf" file data types follow: 1) _isidx 2) _isdata ! type, private:: pk_record_isidx integer :: v_d_flag type (data_record_type_isidx) :: dat end type pk_record_isidx ! type, public :: pk_block_defn_isidx 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 :: rsv3 integer :: rsv2 integer :: rsv1 logical :: writable integer :: unit integer :: hdr_len integer :: first_loc end type pk_block_defn_isidx ! type (pk_record_isidx), private :: pk_record_temp_isidx type (pk_block_defn_isidx), pointer, private :: pk_block_isidx ! type, private:: pk_record_isdata integer :: v_d_flag type (data_record_type_isdata) :: dat end type pk_record_isdata ! type, public :: pk_block_defn_isdata 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 :: rsv3 integer :: rsv2 integer :: rsv1 logical :: writable integer :: unit integer :: hdr_len integer :: first_loc end type pk_block_defn_isdata ! type (pk_record_isdata), private :: pk_record_temp_isdata type (pk_block_defn_isdata), pointer, private :: pk_block_isdata ! integer, public, parameter :: PKERR_ILLREC = - 11 integer, public, parameter :: PKERR_FILE = - 12 integer, public, parameter :: PKERR_MEM = - 13 integer, public, parameter :: PKERR_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_isdata integer, private :: last_rno_isidx integer, save, private :: extended_error ! ! contains ! ------------------------------------------------ ! public functions and subroutines ! ------------------------------------------------ subroutine is_file_create (fname, unit1, unit2, err) character (len=*), intent (in) :: fname integer, intent (in), optional :: unit1 integer, intent (in), optional :: unit2 integer, intent (out), optional :: err integer :: ijerr, ierr, jerr, irec, unitu type (pk_block_defn_isidx), pointer :: tpkblk type (data_record_type_isidx) :: master ! ijerr = 0 if (present(unit1)) then unitu = unit1 else call find_unit(unitu) end if call pk_file_create_isdata (fname, unit=unitu, err=ierr) ! write(unit=*, fmt=*) " dat file created ", ierr, unitu if (present(unit2)) then unitu = unit2 else call find_unit(unitu) end if call pk_file_create_isidx (fname, unit=unitu, err=jerr) ! write(unit=*, fmt=*) " idx file created ", jerr, unitu ijerr = abs (ierr) + abs (jerr) if (ijerr == 0) then !tpkblk => pk_file_open_isidx (fname, unit=unitu, err=ierr) ! write(unit=*,fmt=*) " IS open master index - 1" call pk_file_open_isidx (tpkblk, fname, unit=unitu) ! write(unit=*,fmt=*) " IS open master index - 2" ierr = extended_error master%level = "B" master%ngood = 0 if (clean) then master%iindex = 0 ! initialize - not really needed master%key = " " ! initialize - not really needed end if !irec = pk_new_record_isidx (tpkblk, master, jerr) call pk_new_record_isidx (tpkblk, master, irec) ! write(unit=*,fmt=*) " IS write master index ",irec if (irec /= 1) then ijerr = ijerr + 100 end if ijerr = ijerr + abs (ierr) + abs (jerr) call pk_file_close_isidx (tpkblk, ierr) ! write(unit=*,fmt=*) " IS close master index ", ierr, ijerr ijerr = ijerr + abs (ierr) end if if( present (err)) then err = ijerr end if ! write(unit=*, fmt=*) " IS master created ", ijerr return end subroutine is_file_create ! ---------------------------------------------------------- subroutine is_file_open (is_block, fname, unit1, unit2, err) ! was function is_file_open (fname, unit1, unit2, err) result (is_block) type (is_block_defn), pointer :: is_block character (len=*), intent (in) :: fname integer, intent (in), optional :: unit1 integer, intent (in), optional :: unit2 integer, intent (out), optional :: err ! integer :: ijerr, ierr, jerr, unitu ! allocate(is_block, stat=ijerr) is_block%found = .false. if (present(unit1)) then unitu = unit1 else call find_unit(unitu) end if !is_block%pk_block => & ! pk_file_open_isdata (fname, unit=unitu, err=ierr) call pk_file_open_isdata (is_block%pk_block, fname, unit=unitu) ierr = extended_error ! write(unit=*, fmt=*) " data file open ", ierr ! if (present(unit2)) then unitu = unit2 else call find_unit(unitu) end if !is_block%isidx_block => & ! pk_file_open_isidx (fname, unit=unitu, err=jerr) call pk_file_open_isidx (is_block%isidx_block, fname, unit=unitu) jerr = extended_error ! write(unit=*, fmt=*) " index file open ", jerr ! ijerr = ijerr + abs (ierr) + abs (jerr) ! is_block%head%ixrec => is_block%master is_block%ixhead => is_block%head is_block%ixptr => is_block%ixhead is_block%ixhead%ix_rno = 1 is_block%found = .false. nullify (is_block%ixhead%prev) nullify (is_block%ixhead%next) if (ijerr == 0) then call pk_get_record_isidx (is_block%isidx_block,& is_block%ixhead%ix_rno, is_block%master, ierr) ijerr = ijerr + abs (ierr) end if if (ijerr /= 0) then if(associated(is_block%pk_block)) then call pk_file_close_isdata(is_block%pk_block) end if if(associated(is_block%isidx_block)) then call pk_file_close_isidx(is_block%isidx_block) end if deallocate(is_block) else call is_pos_begin (is_block, ierr) end if ! write(unit=*, fmt=*) " data file open - exiting", ijerr if (present (err)) then err = ijerr end if return !end function is_file_open end subroutine is_file_open ! ---------------------------------------------------------- subroutine is_get_record (is_block, is_key, data_record, err) type (is_block_defn), pointer :: is_block character (len=*), intent (in) :: is_key type (data_record_type_isdata), intent (out) :: data_record integer, intent (out), optional :: err integer :: ierr, irec ! if(.not. associated(is_block)) then ierr = -100 if (present(err)) then err = ierr end if return end if is_block%ixptr => is_block%ixhead call findrec (is_block, is_key, irec) if (irec == 0) then ierr = 1 is_block%found = .false. if (present(err)) then err = ierr end if return end if is_block%found = .true. call pk_get_record_isdata (is_block%pk_block, irec, data_record, ierr) if (present(err)) then err = ierr end if return end subroutine is_get_record ! ---------------------------------------------------------- subroutine is_put_record (is_block, data_record, err) type (is_block_defn), pointer :: is_block type (data_record_type_isdata), intent (in) :: data_record integer, intent (out), optional :: err integer :: ierr, irec ! if(.not. associated(is_block)) then ierr = -100 if (present(err)) then err = ierr end if return end if ierr = 0 is_block%ixptr => is_block%ixhead call findrec (is_block, data_record%key, irec) if (irec /= 0) then ierr = 1 if (present(err)) then err = ierr end if return end if !irec = pk_new_record_isdata (is_block%pk_block, data_record, ierr) call pk_new_record_isdata (is_block%pk_block, data_record, irec) ! write(unit=*,fmt=*)" put record - ready ", irec call putrec (is_block, data_record%key, irec) if (present(err)) then err = ierr end if return end subroutine is_put_record ! ---------------------------------------------------------- subroutine is_replace_record (is_block, data_record, err) type (is_block_defn), pointer :: is_block type (data_record_type_isdata), intent(in out) :: data_record integer, intent (out), optional :: err type (data_record_type_isdata) :: trec integer :: ierr, irec ! if(.not. associated(is_block)) then ierr = -100 if (present(err)) then err = ierr end if return end if is_block%ixptr => is_block%ixhead call findrec (is_block, data_record%key, irec) if (irec == 0) then ierr = 1 if (present(err)) then err = ierr end if return end if !print*," replace - found record to replace" call pk_get_record_isdata (is_block%pk_block, irec, trec, ierr) if (ierr /= 0) then if (present(err)) then err = ierr end if return end if call pk_put_record_isdata (is_block%pk_block, irec, data_record, ierr) if (present(err)) then err = ierr end if is_block%found = .true. return end subroutine is_replace_record ! ---------------------------------------------------------- subroutine is_delete_record (is_block, is_key, err) type (is_block_defn), pointer :: is_block character (len=*), intent (in) :: is_key integer, intent (out), optional :: err integer :: ierr, irec ! if(.not. associated(is_block)) then ierr = -100 if (present(err)) then err = ierr end if return end if ierr = 0 is_block%ixptr => is_block%ixhead call findrec (is_block, is_key, irec) if (irec <= 0) then ierr = 1 if (is_debug) then write(unit=*, fmt=*) " del_rec error1 ", irec end if if (present(err)) then err = ierr end if return else call pk_delete_record_isdata (is_block%pk_block, irec, ierr) if (ierr /= 0) then if (present(err)) then err = ierr end if if (is_debug) then write(unit=*, fmt=*) " del_rec error2 ", irec, ierr end if return end if end if !print*," delete - found record to delete" call delrec (is_block) if (present(err)) then err = ierr end if ! re-establish position for next sequential op. call findrec (is_block, is_key, irec) return end subroutine is_delete_record ! ---------------------------------------------------------- subroutine is_file_close (is_block, err) type (is_block_defn), pointer :: is_block integer, intent (out), optional :: err integer :: ijerr, jerr, ierr, master_loc ! if(.not. associated(is_block)) then ierr = -100 if (present(err)) then err = ierr end if return end if is_block%ixptr => is_block%ixhead ierr = ixclean (is_block%ixptr%next) master_loc = is_block%ixhead%ix_rno !print*," close - write master at ",master_loc call pk_put_record_isidx (is_block%isidx_block, master_loc, & is_block%master, ierr) ijerr = abs (ierr) call pk_file_close_isdata (is_block%pk_block, ierr) call pk_file_close_isidx (is_block%isidx_block, jerr) ijerr = ijerr + abs (ierr) + abs (jerr) deallocate(is_block, stat=ierr) ijerr = ijerr + abs (ierr) if (present(err)) then err = ijerr end if return ! end subroutine is_file_close ! ---------------------------------------------------------- subroutine is_pos_begin (is_block, err) type (is_block_defn), pointer :: is_block integer, intent (out), optional :: err type (data_record_type_isidx), pointer :: iptr integer :: ierr, it, it_tmp ! if(.not. associated(is_block)) then ierr = -100 if (present(err)) then err = ierr end if return end if ierr = 0 is_block%ixptr => is_block%ixhead is_block%ixptr%cur_pos = 1 iptr => is_block%ixptr%ixrec do !while (iptr%level /= "B") if (iptr%level == "B" ) then exit end if it = is_block%ixptr%ixrec%iindex (1) it_tmp = -99 if (associated(is_block%ixptr%next)) then it_tmp = is_block%ixptr%next%ix_rno end if if ( .not. associated(is_block%ixptr%next) .or. & it_tmp /= it) then ! was -- & is_block%ixptr%next%ix_rno /= it) then ierr = ixclean (is_block%ixptr%next) allocate (is_block%ixptr%next, stat=ierr) is_block%ixptr%next%prev => is_block%ixptr nullify (is_block%ixptr%next%next) nullify (is_block%ixptr%next%ixrec) it = is_block%ixptr%ixrec%iindex (1) is_block%ixptr => is_block%ixptr%next is_block%ixptr%ix_rno = it allocate (is_block%ixptr%ixrec, stat=ierr) iptr => is_block%ixptr%ixrec call pk_get_record_isidx (is_block%isidx_block, it,& is_block%ixptr%ixrec, ierr) if (ierr /= 0) then if (present(err)) then err = ierr end if return end if else is_block%ixptr => is_block%ixptr%next end if iptr => is_block%ixptr%ixrec is_block%ixptr%cur_pos = 1 end do is_block%ixptr%cur_pos = 0 is_block%found = .false. if (present(err)) then err = ierr end if return end subroutine is_pos_begin ! ---------------------------------------------------------- subroutine is_pos_eof (is_block, err) type (is_block_defn), pointer :: is_block integer, intent (out), optional :: err type (data_record_type_isidx), pointer :: iptr integer :: ierr, it, it_tmp ! if(.not. associated(is_block)) then ierr = -100 if (present(err)) then err = ierr end if return end if ierr = 0 is_block%ixptr => is_block%ixhead iptr => is_block%ixptr%ixrec is_block%ixptr%cur_pos = iptr%ngood do !while (iptr%level /= "B") if ( iptr%level == "B" ) then exit end if it = iptr%iindex (iptr%ngood) it_tmp = -99 if (associated(is_block%ixptr%next)) then it_tmp = is_block%ixptr%next%ix_rno end if if ( .not. associated(is_block%ixptr%next) .or. & it_tmp /= it) then ierr = ixclean (is_block%ixptr%next) allocate (is_block%ixptr%next, stat=ierr) is_block%ixptr%next%prev => is_block%ixptr nullify (is_block%ixptr%next%next) nullify (is_block%ixptr%next%ixrec) is_block%ixptr => is_block%ixptr%next is_block%ixptr%ix_rno = it allocate (is_block%ixptr%ixrec, stat=ierr) iptr => is_block%ixptr%ixrec call pk_get_record_isidx (is_block%isidx_block, it,& is_block%ixptr%ixrec, ierr) it = is_block%ixptr%ixrec%iindex (iptr%ngood) if (ierr /= 0) then if (present(err)) then err = ierr end if return end if else is_block%ixptr => is_block%ixptr%next end if iptr => is_block%ixptr%ixrec is_block%ixptr%cur_pos = iptr%ngood end do is_block%ixptr%cur_pos = iptr%ngood + 1 is_block%found = .false. if (present(err)) then err = ierr end if return end subroutine is_pos_eof ! ---------------------------------------------------------- subroutine is_get_next_record (is_block, data_record, err) type (is_block_defn), pointer :: is_block type (data_record_type_isdata), intent (out) :: data_record integer, optional, intent (out) :: err integer :: irec integer :: ierr ! ierr = 0 if(.not. associated(is_block)) then ierr = -100 if (present(err)) then err = ierr end if return end if !irec = next_rec (is_block) call next_rec (is_block, irec) !print*," call next_rec " if (irec <= 0) then ierr = -1 if (present(err)) then err = ierr end if return end if call pk_get_record_isdata (is_block%pk_block, irec, data_record, ierr) if (present(err)) then err = ierr end if return end subroutine is_get_next_record ! ---------------------------------------------------------- subroutine is_get_prev_record (is_block, data_record, err) type (is_block_defn), pointer :: is_block type (data_record_type_isdata), intent (out) :: data_record integer, intent(out), optional :: err integer :: ierr, irec ! ierr = 0 if(.not. associated(is_block)) then ierr = -100 if (present(err)) then err = ierr end if return end if !irec = prev_rec (is_block) call prev_rec (is_block, irec) !print*," call prev_rec " if (irec <= 0) then ierr = -1 if (present(err)) then err = ierr end if return end if call pk_get_record_isdata (is_block%pk_block, irec, data_record, ierr) if (present(err)) then err = ierr end if return end subroutine is_get_prev_record ! ---------------------------------------------------------- ! private functions and subroutines ! ---------------------------------------------------------- recursive subroutine findrec (is_block, is_key, irec) type (is_block_defn), pointer :: is_block character (len=*), intent (in) :: is_key integer, intent(out) :: irec type (data_record_type_isidx), pointer :: iptr integer :: err, is, ie, it, it_tmp ! iptr => is_block%ixptr%ixrec is = 1 ie = iptr%ngood irec = 0 is_block%found = .false. ! write(unit=*,fmt=*) " findrec - start is/ie ",is,ie if (ie < is) then if (is_debug) then ! write(unit=*,fmt=*) " findrec - not found early return " end if is_block%ixptr%cur_pos = 0 return end if ! search : do it = (is+ie+1) / 2 if (is < ie) then if (is_key == iptr%key(it)) then exit search else if (is_key > iptr%key(it)) then is = it else ie = it - 1 end if else if (is == ie) then exit search else it = is exit search end if end do search ! if (it > iptr%ngood) then it = iptr%ngood end if is_block%ixptr%cur_pos = it if (iptr%level == "B") then irec = iptr%iindex (it) if (is_key == iptr%key(it)) then is_block%found = .true. return else if(it == 1 .and. is_key < iptr%key(it)) then ! key is before first value in block is_block%ixptr%cur_pos = 0 end if irec = 0 !print*," findrec - not found return " return end if ! ! write(unit=*,fmt=*)" findrec - long index chain " it = iptr%iindex (it) it_tmp = -99 if (associated(is_block%ixptr%next)) then it_tmp = is_block%ixptr%next%ix_rno end if if (associated(is_block%ixptr%next) .and. it_tmp == it) then is_block%ixptr => is_block%ixptr%next else err = ixclean (is_block%ixptr%next) allocate (is_block%ixptr%next, stat=err) nullify (is_block%ixptr%next%next) is_block%ixptr%next%prev => is_block%ixptr is_block%ixptr => is_block%ixptr%next allocate (is_block%ixptr%ixrec, stat=err) is_block%ixptr%ix_rno = it ! write(unit=*,fmt=*)" findrec - get isidx block ", it call pk_get_record_isidx (is_block%isidx_block, it, & is_block%ixptr%ixrec, err) iptr => is_block%ixptr%ixrec if (err /= 0) then return end if end if ! write(unit=*,fmt=*) " findrec recurse,is_key ", is_key call findrec (is_block, is_key, irec) ! write(unit=*,fmt=*) " findrec return - it ", irec return end subroutine findrec ! ---------------------------------------------------------- subroutine delrec (is_block) type (is_block_defn), pointer :: is_block integer :: it, itn, ng ! !print*," delrec called " ng = is_block%ixptr%ixrec%ngood it = is_block%ixptr%cur_pos if (ng > 1) then if (it /= ng) then is_block%ixptr%ixrec%iindex (it:ng-1) = & is_block%ixptr%ixrec%iindex (it+1:ng) is_block%ixptr%ixrec%key (it:ng-1) = & is_block%ixptr%ixrec%key (it+1:ng) end if end if if (clean) then is_block%ixptr%ixrec%iindex (ng) = 0 is_block%ixptr%ixrec%key (ng) = " " end if is_block%ixptr%ixrec%ngood = ng - 1 ng = ng - 1 call pk_put_record_isidx (is_block%isidx_block, & is_block%ixptr%ix_rno, is_block%ixptr%ixrec) if ( .not. associated(is_block%ixptr%prev)) then return end if ! if empty node if (ng == 0) then call pk_delete_record_isidx (is_block%isidx_block, & is_block%ixptr%ix_rno) is_block%ixptr => is_block%ixptr%prev ng = is_block%ixptr%ixrec%ngood it = is_block%ixptr%cur_pos if (is_debug) then write(unit=*,fmt=*) " delrec empty node ", it, ng end if if (ng > 1) then is_block%ixptr%ixrec%iindex (it:ng-1) = & is_block%ixptr%ixrec%iindex (it+1:ng) is_block%ixptr%ixrec%key (it:ng-1) = & is_block%ixptr%ixrec%key (it+1:ng) end if if (clean) then is_block%ixptr%ixrec%iindex (ng) = 0 is_block%ixptr%ixrec%key (ng) = " " end if is_block%ixptr%ixrec%ngood = ng - 1 ng = ng - 1 ! special case when deleteing last record on the file if (ng == 0) then is_block%ixptr%ixrec%level = "B" end if call pk_put_record_isidx (is_block%isidx_block, & is_block%ixptr%ix_rno, is_block%ixptr%ixrec) end if ! collapse index if only 1 entry, and not at the top if ((associated(is_block%ixptr%prev)) .and. (ng == 1) .and.& (is_block%ixptr%ixrec%level /= "B")) then is_block%ixptr => is_block%ixptr%prev it = is_block%ixptr%cur_pos !print*," delrec collapse node ",it is_block%ixptr%ixrec%key (it) = is_block%ixptr%next%ixrec%key(1) is_block%ixptr%ixrec%iindex (it) = is_block%ixptr%next%ixrec%iindex(1) is_block%ixptr%next%ixrec%ngood = 0 call pk_delete_record_isidx (is_block%isidx_block, & is_block%ixptr%next%ix_rno) call pk_put_record_isidx (is_block%isidx_block, & is_block%ixptr%ix_rno, is_block%ixptr%ixrec) end if ! in any case, if deleting the first index, trace back up the tree. do !while ((it == 1) .and. associated(is_block%ixptr%prev)) if (( it /= 1) .or. .not.associated(is_block%ixptr%prev)) then exit end if is_block%ixptr => is_block%ixptr%prev itn = is_block%ixptr%cur_pos !print*," delrec first node trace ",it,itn is_block%ixptr%ixrec%key (itn) = is_block%ixptr%next%ixrec%key (it) call pk_put_record_isidx (is_block%isidx_block, & is_block%ixptr%ix_rno, is_block%ixptr%ixrec) it = itn end do return end subroutine delrec ! ---------------------------------------------------------- recursive function ixclean (tptr) result (ival) ! recursive subroutine ixclean (tptr) type (ixtree), pointer :: tptr integer :: ival integer :: err ! !print*," ixclean called " if ( .not. associated(tptr)) then ival = 0 return end if if (associated(tptr%next)) then ival = ixclean (tptr%next) end if !print*," ixclean - dealloc ",tptr%cur_pos, tptr%ix_rno deallocate (tptr%ixrec, stat=err) deallocate (tptr, stat=err) ival = err return ! end subroutine ixclean end function ixclean ! ---------------------------------------------------------- subroutine putrec (is_block, is_key, iloc) type (is_block_defn), pointer :: is_block character (len=*), intent (in) :: is_key integer, intent (in) :: iloc type (data_record_type_isidx), pointer :: iptr type (ixtree), pointer :: tptr integer :: it ! ! write(unit=*,fmt=*)" putrec - ngood ",is_block%ixptr % ixrec % ngood if (is_block%ixptr%ixrec%ngood == maxitbl) then ! must split block ! write(unit=*,fmt=*) " putrec - call split block" call split_block (is_block, is_key) end if ! iptr => is_block%ixptr%ixrec !if(.not.associated(iptr)) print*," putrec - not associated" it = is_block%ixptr%cur_pos if ((it < 1) .or. ((it == 1) .and. (is_key < iptr%key(1)))) then ! write(unit=*,fmt=*)" putrec - add at beginning of block ",it,"*",is_key,"*",iptr % key(1),"*" ! add before the first entry of a block it = 1 is_block%ixptr%cur_pos = it if (iptr%ngood >= maxitbl) then stop !" error - putrec1 table full " end if if (iptr%ngood >= 1) then iptr%key (2:iptr%ngood+1) = iptr%key (1:iptr%ngood) iptr%iindex (2:iptr%ngood+1) = iptr%iindex (1:iptr%ngood) end if iptr%ngood = iptr%ngood + 1 iptr%key (1) = is_key iptr%iindex (1) = iloc ! since we have just added an entry at the beginning of the block, ! we have to trace all the way up the tree and change the first entry, ! if it is the first entry, of all the upper level blocks. tptr => is_block%ixptr do !while (associated(tptr%prev)) if ( .not.associated(tptr%prev)) then exit end if tptr => tptr%prev if (tptr%cur_pos /= 1) then exit ! no longer the first entry end if tptr%ixrec%key (1) = is_key !print*," putrec1 - write isidx at record ",tptr % ix_rno call pk_put_record_isidx (is_block%isidx_block, tptr%ix_rno,& tptr%ixrec) end do else if (iptr%ngood >= maxitbl) then stop !" error - putrec2 table full " end if ! somewhere in the middle, or at the end of a block it = it + 1 !print*," putrec - add in middle/end of block ",it is_block%ixptr%cur_pos = it if (it <= iptr%ngood) then ! not at end iptr%key (it+1:iptr%ngood+1) = iptr%key (it:iptr%ngood) iptr%iindex (it+1:iptr%ngood+1) = iptr%iindex (it:iptr%ngood) end if iptr%ngood = iptr%ngood + 1 iptr%key (it) = is_key iptr%iindex (it) = iloc end if !print*," putrec2 - write isidx at record ",is_block%ixptr % ix_rno call pk_put_record_isidx (is_block%isidx_block, & is_block%ixptr%ix_rno, iptr) ! return end subroutine putrec ! ---------------------------------------------------------- subroutine split_block (is_block, is_key) type (is_block_defn), pointer :: is_block character (len=*), intent(in) :: is_key type (data_record_type_isidx), pointer :: iptr integer :: ng, nng, ih, it, newloc, err logical :: top ! !if(.not.associated(is_block%ixptr%ixrec)) print*," split_block - not associated" main_loop: do !while (is_block%ixptr%ixrec%ngood == maxitbl) if (is_block%ixptr%ixrec%ngood /= maxitbl) then exit end if top = .not. associated (is_block%ixptr%prev) if (top) then ng = 0 else ng = is_block%ixptr%prev%ixrec%ngood end if do !while (( .not. top) .and. ng == maxitbl) if ( top .or. ng /= maxitbl ) then exit end if is_block%ixptr => is_block%ixptr%prev top = .not. associated (is_block%ixptr%prev) if (top) then ng = 0 else ng = is_block%ixptr%prev%ixrec%ngood end if end do ! if (top) then ih = maxitbl / 2 allocate (iptr, stat=err) if (err /= 0) then write(unit=*, fmt=*) " split-block memory error ", err end if iptr%ngood = ih iptr%level = is_block%ixptr%ixrec%level iptr%key (1:ih) = is_block%ixptr%ixrec%key (1:ih) iptr%iindex (1:ih) = is_block%ixptr%ixrec%iindex (1:ih) if (clean) then iptr%iindex (ih+1:maxitbl) = 0 iptr%key (ih+1:maxitbl) = " " end if !newloc = pk_new_record_isidx (is_block%isidx_block, iptr) call pk_new_record_isidx (is_block%isidx_block, iptr, newloc ) is_block%ixptr%ixrec%iindex (1) = newloc ! write(unit=*,fmt=*) " splitblock - write isidx at record ",newloc ng = is_block%ixptr%ixrec%ngood nng = ng - ih ih = ih + 1 iptr%ngood = nng iptr%key (1:nng) = is_block%ixptr%ixrec%key (ih:ng) iptr%iindex (1:nng) = is_block%ixptr%ixrec%iindex (ih:ng) ! write(unit=*,fmt=*) " splitblock - copy ",nng,ih,ng," iptr%key (nng)",iptr%key (nng) if (clean) then iptr%iindex (nng+1:maxitbl) = 0 iptr%key (nng+1:maxitbl) = " " end if is_block%ixptr%ixrec%ngood = 2 is_block%ixptr%ixrec%level = "I" is_block%ixptr%ixrec%key (2) = iptr%key (1) !newloc = pk_new_record_isidx (is_block%isidx_block, iptr) call pk_new_record_isidx (is_block%isidx_block, iptr, newloc ) ! write(unit=*,fmt=*) " splitblock - write isidx at record ",newloc is_block%ixptr%ixrec%iindex (2) = newloc if (clean) then is_block%ixptr%ixrec%iindex (3:maxitbl) = 0 is_block%ixptr%ixrec%key (3:maxitbl) = " " end if ! write(unit=*,fmt=*) " splitblock - rewrite isidx at record ",is_block%ixptr % ix_rno call pk_put_record_isidx (is_block%isidx_block, & is_block%ixptr%ix_rno, is_block%ixptr%ixrec) deallocate (iptr, stat=err) else ! not at the top. ! split block into two, guarenteed prev block has at least one space ng = is_block%ixptr%ixrec%ngood ! choice: split at (or near) insertion point. ih = max (3, min(ng-2, is_block%ixptr%cur_pos)) ! other choice: split in half. ! ih = maxitbl / 2 ! half way split allocate (iptr, stat=err) iptr%level = is_block%ixptr%ixrec%level nng = ng - ih ih = ih + 1 iptr%ngood = nng iptr%key (1:nng) = is_block%ixptr%ixrec%key (ih:ng) iptr%iindex (1:nng) = is_block%ixptr%ixrec%iindex (ih:ng) if (clean) then iptr%iindex (nng+1:maxitbl) = 0 iptr%key (nng+1:maxitbl) = " " is_block%ixptr%ixrec%iindex (ih:maxitbl) = 0 is_block%ixptr%ixrec%key (ih:maxitbl) = " " end if is_block%ixptr%ixrec%ngood = ih - 1 !print*," splitblock2 - write isidx at record ",is_block%ixptr % ix_rno call pk_put_record_isidx (is_block%isidx_block, & is_block%ixptr%ix_rno, is_block%ixptr%ixrec) !newloc = pk_new_record_isidx (is_block%isidx_block, iptr) call pk_new_record_isidx (is_block%isidx_block, iptr, newloc ) is_block%ixptr => is_block%ixptr%prev ! insert new key into previous iindex block it = is_block%ixptr%cur_pos if (is_block%ixptr%ixrec%ngood >= maxitbl) then stop !" error - splitblock table full " end if !print*," splitblock inserting at upper level ", it,is_block%ixptr%ixrec%ngood if (it == is_block%ixptr%ixrec%ngood) then ! insert at end of block - don"t have to move stuff around is_block%ixptr%ixrec%ngood = is_block%ixptr%ixrec%ngood + 1 is_block%ixptr%ixrec%key (is_block%ixptr%ixrec%ngood) = & iptr%key (1) is_block%ixptr%ixrec%iindex (is_block%ixptr%ixrec%ngood) = & newloc else ng = is_block%ixptr%ixrec%ngood it = it + 1 is_block%ixptr%ixrec%key (it+1:ng+1) = & is_block%ixptr%ixrec%key (it:ng) is_block%ixptr%ixrec%iindex (it+1:ng+1) = & is_block%ixptr%ixrec%iindex(it:ng) is_block%ixptr%ixrec%ngood = is_block%ixptr%ixrec%ngood + 1 is_block%ixptr%ixrec%key (it) = iptr%key (1) is_block%ixptr%ixrec%iindex (it) = newloc end if !print*," splitblock3 - write isidx at record ",is_block%ixptr % ix_rno call pk_put_record_isidx (is_block%isidx_block, & is_block%ixptr%ix_rno, is_block%ixptr%ixrec) deallocate (iptr, stat=err) end if ! re-establish ixtree for current record is_block%ixptr => is_block%ixhead call findrec (is_block, is_key, it) end do main_loop return end subroutine split_block ! ---------------------------------------------------------- subroutine next_rec (is_block, irec) !function next_rec (is_block) result (irec) type (is_block_defn), pointer :: is_block integer, intent(out) :: irec type (ixtree), pointer :: tptr integer :: err, it ! if (is_block%ixptr%cur_pos < is_block%ixptr%ixrec%ngood) then is_block%ixptr%cur_pos = is_block%ixptr%cur_pos + 1 irec = is_block%ixptr%ixrec%iindex (is_block%ixptr%cur_pos) is_block%found = .true. else if (is_block%ixptr%ixrec%ngood <= is_block%ixptr%cur_pos) then tptr => is_block%ixptr search : do if (associated(tptr%prev)) then tptr => tptr%prev else is_block%found = .false. irec = -1 return end if if (tptr%ixrec%ngood == tptr%cur_pos) then cycle search end if exit search end do search is_block%ixptr => tptr ! done going up the tree, now go back down err = ixclean (is_block%ixptr%next) if (err /= 0) then write(unit=*, fmt=*) " next_rec error ", err end if is_block%ixptr%cur_pos = is_block%ixptr%cur_pos + 1 do !while (is_block%ixptr%ixrec%level /= "B") if (is_block%ixptr%ixrec%level == "B") then exit end if allocate (is_block%ixptr%next, stat=err) !if(err .ne. 0) print*," next_rec err1" nullify (is_block%ixptr%next%next) nullify (is_block%ixptr%next%ixrec) is_block%ixptr%next%prev => is_block%ixptr it = is_block%ixptr%ixrec%iindex (is_block%ixptr%cur_pos) is_block%ixptr => is_block%ixptr%next is_block%ixptr%cur_pos = 1 is_block%ixptr%ix_rno = it allocate (is_block%ixptr%ixrec, stat=err) !if(err .ne. 0) print*," next_rec err2" !print*," next_rec - get record = ",it call pk_get_record_isidx (is_block%isidx_block, it,& is_block%ixptr%ixrec, err) end do irec = is_block%ixptr%ixrec%iindex (is_block%ixptr%cur_pos) is_block%found = .true. else is_block%found = .false. irec = -1 end if return !end function next_rec end subroutine next_rec ! ---------------------------------------------------------- subroutine prev_rec (is_block, irec) !function prev_rec (is_block) result (irec) type (is_block_defn), pointer :: is_block integer, intent(out) :: irec type (ixtree), pointer :: tptr integer :: err, it ! if (is_block%found) then ! write(unit=*,fmt=*) " is_block is found , cur_pos= ",is_block%ixptr%cur_pos if (is_block%ixptr%cur_pos > 1) then is_block%ixptr%cur_pos = is_block%ixptr%cur_pos - 1 irec = is_block%ixptr%ixrec%iindex (is_block%ixptr%cur_pos) return else if (is_block%ixptr%cur_pos /= 0) then tptr => is_block%ixptr traceloop : do if (associated(tptr%prev)) then tptr => tptr%prev else is_block%found = .false. irec = -1 return end if if (tptr%cur_pos == 1) then cycle traceloop end if exit traceloop end do traceloop is_block%ixptr => tptr ! done going up the tree, now go back down err = ixclean (is_block%ixptr%next) if (err /= 0) then write(unit=*, fmt=*) " prev-rec error ", err end if is_block%ixptr%cur_pos = is_block%ixptr%cur_pos - 1 do !while (is_block%ixptr%ixrec%level /= "B") if (is_block%ixptr%ixrec%level == "B") then exit end if allocate (is_block%ixptr%next, stat=err) nullify (is_block%ixptr%next%next) nullify (is_block%ixptr%next%ixrec) is_block%ixptr%next%prev => is_block%ixptr it = is_block%ixptr%ixrec%iindex (is_block%ixptr%cur_pos) is_block%ixptr => is_block%ixptr%next is_block%ixptr%ix_rno = it allocate (is_block%ixptr%ixrec, stat=err) ! write(unit=*,fmt=*)" prev_rec - get record = ",it call pk_get_record_isidx (is_block%isidx_block, it,& is_block%ixptr%ixrec, err) is_block%ixptr%cur_pos = is_block%ixptr%ixrec%ngood end do irec = is_block%ixptr%ixrec%iindex (is_block%ixptr%ixrec%ngood) is_block%found = .true. return else is_block%found = .false. irec = -1 return end if else ! is_block not found if (is_block%ixptr%cur_pos > is_block%ixptr%ixrec%ngood) then irec = is_block%ixptr%ixrec%iindex (is_block%ixptr%ixrec%ngood) is_block%ixptr%cur_pos = is_block%ixptr%ixrec%ngood else if (is_block%ixptr%cur_pos == 0) then is_block%found = .false. irec = -1 return else irec = is_block%ixptr%ixrec%iindex (is_block%ixptr%cur_pos) end if is_block%found = .true. end if return !end function prev_rec end subroutine prev_rec ! ---------------------------------------------------------- ! ! "pkf" version for _isidx ! subroutine pk_file_create_isidx (name, unit, err) character (len=*), intent (in) :: name integer, intent (in), optional :: unit integer, intent (out), optional :: err type (pk_record_isidx), pointer :: ptr_pk ! integer :: lenf integer :: ierr integer :: unitu integer :: lenhdr type (pk_block_defn_isidx), pointer :: pk_block_isidx character (len=128) :: fname integer :: krec ! ierr = 0 extended_error = 0 nullify (ptr_pk) main: do if (present(unit)) then unitu = unit else call find_unit (unitu) if (unitu <= 0) then ierr = PKERR_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=*) " i created length is ",lenf ! nullify (pk_block_isidx) allocate (pk_block_isidx) inquire (iolength=lenhdr) pk_block_isidx pk_block_isidx%name = name pk_block_isidx%copyrt = "Copyright(c) Garnatz and Grovender, Inc. 1997." pk_block_isidx%v_name = "is_filex" pk_block_isidx%v_num = 110 pk_block_isidx%num_recs = 0 pk_block_isidx%del_ptr = 0 pk_block_isidx%rec_len = lenf pk_block_isidx%num_indx = 0 pk_block_isidx%rsv1 = 0 pk_block_isidx%rsv2 = 0 pk_block_isidx%rsv3 = 0 pk_block_isidx%writable = .true. pk_block_isidx%unit = - 1 pk_block_isidx%first_loc = max (1, (lenhdr-1) /lenf+1) if(INDEX_FILE_SEPARATE) then pk_block_isidx%first_loc = 0 end if pk_block_isidx%hdr_len = lenhdr !write(unit=*,fmt=*) " created header/ first_loc ",lenhdr,pk_block_isidx % first_loc fname = trim (name) // ".ix" krec = 1 if(INDEX_FILE_SEPARATE) then fname = trim (name) // ".cti" end if open (unit=unitu, file=fname, status="unknown", access="direct", & recl=lenhdr, form="unformatted", action="readwrite", iostat=ierr) ! write(unit=*,fmt=*) " create_isidx open err ",ierr if (ierr /= 0) then extended_error = ierr ierr = PKERR_FILE exit main end if ! write (unitu, iostat=ierr, rec=1, err=98) pk_block_isidx ierr = pk_file_wthead_isidx (unitu, krec, pk_block_isidx) if (ierr /= 0) then extended_error = ierr ierr = PKERR_FILE exit main end if ! write(unit=*,fmt=*) " wthead idx err ",ierr close (unit=unitu, iostat=ierr) if (ierr /= 0) then extended_error = ierr ierr = PKERR_FILE exit main end if deallocate (pk_block_isidx, stat=ierr) if (ierr /= 0) then extended_error = ierr ierr = PKERR_MEM exit main end if exit main end do main if (present(err)) then err = ierr end if return end subroutine pk_file_create_isidx ! subroutine pk_file_open_isidx (pk_block_isidx, 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_isidx (name, unit, action) result (pk_block_isidx) character (len=*), intent (in) :: name integer, intent (in), optional :: unit character (len=*), optional, intent (in) :: action type (pk_block_defn_isidx), pointer :: pk_block_isidx ! 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 (unitu) if (unitu <= 0) then ierr = PKERR_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_isidx) allocate (pk_block_isidx, stat=ierr) if (ierr /= 0) then exit main end if inquire (iolength=lenhdr) pk_block_isidx ! open key file header and read control information fname = trim (name) // ".ix" if(INDEX_FILE_SEPARATE) then fname = trim (name) // ".cti" 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_isidx call pk_file_rdhead_isidx(unitu, 1, pk_block_isidx, ierr) if (ierr /= 0) then exit main end if pk_block_isidx%unit = unitu pk_block_isidx%name = fname close (unit=unitu, iostat=ierr) if (ierr /= 0) then exit main end if ! open data file fname = trim (name) // ".ix" open (unit=unitu, file=fname, access="direct", & recl=pk_block_isidx%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", pk_block_isidx%name return end do main ! write(unit=*,fmt=*) " open data file bad" extended_error = ierr nullify (pk_block_isidx) return end subroutine pk_file_open_isidx !end function pk_file_open_isidx ! subroutine pk_file_rdhead_isidx(unitu, irec, pk_blk, ierr) type (pk_block_defn_isidx), 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 ! write(unit=*, fmt=*) " rdhead_isidx ", irec, ierr return end subroutine pk_file_rdhead_isidx ! subroutine pk_file_close_isidx (pk_block_isidx, err) integer, intent (out), optional :: err type (pk_block_defn_isidx), pointer :: pk_block_isidx ! integer :: ierr character (len=128) :: fname ! extended_error = 0 ierr = 0 last_rno_isidx = 0 main : do if ((pk_block_isidx%unit <= 0) .or. & ( .not. pk_block_isidx%writable)) then ierr = PKERR_ILLREC exit main end if ! close data file close (unit=pk_block_isidx%unit, iostat=ierr) !, err=99) if (ierr /= 0) then ierr = PKERR_FILE exit main end if ! open, update, and close control file fname = pk_block_isidx%name open (unit=pk_block_isidx%unit, file=fname, status="old", & recl=pk_block_isidx%hdr_len, access="direct", form="unformatted", & action="readwrite", iostat=ierr) !, err=99) if (ierr /= 0) then ierr = PKERR_FILE exit main end if ierr = pk_file_wthead_isidx(pk_block_isidx%unit, 1, pk_block_isidx) ! write (unit=pk_block_isidx%unit, rec=1, iostat=ierr, err=99) & ! & pk_block_isidx close (unit=pk_block_isidx%unit, iostat=ierr) !, err=99) if (ierr /= 0) then ierr = PKERR_FILE exit main end if deallocate (pk_block_isidx, 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=*) " idx close -- ok ", ierr return end do main extended_error = ierr if (present(err)) then err = ierr end if ! write(unit=*, fmt=*) " idx close -- bad ", ierr return end subroutine pk_file_close_isidx function pk_file_wthead_isidx(unitu, irec, pk_blk) result (ierr) type (pk_block_defn_isidx), intent(in) :: pk_blk integer, intent(in) :: unitu, irec integer :: ierr ! ierr = 0 write (unit=unitu, rec=irec, iostat=ierr) pk_blk ! write(unit=*, fmt=*) " wthead_isidx ", irec, ierr return end function pk_file_wthead_isidx ! subroutine pk_get_record_isidx (pk_block_isidx, pk_rno, data_record, & err) type (pk_block_defn_isidx), pointer :: pk_block_isidx integer, intent (in) :: pk_rno type (data_record_type_isidx), 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_isidx), intent (out) :: data_record integer :: ierr ! ierr = 0 extended_error = 0 last_rno_isidx = 0 main: do if ((pk_rno <= 0) .or. (pk_rno > pk_block_isidx%num_recs)) then ierr = PKERR_ILLREC exit main end if read (unit=pk_block_isidx%unit, & rec=pk_rno+pk_block_isidx%first_loc, iostat=ierr) & pk_record_temp_isidx if (ierr /= 0) then err = PKERR_FILE exit main end if if (pk_record_temp_isidx%v_d_flag /= -1) then ierr = PKERR_ILLREC else last_rno_isidx = pk_rno data_record = pk_record_temp_isidx%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_isidx ! subroutine pk_put_record_isidx (pk_block_isidx, pk_rno, data_record, & err) type (pk_block_defn_isidx), pointer :: pk_block_isidx integer, intent (in) :: pk_rno type (data_record_type_isidx), 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_isidx%num_recs)) then ierr = PKERR_ILLREC exit main end if if( pk_rno /= last_rno_isidx ) then read (unit=pk_block_isidx%unit, & rec=pk_rno+pk_block_isidx%first_loc, iostat=ierr) & pk_record_temp_isidx if (ierr /= 0) then err = PKERR_FILE exit main end if if (pk_record_temp_isidx%v_d_flag /= -1) then ierr = PKERR_ILLREC exit main end if end if pk_record_temp_isidx%dat = data_record pk_record_temp_isidx%v_d_flag = - 1 write (unit=pk_block_isidx%unit, rec= & pk_rno+pk_block_isidx%first_loc, iostat=ierr) & pk_record_temp_isidx if (ierr /= 0) then err = PKERR_FILE exit main end if last_rno_isidx = pk_rno exit main end do main extended_error = ierr if (present(err)) then err = ierr end if return end subroutine pk_put_record_isidx ! subroutine pk_new_record_isidx (pk_block_isidx, data_record, rno) !function pk_new_record_isidx (pk_block_isidx, data_record) & ! result (rno) type (pk_block_defn_isidx), pointer :: pk_block_isidx type (data_record_type_isidx), intent (in) :: data_record integer, intent(out) :: rno ! integer :: ierr ! ierr = 0 extended_error = 0 last_rno_isidx = 0 rno = -1 main : do if (pk_block_isidx%del_ptr > 0) then rno = pk_block_isidx%del_ptr read (unit=pk_block_isidx%unit, rec= & rno+pk_block_isidx%first_loc, iostat=ierr) & pk_record_temp_isidx if (ierr /= 0) then exit main end if pk_block_isidx%del_ptr = pk_record_temp_isidx%v_d_flag else pk_block_isidx%num_recs = pk_block_isidx%num_recs + 1 rno = pk_block_isidx%num_recs end if ! pk_record_temp_isidx%v_d_flag = - 1 pk_record_temp_isidx%dat = data_record write (unit=pk_block_isidx%unit, rec= & rno+pk_block_isidx%first_loc, iostat=ierr) & pk_record_temp_isidx ! if (ierr /= 0) then exit main end if last_rno_isidx = rno exit main end do main extended_error = ierr return !end function pk_new_record_isidx end subroutine pk_new_record_isidx ! subroutine pk_new_rec_num_isidx (pk_block_isidx, rno) !function pk_new_rec_num_isidx (pk_block_isidx) result (rno) type (pk_block_defn_isidx), pointer :: pk_block_isidx integer, intent(out) :: rno ! integer :: ierr ! ierr = 0 extended_error = 0 last_rno_isidx = 0 rno = -1 main : do if (pk_block_isidx%del_ptr > 0) then rno = pk_block_isidx%del_ptr read (unit=pk_block_isidx%unit, rec= & rno+pk_block_isidx%first_loc, iostat=ierr) & pk_record_temp_isidx if (ierr /= 0) then rno = - 1 exit main end if pk_block_isidx%del_ptr = pk_record_temp_isidx%v_d_flag else pk_block_isidx%num_recs = pk_block_isidx%num_recs + 1 rno = pk_block_isidx%num_recs end if ! last_rno_isidx = rno return end do main extended_error = ierr return !end function pk_new_rec_num_isidx end subroutine pk_new_rec_num_isidx ! subroutine pk_delete_record_isidx (pk_block_isidx, pk_rno, err) type (pk_block_defn_isidx), pointer :: pk_block_isidx integer, intent (in) :: pk_rno integer, intent (out), optional :: err ! type (data_record_type_isidx) :: data_record integer :: ierr ! ierr = 0 main : do call pk_get_record_isidx (pk_block_isidx, pk_rno, data_record, ierr) if (ierr /= 0) then exit main end if pk_record_temp_isidx%v_d_flag = pk_block_isidx%del_ptr pk_block_isidx%del_ptr = pk_rno ! write (unit=pk_block_isidx%unit, rec= & pk_rno+pk_block_isidx%first_loc, iostat=ierr) & pk_record_temp_isidx 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 = PKERR_FILE end if return end subroutine pk_delete_record_isidx ! ! ---------------------------------------------------------- ! "pkf" version for _isdata ! subroutine pk_file_create_isdata (name, unit, err) character (len=*), intent (in) :: name integer, intent (in), optional :: unit integer, intent (out), optional :: err type (pk_record_isdata), pointer :: ptr_pk ! integer :: lenf integer :: ierr integer :: unitu integer :: lenhdr type (pk_block_defn_isdata), pointer :: pk_block_isdata character (len=128) :: fname integer :: krec ! ierr = 0 extended_error = 0 nullify (ptr_pk) main: do if (present(unit)) then unitu = unit else call find_unit (unitu) if (unitu <= 0) then ierr = PKERR_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=*) " d created length is ",lenf ! nullify (pk_block_isdata) allocate (pk_block_isdata) inquire (iolength=lenhdr) pk_block_isdata pk_block_isdata%name = name pk_block_isdata%copyrt = "Copyright(c) Garnatz and Grovender, Inc. 1997." pk_block_isdata%v_name = "is_filed" pk_block_isdata%v_num = 110 pk_block_isdata%num_recs = 0 pk_block_isdata%del_ptr = 0 pk_block_isdata%rec_len = lenf pk_block_isdata%num_indx = 0 pk_block_isdata%rsv1 = 0 pk_block_isdata%rsv2 = 0 pk_block_isdata%rsv3 = 0 pk_block_isdata%writable = .true. pk_block_isdata%unit = - 1 pk_block_isdata%first_loc = max (1, (lenhdr-1) /lenf+1) if(INDEX_FILE_SEPARATE) then pk_block_isdata%first_loc = 0 end if pk_block_isdata%hdr_len = lenhdr ! write(unit=*,fmt=*) " created header/ first_loc ",lenhdr,pk_block_isdata % first_loc fname = trim (name) // ".dt" krec = 1 if(INDEX_FILE_SEPARATE) then fname = trim (name) // ".cti" krec = 2 end if !pk_block_isdata%name = fname ! not needed 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_isdata ierr = pk_file_wthead_isdata (unitu, krec, pk_block_isdata) close (unit=unitu, iostat=ierr) if (ierr /= 0) then extended_error = ierr ierr = PKERR_FILE if (present(err)) then err = ierr end if exit main end if deallocate (pk_block_isdata, stat=ierr) if (ierr /= 0) then extended_error = ierr ierr = PKERR_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_isdata ! subroutine pk_file_open_isdata (pk_block_isdata, 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_isdata (name, unit, action) result (pk_block_isdata) character (len=*), intent (in) :: name integer, intent (in), optional :: unit character (len=*), optional, intent (in) :: action type (pk_block_defn_isdata), pointer :: pk_block_isdata ! integer :: ierr integer :: unitu integer :: lenhdr character (len=128) :: fname character (len=9) :: my_action integer :: krec ! extended_error = 0 main : do if (present(unit)) then unitu = unit else call find_unit (unitu) if (unitu <= 0) then ierr = PKERR_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_isdata) allocate (pk_block_isdata, stat=ierr) if (ierr /= 0) then exit main end if inquire (iolength=lenhdr) pk_block_isdata ! open key file header and read control information fname = trim (name) // ".dt" krec = 1 if(INDEX_FILE_SEPARATE) then fname = trim (name) // ".cti" krec = 2 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 ! write(unit=*,fmt=*) " open data header error ", ierr exit main end if !read (unit=unitu, rec=1, iostat=ierr, err=98) pk_block_isdata call pk_file_rdhead_isdata(unitu, krec, pk_block_isdata, ierr) if (ierr /= 0) then exit main end if pk_block_isdata%unit = unitu pk_block_isdata%name = fname close (unit=unitu, iostat=ierr) if (ierr /= 0) then ! write(unit=*,fmt=*) " close data header error ", ierr exit main end if ! open data file ! write(unit=*,fmt=*) " open data file ", pk_block_isdata%rec_len fname = trim (name) // ".dt" open (unit=unitu, file=fname, access="direct", & recl=pk_block_isdata%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_isdata) return end subroutine pk_file_open_isdata !end function pk_file_open_isdata ! subroutine pk_file_rdhead_isdata(unitu, irec, pk_blk, ierr) type (pk_block_defn_isdata), 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 ! write(unit=*, fmt=*) " rdhead_isdata ", irec, ierr return end subroutine pk_file_rdhead_isdata ! subroutine pk_file_close_isdata (pk_block_isdata, err) integer, intent (out), optional :: err type (pk_block_defn_isdata), pointer :: pk_block_isdata ! integer :: ierr, krec character (len=128) :: fname ! extended_error = 0 ierr = 0 last_rno_isdata = 0 main : do if ((pk_block_isdata%unit <= 0) .or. & ( .not. pk_block_isdata%writable)) then ierr = PKERR_ILLREC exit main end if ! close data file close (unit=pk_block_isdata%unit, iostat=ierr) !, err=99) if (ierr /= 0) then ierr = PKERR_FILE exit main end if ! open, update, and close control file fname = pk_block_isdata%name open (unit=pk_block_isdata%unit, file=fname, status="old", & recl=pk_block_isdata%hdr_len, access="direct", form="unformatted", & action="readwrite", iostat=ierr) !, err=99) if (ierr /= 0) then ! write(unit=*, fmt=*) " data close -- bad open hdr ", ierr ierr = PKERR_FILE exit main end if krec = 1 if(INDEX_FILE_SEPARATE) then krec = 2 end if ierr = pk_file_wthead_isdata(pk_block_isdata%unit, krec, pk_block_isdata) ! write (unit=pk_block_isdata%unit, rec=1, iostat=ierr, err=99) & ! & pk_block_isdata close (unit=pk_block_isdata%unit, iostat=ierr) !, err=99) if (ierr /= 0) then ! write(unit=*, fmt=*) " data close -- bad write hdr ", ierr ierr = PKERR_FILE exit main end if deallocate (pk_block_isdata, 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=*) " data close -- ok ", ierr return end do main extended_error = ierr if (present(err)) then err = ierr end if ! write(unit=*, fmt=*) " data close -- bad ", ierr return end subroutine pk_file_close_isdata function pk_file_wthead_isdata(unitu, irec, pk_blk) result (ierr) type (pk_block_defn_isdata), intent(in) :: pk_blk integer, intent(in) :: unitu, irec integer :: ierr ! ierr = 0 write (unit=unitu, rec=irec, iostat=ierr) pk_blk ! write(unit=*, fmt=*) " wthead_isdata ", irec, ierr return end function pk_file_wthead_isdata ! subroutine pk_get_record_isdata (pk_block_isdata, pk_rno, data_record, & err) type (pk_block_defn_isdata), pointer :: pk_block_isdata integer, intent (in) :: pk_rno type (data_record_type_isdata), 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_isdata), intent (out) :: data_record integer :: ierr ! ierr = 0 extended_error = 0 last_rno_isdata = 0 main: do if ((pk_rno <= 0) .or. (pk_rno > pk_block_isdata%num_recs)) then ierr = PKERR_ILLREC exit main end if read (unit=pk_block_isdata%unit, & rec=pk_rno+pk_block_isdata%first_loc, iostat=ierr) & pk_record_temp_isdata if (ierr /= 0) then err = PKERR_FILE exit main end if if (pk_record_temp_isdata%v_d_flag /= -1) then ierr = PKERR_ILLREC else last_rno_isdata = pk_rno data_record = pk_record_temp_isdata%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_isdata ! subroutine pk_put_record_isdata (pk_block_isdata, pk_rno, data_record, & err) type (pk_block_defn_isdata), pointer :: pk_block_isdata integer, intent (in) :: pk_rno type (data_record_type_isdata), 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_isdata%num_recs)) then ierr = PKERR_ILLREC exit main end if if( pk_rno /= last_rno_isdata ) then read (unit=pk_block_isdata%unit, & rec=pk_rno+pk_block_isdata%first_loc, iostat=ierr) & pk_record_temp_isdata if (ierr /= 0) then err = PKERR_FILE exit main end if if (pk_record_temp_isdata%v_d_flag /= -1) then ierr = PKERR_ILLREC exit main end if end if pk_record_temp_isdata%dat = data_record pk_record_temp_isdata%v_d_flag = - 1 write (unit=pk_block_isdata%unit, rec= & pk_rno+pk_block_isdata%first_loc, iostat=ierr) & pk_record_temp_isdata if (ierr /= 0) then err = PKERR_FILE exit main end if last_rno_isdata = pk_rno exit main end do main extended_error = ierr if (present(err)) then err = ierr end if return end subroutine pk_put_record_isdata ! subroutine pk_new_record_isdata (pk_block_isdata, data_record, rno) !function pk_new_record_isdata (pk_block_isdata, data_record) & ! result (rno) type (pk_block_defn_isdata), pointer :: pk_block_isdata type (data_record_type_isdata), intent (in) :: data_record integer, intent(out) :: rno ! integer :: ierr ! ierr = 0 extended_error = 0 last_rno_isdata = 0 rno = -1 main : do if (pk_block_isdata%del_ptr > 0) then rno = pk_block_isdata%del_ptr read (unit=pk_block_isdata%unit, rec= & rno+pk_block_isdata%first_loc, iostat=ierr) & pk_record_temp_isdata if (ierr /= 0) then exit main end if pk_block_isdata%del_ptr = pk_record_temp_isdata%v_d_flag else pk_block_isdata%num_recs = pk_block_isdata%num_recs + 1 rno = pk_block_isdata%num_recs end if ! pk_record_temp_isdata%v_d_flag = - 1 pk_record_temp_isdata%dat = data_record write (unit=pk_block_isdata%unit, rec= & rno+pk_block_isdata%first_loc, iostat=ierr) & pk_record_temp_isdata ! if (ierr /= 0) then exit main end if last_rno_isdata = rno exit main end do main extended_error = ierr return !end function pk_new_record_isdata end subroutine pk_new_record_isdata ! subroutine pk_new_rec_num_isdata (pk_block_isdata, rno) !function pk_new_rec_num_isdata (pk_block_isdata) result (rno) type (pk_block_defn_isdata), pointer :: pk_block_isdata integer, intent(out) :: rno ! integer :: ierr ! ierr = 0 extended_error = 0 last_rno_isdata = 0 rno = -1 main : do if (pk_block_isdata%del_ptr > 0) then rno = pk_block_isdata%del_ptr read (unit=pk_block_isdata%unit, rec= & rno+pk_block_isdata%first_loc, iostat=ierr) & pk_record_temp_isdata if (ierr /= 0) then rno = - 1 exit main end if pk_block_isdata%del_ptr = pk_record_temp_isdata%v_d_flag else pk_block_isdata%num_recs = pk_block_isdata%num_recs + 1 rno = pk_block_isdata%num_recs end if ! last_rno_isdata = rno return end do main extended_error = ierr return !end function pk_new_rec_num_isdata end subroutine pk_new_rec_num_isdata ! subroutine pk_delete_record_isdata (pk_block_isdata, pk_rno, err) type (pk_block_defn_isdata), pointer :: pk_block_isdata integer, intent (in) :: pk_rno integer, intent (out), optional :: err ! type (data_record_type_isdata) :: data_record integer :: ierr ! ierr = 0 main : do call pk_get_record_isdata (pk_block_isdata, pk_rno, data_record, ierr) if (ierr /= 0) then exit main end if pk_record_temp_isdata%v_d_flag = pk_block_isdata%del_ptr pk_block_isdata%del_ptr = pk_rno ! write (unit=pk_block_isdata%unit, rec= & pk_rno+pk_block_isdata%first_loc, iostat=ierr) & pk_record_temp_isdata 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 = PKERR_FILE end if return end subroutine pk_delete_record_isdata ! subroutine find_unit (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 () 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. .not.tf2 .and. ierr==0) then return end if end do unitu = -1 return !end function find_unit end subroutine find_unit ! function ext_err() result (ierr) integer :: ierr ierr = extended_error return end function ext_err ! ! ---------------------------------------------------------- ! end module is_file