C This file needs to be split into two parts: pkf77.fh (next 131 lines) Cfile: pkf77.fh C! ------------ C! Copyright (C) 1995, Garnatz and Grovender, Inc. C! C! Permission to distribute this software and its documentation within C! your department or organization, is granted only under the terms C! of our Software Licensing Agreement. A fee must be paid for use C! of this software. C! C! For a copy of the Software Licensing Agreement write to: C! C! Garnatz and Grovender, Inc. C! 5301 26th Avenue South C! Minneapolis Minnesota USA 55417-1923 C! C! This general terms of the Software Licensing Agreement provide for C! distribution of this software under what is generally called a C! "shareware" agreement. If you are using this software, you are C! requested to acquire a license to use it at one of the following C! 4 levels: C! C! INDIVIDUAL USE: C! level 0: 1 developer with source, on only 1 computer $45.00 C! MULTIPLE USE: C! level 1: 1 developer, and up to 10 runtime copies $120.00 C! level 2: up to 10 developers, and up to 100 runtime copies $350.00 C! level 3: unlimited developers, and unlimited runtime copies $2500.00 C! C! Upon payment and acceptance of the Software Licensing Agreement you C! will be entitled to many benefits, including 1) updates and bugfixes C! as needed, 2) complete documentation, 3) additional utility programs to C! inquire into the status of and repair damaged files, 4)access to fee-based C! consulting and other services. C! C! This software is provided as is and Garnatz and Grovender, Inc. disclaims C! all warranties with regard to this software, including all implied warranties C! of merchantability and fitness for a particular purpose. In no event C! shall Garnatz and Grovender, Inc. be liable for any special, indirect or C! consequential damages or any damages whatsoever resulting from loss of C! use, data or profits, whether in an action of contract, negligence or C! other tortious action, arising out of or in connection with the use or C! performance of this software. C! ------------- implicit none integer v_d_flag_KEY integer last_rno_KEY integer extended_error_KEY common /pk_record_KEY_key_int/ v_d_flag_KEY & , last_rno_KEY & , extended_error_KEY C! C! Customize this file by globally replacing '_KEY' with '_yourstring' C! identifier and entering your key and data fields below. C ! your data goes here integer len1 parameter (len1=8) character*(len1) pk_record_temp_KEY_item_1 integer len2 parameter (len2=120) character*(len2) pk_record_temp_KEY_item_2 C integer len3 C parameter (len3=8) C character*(len3) pk_record_temp_KEY_item_3 C integer len4 C parameter (len4=8) C character*(len4) pk_record_temp_KEY_item_4 C common /pk_record_KEY_items/ pk_record_temp_KEY_item_1 & ,pk_record_temp_KEY_item_2 C & ,pk_record_temp_KEY_item_3 C & ,pk_record_temp_KEY_item_4 C c! also customize by calculating the length of the header and the c! data records. integer sizeof_int parameter(sizeof_int=4) C! data record length is keylen+len1+len2+...+sizeof(integer) integer lenf c parameter(lenf=132) parameter(lenf=len1+len2+sizeof_int) C! header record length is 128+128+8+12*sizeof(integer) integer lenhdr c parameter(lenhdr=264+12*4) parameter(lenhdr=264+12*sizeof_int) c character*128 pk_block_KEY_name character*128 pk_block_KEY_copyrt character*8 pk_block_KEY_v_name C common /pk_header_KEY/ pk_block_KEY_name, & pk_block_KEY_copyrt, & pk_block_KEY_v_name C integer pk_block_KEY_v_num integer pk_block_KEY_num_recs integer pk_block_KEY_del_ptr integer pk_block_KEY_rec_len integer pk_block_KEY_num_indx integer pk_block_KEY_rsv1 integer pk_block_KEY_rsv2 integer pk_block_KEY_rsv3 logical pk_block_KEY_writable integer pk_block_KEY_unit integer pk_block_KEY_first_loc integer pk_block_KEY_hdr_len C common /pk_header_KEY_int/ & pk_block_KEY_v_num, & pk_block_KEY_num_recs, & pk_block_KEY_del_ptr, & pk_block_KEY_rec_len, & pk_block_KEY_num_indx, & pk_block_KEY_rsv1, & pk_block_KEY_rsv2, & pk_block_KEY_rsv3, & pk_block_KEY_writable, & pk_block_KEY_unit, & pk_block_KEY_first_loc, & pk_block_KEY_hdr_len C! integer PKERR_ILLREC integer PKERR_FILE integer PKERR_MEM integer PKERR_NOFILE C! parameter ( PKERR_ILLREC = -11 ) parameter ( PKERR_FILE = -12 ) parameter ( PKERR_MEM = -13 ) parameter ( PKERR_NOFILE = -14 ) C! C end of file pkf77.fh C start of file pkf77.f (next 419 lines) Cmodule pk_file_KEY C! ------------- C! Copyright (C) 1995, Garnatz and Grovender, Inc. C! C! Permission to distribute this software and its documentation within C! your department or organization, is granted only under the terms C! of our Software Licensing Agreement. A fee must be paid for use C! of this software. C! C! For a copy of the Software Licensing Agreement write to: C! C! Garnatz and Grovender, Inc. C! 5301 26th Avenue South C! Minneapolis Minnesota USA 55417-1923 C! C! This general terms of the Software Licensing Agreement provide for C! distribution of this software under what is generally called a C! "shareware" agreement. If you are using this software, you are C! requested to acquire a license to use it at one of the following C! 4 levels: C! C! INDIVIDUAL USE: C! level 0: 1 developer with source, on only 1 computer $45.00 C! MULTIPLE USE: C! level 1: 1 developer, and up to 10 runtime copies $120.00 C! level 2: up to 10 developers, and up to 100 runtime copies $350.00 C! level 3: unlimited developers, and unlimited runtime copies $2500.00 C! C! Upon payment and acceptance of the Software Licensing Agreement you C! will be entitled to many benefits, including 1) updates and bugfixes C! as needed, 2) complete documentation, 3) additional utility programs to C! inquire into the status of and repair damaged files, 4)access to fee-based C! consulting and other services. C! C! This software is provided as is and Garnatz and Grovender, Inc. disclaims C! all warranties with regard to this software, including all implied warranties C! of merchantability and fitness for a particular purpose. In no event C! shall Garnatz and Grovender, Inc. be liable for any special, indirect or C! consequential damages or any damages whatsoever resulting from loss of C! use, data or profits, whether in an action of contract, negligence or C! other tortious action, arising out of or in connection with the use or C! performance of this software. C! ------------- subroutine pk_file_create_KEY (name, unit, err) include 'pkf77.fh' character*(*) name integer unit integer err C! integer ierr integer unitu integer trim_len character*128 fname C! unitu = unit extended_error_KEY = 0 pk_block_KEY_name = name pk_block_KEY_copyrt = 'Copyright(c) Garnatz and Grovender, Inc.& & 1995.' pk_block_KEY_v_name = 'pk_file7' pk_block_KEY_v_num = 72 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) pk_block_KEY_hdr_len = lenhdr ierr = 0 fname = name(1: trim_len(name)) // '.pk' open (unit=unitu, file=fname, status='new', access='direct', & & recl=lenhdr, form='unformatted', iostat=ierr, err=98) write (unitu, iostat=ierr, rec=1, err=98) & pk_block_KEY_name, & pk_block_KEY_copyrt, & pk_block_KEY_v_name, & pk_block_KEY_v_num, & pk_block_KEY_num_recs, & pk_block_KEY_del_ptr, & pk_block_KEY_rec_len, & pk_block_KEY_num_indx, & pk_block_KEY_rsv1, & pk_block_KEY_rsv2, & pk_block_KEY_rsv3, & pk_block_KEY_writable, & pk_block_KEY_unit, & pk_block_KEY_first_loc, & pk_block_KEY_hdr_len close (unitu, iostat=ierr) go to 99 98 continue extended_error_KEY = ierr ierr = PKERR_FILE 99 continue err = ierr end C! subroutine pk_file_open_KEY (name, unit, action, err) include 'pkf77.fh' character*(*) name integer unit character*(*) action integer err C integer ierr integer unitu character*128 fname character*9 my_action integer trim_len C extended_error_KEY = 0 C unitu = unit my_action = action C ierr = 0 last_rno_KEY = 0 fname = name(1: trim_len(name)) // '.pk' open (unit=unitu, file=fname, status='old', access='direct', & recl=lenhdr, form='unformatted', & iostat=ierr, err=98) if (ierr .ne. 0) go to 98 read (unit=unitu, rec=1, iostat=ierr, err=98) & pk_block_KEY_name, & pk_block_KEY_copyrt, & pk_block_KEY_v_name, & pk_block_KEY_v_num, & pk_block_KEY_num_recs, & pk_block_KEY_del_ptr, & pk_block_KEY_rec_len, & pk_block_KEY_num_indx, & pk_block_KEY_rsv1, & pk_block_KEY_rsv2, & pk_block_KEY_rsv3, & pk_block_KEY_writable, & pk_block_KEY_unit, & pk_block_KEY_first_loc, & pk_block_KEY_hdr_len pk_block_KEY_unit = unitu pk_block_KEY_name = fname pk_block_KEY_writable = .true. if(my_action .eq. 'read') then pk_block_KEY_writable = .false. end if close (unit=unitu, iostat=ierr, err=98) C! open data file C !print*, ' open data file ', pk_block_KEY_rec_len open (unit=unitu, file=fname, access='direct', & recl=pk_block_KEY_rec_len, form='unformatted', & iostat=ierr, err=98) err = ierr return 98 continue extended_error_KEY = ierr err = PKERR_FILE return 99 continue err = PKERR_MEM end C end function pk_file_open_KEY C! subroutine pk_file_close_KEY (err) include 'pkf77.fh' integer err C integer ierr integer unitu character*128 fname C extended_error_KEY = 0 ierr = 0 if (pk_block_KEY_unit .le. 0) then ierr = PKERR_ILLREC go to 97 end if C! close data file close (unit=pk_block_KEY_unit, iostat=ierr, err=99) C! open, update, and close control file if( .not. pk_block_KEY_writable) then return end if 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', & iostat=ierr, err=99) c &', action='readwrite', iostat=ierr, err=99) if (ierr .ne. 0) go to 99 unitu = pk_block_KEY_unit pk_block_KEY_unit = -1 write (unit=unitu, rec=1, iostat=ierr, err=99) & pk_block_KEY_name, & pk_block_KEY_copyrt, & pk_block_KEY_v_name, & pk_block_KEY_v_num, & pk_block_KEY_num_recs, & pk_block_KEY_del_ptr, & pk_block_KEY_rec_len, & pk_block_KEY_num_indx, & pk_block_KEY_rsv1, & pk_block_KEY_rsv2, & pk_block_KEY_rsv3, & pk_block_KEY_writable, & pk_block_KEY_unit, & pk_block_KEY_first_loc, & pk_block_KEY_hdr_len close (unit=unitu, iostat=ierr, err=99) 97 continue err = ierr return 99 continue extended_error_KEY = ierr err = PKERR_FILE end C end subroutine pk_file_close_KEY C subroutine pk_get_record_KEY (pk_rno, data_item_1 & , data_item_2, err) c & , data_item_2, data_item_3, err) c & , data_item_2, data_item_3, data_item_4, err) c include 'pkf77.fh' integer pk_rno character*(*) data_item_1 character*(*) data_item_2 c character*(*) data_item_3 c character*(*) data_item_4 integer err C integer ierr C ierr = 0 extended_error_KEY = 0 last_rno_KEY = 0 if ((pk_rno .le. 0) .or. & (pk_rno .gt. pk_block_KEY_num_recs)) then ierr = PKERR_ILLREC go to 99 end if read (unit=pk_block_KEY_unit, & rec=pk_rno+pk_block_KEY_first_loc, iostat=ierr, err=98) & v_d_flag_KEY, & data_item_1 & , data_item_2 c & , data_item_3 c & , data_item_4 c if (v_d_flag_KEY .ne. -1) then ierr = PKERR_ILLREC go to 99 end if last_rno_KEY = pk_rno go to 99 98 continue extended_error_KEY = ierr ierr = PKERR_FILE 99 continue err = ierr end C end subroutine pk_get_record_KEY C subroutine pk_put_record_KEY (pk_rno, data_item_1 & , data_item_2 c & , data_item_3 c & , data_item_4 & , err) include 'pkf77.fh' integer pk_rno character*(*) data_item_1 character*(*) data_item_2 c character*(*) data_item_3 c character*(*) data_item_4 integer err C integer ierr C ierr = 0 extended_error_KEY = 0 if ((pk_rno .le. 0) .or. & (pk_rno .gt. pk_block_KEY_num_recs)) then ierr = PKERR_ILLREC go to 99 end if if (last_rno_KEY .ne. pk_rno) then read (unit=pk_block_KEY_unit, & rec=pk_rno+pk_block_KEY_first_loc, iostat=ierr, err=98) & v_d_flag_KEY if (v_d_flag_KEY .ne. -1) then ierr = PKERR_ILLREC last_rno_KEY = 0 go to 99 end if end if write (unit=pk_block_KEY_unit, & rec = pk_rno+pk_block_KEY_first_loc, iostat=ierr, err=98) & v_d_flag_KEY, & data_item_1 & , data_item_2 c & , data_item_3 c & , data_item_4 go to 99 98 continue extended_error_KEY = ierr ierr = PKERR_FILE 99 continue err = ierr end C end subroutine pk_put_record_KEY C! integer function pk_new_record_KEY (data_item_1 & , data_item_2, err) C & , err) C & , data_item_2, data_item_3, err) C & , data_item_2, data_item_3, data_item_4 ,err) include 'pkf77.fh' character*(*) data_item_1 character*(*) data_item_2 c character*(*) data_item_3 c character*(*) data_item_4 integer err C integer rno integer ierr C ierr = 0 extended_error_KEY = 0 last_rno_KEY = 0 if (pk_block_KEY_del_ptr .gt. 0) then rno = pk_block_KEY_del_ptr read (unit=pk_block_KEY_unit, rec= & rno+pk_block_KEY_first_loc, iostat=ierr, err=99) & v_d_flag_KEY, & pk_record_temp_KEY_item_1 & , pk_record_temp_KEY_item_2 c & , pk_record_temp_KEY_item_3 c & , pk_record_temp_KEY_item_4 if (ierr .ne. 0) then rno = -1 go to 99 end if pk_block_KEY_del_ptr = v_d_flag_KEY else pk_block_KEY_num_recs = pk_block_KEY_num_recs + 1 rno = pk_block_KEY_num_recs end if C v_d_flag_KEY = -1 pk_record_temp_KEY_item_1 = data_item_1 pk_record_temp_KEY_item_2 = data_item_2 c pk_record_temp_KEY_item_3 = data_item_3 c pk_record_temp_KEY_item_4 = data_item_4 write (unit=pk_block_KEY_unit, & rec=rno+pk_block_KEY_first_loc, iostat=ierr, err=99) & v_d_flag_KEY, & pk_record_temp_KEY_item_1 & , pk_record_temp_KEY_item_2 c & , pk_record_temp_KEY_item_3 c & , pk_record_temp_KEY_item_4 C err = ierr pk_new_record_KEY = rno return 99 continue extended_error_KEY = ierr err = PKERR_FILE pk_new_record_KEY = rno end C end function pk_new_record_KEY C! subroutine pk_delete_record_KEY (pk_rno, err) include 'pkf77.fh' integer pk_rno integer err C integer ierr C ierr = 0 last_rno_KEY = 0 call pk_get_record_KEY (pk_rno, & pk_record_temp_KEY_item_1, pk_record_temp_KEY_item_2, c & pk_record_temp_KEY_item_3, pk_record_temp_KEY_item_4, & ierr) if (ierr .ne. 0) go to 99 v_d_flag_KEY = pk_block_KEY_del_ptr pk_block_KEY_del_ptr = pk_rno C write (unit=pk_block_KEY_unit, rec= & pk_rno+pk_block_KEY_first_loc, iostat=ierr, err=99) & v_d_flag_KEY err = ierr return 99 continue extended_error_KEY = ierr err = PKERR_FILE end C end subroutine pk_delete_record_KEY C! integer function ext_err_KEY() include 'pkf77.fh' ext_err_KEY = extended_error_KEY end C end function ext_err_KEY C! integer function trim_len(ch) character*(*) ch l = len(ch) do 120 i=l,1,-1 if(ch(i:i) .ne. ' ') then trim_len = i return end if 120 continue trim_len = 0 end Cend module pk_file_KEY C end of file pkf77.f