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