module pk_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 ! 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, 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 :: pk_file_create_KEY public :: pk_file_close_KEY public :: pk_get_record_KEY public :: pk_put_record_KEY public :: pk_delete_record_KEY public :: pk_file_open_KEY private :: pk_file_rdhead_KEY private :: pk_file_wthead_KEY public :: pk_new_record_KEY private :: pk_new_rec_num_KEY public :: find_unit_KEY public :: ext_err_KEY type, public :: data_record_type_KEY ! your data goes here character (len=8) :: data_item_1 character (len=120) :: data_item_2 ! more of your data goes here end type data_record_type_KEY ! type, public:: pk_record_KEY integer :: v_d_flag type (data_record_type_KEY) :: dat end type pk_record_KEY ! type, public :: pk_block_defn_KEY 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_KEY ! type (pk_record_KEY), private :: pk_record_temp_KEY type (pk_block_defn_KEY), pointer, private :: pk_block_KEY ! 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 integer, private :: extended_error ! contains ! subroutine pk_file_create_KEY (name, unit, err) character (len=*), intent (in) :: name integer, intent (in), optional :: unit integer, intent (out), optional :: err type (pk_record_KEY), pointer :: ptr_pk ! integer :: lenf integer :: ierr integer :: unitu integer :: lenhdr type (pk_block_defn_KEY), pointer :: pk_block_KEY character (len=128) :: fname ! ierr = 0 extended_error = 0 nullify (ptr_pk) main: do if (present(unit)) then unitu = unit else call find_unit_KEY (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=*) " created length is ",lenf ! nullify (pk_block_KEY) allocate (pk_block_KEY) inquire (iolength=lenhdr) pk_block_KEY pk_block_KEY%name = name pk_block_KEY%copyrt = "Copyright(c) Garnatz and Grovender, Inc. 1997." pk_block_KEY%v_name = "pk_file" pk_block_KEY%v_num = 110 pk_block_KEY%num_recs = 0 pk_block_KEY%del_ptr = 0 pk_block_KEY%rec_len = lenf pk_block_KEY%num_indx = 0 pk_block_KEY%rsv1 = 0 pk_block_KEY%rsv2 = 0 pk_block_KEY%rsv3 = 0 pk_block_KEY%writable = .true. pk_block_KEY%unit = - 1 pk_block_KEY%first_loc = max (1, (lenhdr-1) /lenf+1) if(INDEX_FILE_SEPARATE) then pk_block_KEY%first_loc = 0 end if pk_block_KEY%hdr_len = lenhdr !write(unit=*,fmt=*) " created header/ first_loc ",lenhdr,pk_block_KEY % first_loc fname = trim (name) // ".pk" if(INDEX_FILE_SEPARATE) then fname = trim (name) // ".ctl" 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_KEY ierr = pk_file_wthead_KEY (unitu, 1, pk_block_KEY) 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_KEY, 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_KEY ! subroutine pk_file_open_KEY (pk_block_KEY, 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_KEY (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_KEY), pointer :: pk_block_KEY ! 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_KEY (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_KEY) allocate (pk_block_KEY, stat=ierr) if (ierr /= 0) then exit main end if inquire (iolength=lenhdr) pk_block_KEY ! open key file header and read control information fname = trim (name) // ".pk" if(INDEX_FILE_SEPARATE) then fname = trim (name) // ".ctl" 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_KEY call pk_file_rdhead_KEY(unitu, 1, pk_block_KEY, ierr) if (ierr /= 0) then exit main end if pk_block_KEY%unit = unitu pk_block_KEY%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_KEY%rec_len fname = trim (name) // ".pk" open (unit=unitu, file=fname, access="direct", & recl=pk_block_KEY%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_KEY) return end subroutine pk_file_open_KEY !end function pk_file_open_KEY ! subroutine pk_file_rdhead_KEY(unitu, irec, pk_blk, ierr) type (pk_block_defn_KEY), 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_KEY ! subroutine pk_file_close_KEY (pk_block_KEY, err) integer, intent (out), optional :: err type (pk_block_defn_KEY), pointer :: pk_block_KEY ! integer :: ierr character (len=128) :: fname ! extended_error = 0 ierr = 0 last_rno = 0 main : do if ((pk_block_KEY%unit <= 0) .or. & ( .not. pk_block_KEY%writable)) then ierr = PKERR_ILLREC exit main end if ! close data file close (unit=pk_block_KEY%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_KEY%name open (unit=pk_block_KEY%unit, file=fname, status="old", & recl=pk_block_KEY%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_KEY(pk_block_KEY%unit, 1, pk_block_KEY) ! write (unit=pk_block_KEY%unit, rec=1, iostat=ierr, err=99) & ! & pk_block_KEY close (unit=pk_block_KEY%unit, iostat=ierr) !, err=99) if (ierr /= 0) then ierr = PKERR_FILE exit main end if deallocate (pk_block_KEY, 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_KEY function pk_file_wthead_KEY(unitu, irec, pk_blk) result (ierr) type (pk_block_defn_KEY), 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_KEY ! subroutine pk_get_record_KEY (pk_block_KEY, pk_rno, data_record, & err) type (pk_block_defn_KEY), pointer :: pk_block_KEY 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_KEY%num_recs)) then ierr = PKERR_ILLREC exit main end if read (unit=pk_block_KEY%unit, & rec=pk_rno+pk_block_KEY%first_loc, iostat=ierr) & pk_record_temp_KEY if (ierr /= 0) then err = PKERR_FILE exit main end if if (pk_record_temp_KEY%v_d_flag /= -1) then ierr = PKERR_ILLREC else last_rno = pk_rno data_record = pk_record_temp_KEY%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_KEY ! subroutine pk_put_record_KEY (pk_block_KEY, pk_rno, data_record, & err) type (pk_block_defn_KEY), pointer :: pk_block_KEY 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_KEY%num_recs)) then ierr = PKERR_ILLREC exit main end if if( pk_rno /= last_rno ) then read (unit=pk_block_KEY%unit, & rec=pk_rno+pk_block_KEY%first_loc, iostat=ierr) & pk_record_temp_KEY if (ierr /= 0) then err = PKERR_FILE exit main end if if (pk_record_temp_KEY%v_d_flag /= -1) then ierr = PKERR_ILLREC exit main end if end if pk_record_temp_KEY%dat = data_record pk_record_temp_KEY%v_d_flag = - 1 write (unit=pk_block_KEY%unit, rec= & pk_rno+pk_block_KEY%first_loc, iostat=ierr) & pk_record_temp_KEY if (ierr /= 0) then err = PKERR_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_KEY ! subroutine pk_new_record_KEY (pk_block_KEY, data_record, rno) !function pk_new_record_KEY (pk_block_KEY, data_record) & ! result (rno) type (pk_block_defn_KEY), pointer :: pk_block_KEY 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_KEY%del_ptr > 0) then rno = pk_block_KEY%del_ptr read (unit=pk_block_KEY%unit, rec= & rno+pk_block_KEY%first_loc, iostat=ierr) & pk_record_temp_KEY if (ierr /= 0) then exit main end if pk_block_KEY%del_ptr = pk_record_temp_KEY%v_d_flag else pk_block_KEY%num_recs = pk_block_KEY%num_recs + 1 rno = pk_block_KEY%num_recs end if ! pk_record_temp_KEY%v_d_flag = - 1 pk_record_temp_KEY%dat = data_record write (unit=pk_block_KEY%unit, rec= & rno+pk_block_KEY%first_loc, iostat=ierr) & pk_record_temp_KEY ! 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_KEY end subroutine pk_new_record_KEY ! subroutine pk_new_rec_num_KEY (pk_block_KEY, rno) !function pk_new_rec_num_KEY (pk_block_KEY) result (rno) type (pk_block_defn_KEY), pointer :: pk_block_KEY integer, intent(out) :: rno ! integer :: ierr ! ierr = 0 extended_error = 0 last_rno = 0 rno = -1 main : do if (pk_block_KEY%del_ptr > 0) then rno = pk_block_KEY%del_ptr read (unit=pk_block_KEY%unit, rec= & rno+pk_block_KEY%first_loc, iostat=ierr) & pk_record_temp_KEY if (ierr /= 0) then rno = - 1 exit main end if pk_block_KEY%del_ptr = pk_record_temp_KEY%v_d_flag else pk_block_KEY%num_recs = pk_block_KEY%num_recs + 1 rno = pk_block_KEY%num_recs end if ! last_rno = rno return end do main extended_error = ierr return !end function pk_new_rec_num_KEY end subroutine pk_new_rec_num_KEY ! subroutine pk_delete_record_KEY (pk_block_KEY, pk_rno, err) type (pk_block_defn_KEY), pointer :: pk_block_KEY 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_KEY (pk_block_KEY, pk_rno, data_record, ierr) if (ierr /= 0) then exit main end if pk_record_temp_KEY%v_d_flag = pk_block_KEY%del_ptr pk_block_KEY%del_ptr = pk_rno ! write (unit=pk_block_KEY%unit, rec= & pk_rno+pk_block_KEY%first_loc, iostat=ierr) & pk_record_temp_KEY 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_KEY ! subroutine find_unit_KEY (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_KEY () 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_KEY end subroutine find_unit_KEY ! function ext_err_KEY() result (ierr) integer :: ierr ierr = extended_error return end function ext_err_KEY ! end module pk_file_KEY