subroutine findevin *(base_name,start_time,end_time,key,from_eev,event_no, *evfile,fstart,new_month,status) c c routine finds an event in event index file given input parameters c c jens havskov dec 88 c c latest updates: c jul 94 jh : enable continous search with empty months c nov 24, 1994 : opening files changed c jan 95 : reorganizing completely so index files are not used c jan 18, 95 : bug c jan 31 96 : enable eev to go over months c mar 25 97 : stop for NEXT if end of list for local directory c see comment 25-3 c sep 5 97 : bug when deleting from index file, return with first c event to eev without reading files again C sep 11 : continue into next month also if last part of month c has no data c c feb 98 : year 2000 c sep : ------------ version 7.0 check------------------------ c 5 char base name c sep 17 : bugs with alt base, base ,,,,, to ,, c jan 4 99 : bug when going from one year to next c jan 6 one more of above c march 17 : data base logging c may 24 bmt : bug fixed (Work Directory) c jun 10 jh : modify so there can be a '-' in directory name, fstart cal. c jul 24 : improve date for index file, clean up c oct 29 jh : change base_update: convert base to upper case, do not c write if nevents=0 c march29 00 jh : allow to use year 1900 c feb 17 02 jh : give message if not allowed to update REA.LOG c mar 23 : replace seiopen with read-write 77 in log subroutines c to avoid error message 'too many files open' c jun 16 05 jh : check for error in s-file name c 2010-05-04 pv : changed some tab-formatted source line that gave warnings in f90 c 2011-05-01 jh ; added option start to key to reset s-file list c 2011-05-09 jh : search for a normal data base directory structure under any given c directory structure. c 2011-06 03 jh : fix out of range in i1 c 2012-04 27 jh : add common block for se c 2012 11 27 jh : time back to year 0000 c 2013 01 28 jh : also search for minute in d-function c 2013 02 08 jh : fix dimension problem c 2014 03 14 pv : cleanup warning c c input: base_name : Blank : local data base, also indicated by ,, c Data base name: Up to 5 letter name, thsi is the standard c seisan data base name located under REA c A file name: an index file name: c an index file is identified to have a '.' or c be longer than 5 chars and not terminated by a / c A directory name under which a normal structure is found: the c directory name must be terminated by a / c c start_time: time to find first event:c-y-m-d-hr-min-sec (7a2) c end_time : time of last event,-----------------------, if c blank default to end of month. If a local index file c is used, both start and end time can be blank, c indicating that the whole index file is used. c key : key to select event or index file update c Dxxhh : go to day xx and hour hh c in current month or in. file c #xxx : go to event #xxx ------- c also work without # c sxxx : find next event within xxx secs c next : go to next event c blank: ----------------- c back : back one event c same : same event (return) c del : delete event c ren : read in event list c start: reset s-file list to make sure files read c correspond to start date c from_eev : 0 normal operation, several months c 1 if call comes from eev, else 0 c 2 call from eev, over several months and output c c output: evfile : file name of event file found c fstart : character # start of event id c event_no : event number c new_month: indicate if a new month has been entered c 0: same month, 1: new month c status : 0: event found, key is next, # or date c 1: event not found, ----------------- c 2: end of index file, not data base c 3: end of time period c 4: next index file missing, key: next c 5: wrong time interval c 6: start time is blank when using a database, e.g. REA c 9: something fatally wrong c C implicit none c C Seisan library inserts and routines... C ====================================== C save include 'libsei.inc' ! Open file definitions include 'seidim.inc' ! Seisan dimensions integer seiclen C external sei open, ! Open file routine. & sei close, ! Close file routine. & sei code ! Error encoder. C C ============= end of list ========== C c c--- total number of event names integer total_no_events c--- events without directory info character*19 sfiles(max_index$) c--- year and month infor used with index files character*4 syear(max_index$) character*2 smonth(max_index$) c-- directory where event files are, s-files character*80 sdir c-- lenght of sdir integer slength c-- call from eev indicator integer from_eev c-- see above character*14 start_time c-- start_time at return from call character*14 old_start_time c-- same as start_time in time since 1900 double precision time1 c-- see above character*14 end_time c-- end_time at return form call character*14 old_end_time c-- same as end_time double precision time2 c-- current time double precision time,tim1,tim2 c-- maximum time difference for associating 2 events integer time_dif,old_time_dif c-- see above character*40 base_name c agency character*5 def_base c-- base_name at return from call character*40 old_base_name character*80 text c-- top directory of data base, def REA character*5 base_dir c-- dirctory separation character character*1 dchar c-- see above character*10 key c-- see above character*80 evfile c-- saved version of evfile character*80 old_evfile c-- top directory of system character*60 top_directory c-- see above integer new_month c-- see above integer status c-- date integer year,month,day c-- 1: index file/list is open, 0: not open integer index_open c-- counters integer i,j,i1,i2,q c-- start of ev id in full name string integer fstart c-- index numbers integer old_no c-- event numbers integer event_no,ev_no_wanted c-- day number in month and hour and min integer ev_day_wanted,current_day,hour_wanted,current_hour, *min_wanted,current_min, abs_min_wanted, abs_min_current c logical for existing file or not logical b_old c logical for first closing file logical first c standard or non standard data base logical standard c logical dummy logical ldummy c returned code integer code c read unit #1 integer read01 integer se_out ! if 1, call from se common /seisan_explorer/se_out ctest write(6,'(a6,1x,a5,1x,a5,1x)') ' base',base_name,old_base_name c write(6,'(1x,a,1x,3i3)') c * 'ichar base',(ichar(base_name(i:i)),i=1,3) c write(6,'(1x,a,1x,a,1x,a)')'st,ost',start_time,old_start_time c write(6,'(1x,a,1x,a,1x,a)')'et,oet',end_time,old_end_time c write(6,*)'status',status c write(6,*)' fstart', fstart ctest write(6,'(1x,a)') key c c set some defaults c c check if from se c if(se_out.ne.1) se_out=0 first = .true. call get_def_base(def_base) call dir_char(dchar) c c start from beginning c if(key(1:5).eq.'start') then index_open=0 key=' ' endif c c-- clear new month flag c new_month=0 c c top directory c call topdir(top_directory) c c find which kind of data base: if 5 letters must be a normal c type data base, if containing a . or larger than 5 letters c where last letter is noty a / must c be an index file, which is indicated by a blank base_dir. c If ,, only s-files in local directory. c c-- default is no standard data base c base_dir=base_name(1:5) if(base_name(1:5).eq.' ') base_dir=def_base c c cases where an index file is assumed indicated by base_dir = ' ' c or a file longer than 5 chars, or a . in name c if(start_time.eq.' ') base_dir=' ' i=index(base_name,' ') c c check if index file, name not terminated by a '/' which is direct acces to c a directory with structure c if(i.gt.1) then ! make sure no test if i=1, out of bounds if(i.gt.6.and.base_name(i-1:i-1).ne.'/') base_dir=' ' endif do i=1,40 if(base_name(i:i).eq.'.') base_dir=' ' enddo c c make shure a real base name has 5 non blank characters c if(base_dir(1:1).ne.' '.and.base_dir(1:2).ne.',,') then do i=2,5 if(base_dir(i:i).eq.' ') base_dir(i:i)='_' enddo endif c c case of local data base c if(base_name(1:2).eq.',,') base_dir=',, ' ! no base, local dir c c save base_dir c call put_env_base(base_dir) c c if start time has no month, put in january c if(start_time(5:6).eq.' ') start_time(5:6)='01' do i=7,14 if(start_time(i:i).eq.' ') start_time(i:i)='0' enddo c c If start time year is blank, should be first event in an index file, c or local data base (events in local directory), c then start from year 0000. If end time in that case is also blank, go to c end of file indicated by year 2099 c c write(6,*)' pv: findevin : l244: end time : ' ,end_time if(start_time(1:2).eq.' ') then if(base_dir.ne.' '.and.base_dir(1:2).ne.',,') then status=6 return else start_time(1:4)='0000' if(end_time(1:2).eq.' ') end_time(1:4)='2099' endif endif c c if end time year is blank, must be to end of month, put in c same year-month as start time c c-- end of month if(end_time(1:2).eq.' ') end_time(1:6)=start_time(1:6) c c make sure end time is to end of month, day etc if left blank c if(end_time(5:6).eq.' ') end_time(5:6)='12' if(end_time(7:8).eq.' ') then c write(6,*)' pv: findevin : end time : ' ,end_time read(end_time(1:6),'(i4,i2)',err=7354) year,month goto 7355 7354 continue write(6,*)' Something wrong with end time' status=9 return 7355 continue call month_day(year,month,day) write(end_time(7:8),'(i2)') day if(end_time(7:7).eq.' ') end_time(7:7)='0' endif if(end_time(9:10).eq.' ') end_time(9:10)='23' if(end_time(11:12).eq.' ' ) end_time(11:12)='59' if(end_time(13:14).eq.' ') end_time(13:14)='59' ctest write(6,*) end_time c c------------------------------------------------------------------------- c check if time interval or data base has changed since last call c when the index list was loaded c------------------------------------------------------------------------- c if(old_start_time.ne.start_time.or.old_end_time.ne.end_time. *or.old_base_name.ne.base_name) then if (.not. first) then continue else first = .false. end if index_open=0 endif c-- save base characteristecs if(index_open.eq.0) then old_start_time=start_time old_end_time=end_time old_base_name=base_name endif c write(6,'(1x,a,1x,a)')' base_dir',base_dir c write(6,'(1x,a,1x,a,1x,a)')' stt end t', start_time,end_time c c------------------------------------------------------------------------- c check for file list update if there is index is open c------------------------------------------------------------------------- c if((key(1:3).eq.'DEL'.or.key(1:3).eq.'REN') * .and.index_open.eq.1) then if(base_dir.ne.' ') then ! a data base write(6,'(1x,i4,1x,i2,1x,$)') year,month call sfil(sdir,slength,sfiles,max_index$, * total_no_events, se_out) c c update log file c call base_update(total_no_events,base_dir,year,month) c if(total_no_events.eq.0) then write(6,*)' No more events' status=9 index_open=0 return endif else ! an index file if(key(1:3).eq.'DEL') then total_no_events=total_no_events-1 if(total_no_events.eq.0) then ! no more write(6,*)' No more events' status=9 index_open=0 return else do i=event_no,total_no_events sfiles(i)=sfiles(i+1) smonth(i)=smonth(i+1) syear(i)=syear(i+1) enddo c c rewrite index file c call sei open(old$+warn$, ! Open a existing file. & ' ', ! Prompt file name (n/a). & base_name, ! File name & read01, ! Read unit #1 & b_old, ! Already exists? (n/a). & code) ! Returned condition if (code .ne. e_ok$) then write(6,*)' No such index file' status=9 return endif do i=1,total_no_events sdir(slength-7:slength-4)=syear(i) sdir(slength-2:slength-1)=smonth(i) write(read01,'(7x,a)') * sdir(1:slength)//sfiles(i) enddo write(read01,'(a)') ' ' call sei close (close$,read01,code) endif endif endif c c position event at event after deleted event or at first c event if that was the last c if(event_no.gt.total_no_events) event_no=1 ! at end of list if(slength.gt.0) then if(base_dir.eq.' ') then ! index file, fix year and month sdir(slength-7:slength-4)=syear(event_no) sdir(slength-2:slength-1)=smonth(event_no) endif evfile=sdir(1:slength)//sfiles(event_no) else evfile=sfiles(event_no) endif old_evfile=evfile status=0 return endif c---------------------------------------------------------------------- c get list of files if not there, first check if base or special file c---------------------------------------------------------------------- c if(index_open.eq.0) then c c first check if time interval is valid, get abs time from 0000 c call abstim(start_time,0,time1) call abstim(end_time,0,time2) if(time1.ge.time2) then write(6,*)' ********* wrong time interval *************' status=5 return endif c c-- standard type s-file data base (standard true) or a given directory c (standard false) c c write(6,*)' base_dir,base_name ',base_dir,base_name ldummy=.FALSE. 7365 continue ! to here from section of positioning (goto 1) if(base_dir.ne.' '.and.base_dir(1:2).ne.',,'.OR.ldummy) then if(ldummy) goto 7366 c i1=index(base_name,' ')-1 i1=seiclen(base_name) if(i1.le.0) i1=1 ! make sure not zero if(base_name(i1:i1).eq.'/') then standard=.false. sdir(1:i1)=base_name(1:i1) i2=i1-11 else i2=index(top_directory,' ')-1 standard=.true. sdir(1:i2)=top_directory(1:i2) sdir(i2+1:i2+1)=dchar sdir(i2+2:i2+4)='REA' sdir(i2+5:i2+5)=dchar sdir(i2+6:i2+10)=base_dir ! data base sdir(i2+11:i2+11)=dchar endif sdir(i2+12:i2+15)=start_time(1:4) ! year read(start_time(1:4),'(i4)',err=2736) year if(year.ge.2099.or.year.lt.0000) then write(6,*)'Wrong year' stop endif sdir(i2+16:i2+16)=dchar sdir(i2+17:i2+18)=start_time(5:6) ! month read(start_time(5:6),'(i2)',err=2736) month if(month.gt.12.or.month.le.0) then write(6,*)'Wrong month' stop endif sdir(i2+19:i2+19)=dchar slength=i2+19 goto 2737 2736 continue write(6,*)' Something wrong with year or month' stop 2737 continue c c get list of s-files c c write(6,*) 'call sfil' write(6,'(1x,i4,1x,i2,1x,$)') year,month call sfil(sdir,slength,sfiles,max_index$, * total_no_events,se_out) c c update log file c call base_update(total_no_events,base_dir,year,month) c c c-- flag index file is open index_open=1 c-- must be a new month new_month=1 event_no=0 c c---------------------------------------------------------------------- c check if no files, if so go to next month if c within time interval c-------------------------------------------------------------------- c 7363 continue ! get here from below in this section to check if(total_no_events.eq.0) goto 7364 goto 1 ! there was data 7364 continue write(6,'(a,i4,1x,i2)')' No data for year and month: ', * year,month 7366 continue ! to here from section of positioning (goto 1) ldummy=.FALSE. c c-- time of next month c month=month+1 if(month.eq.13) then month=1 year=year+1 endif c c get abs time from 0000 c call timsec(year,month,1,0,0,0.0,time) c-- not yet end of desired time interval if(time.lt.time2) then c-- make new sdir write(sdir(i2+12:i2+15),'(i4)') year write(sdir(i2+17:i2+18),'(i2)') month if(sdir(i2+14:i2+14).eq.' ') sdir(i2+14:i2+14)='0' if(sdir(i2+17:i2+17).eq.' ') sdir(i2+17:i2+17)='0' write(6,'(1x,i4,1x,i2,1x,$)') year,month call sfil(sdir,slength,sfiles,max_index$, * total_no_events,se_out) c c update log file c call base_update(total_no_events,base_dir,year,month) c goto 7363 ! back to check again for empty file c-- end of time interval else status=3 return endif endif ! end section s data base c c----------------------------------------------------------------------- c Files in local directory c----------------------------------------------------------------------- c if(base_dir(1:2).eq.',,') then ! local directory only do q=1,79 sdir(q:q)=' ' enddo slength=0 call sfil(sdir,slength,sfiles,max_index$, * total_no_events,se_out) c c update log file c call base_update(total_no_events,base_dir,year,month) c if(total_no_events.eq.0) then write(6,*)' No events in local directory' status=9 return endif status=0 index_open=1 new_month=1 event_no=0 endif c c--------------------------------------------------------------------- c Index file c--------------------------------------------------------------------- c if(base_dir.eq.' ') then call sei open(old$+warn$, ! Open a existing file. & ' ', ! Prompt file name (n/a). & base_name, ! File name & read01, ! Read unit #1 & b_old, ! Already exists? (n/a). & code) ! Returned condition if (code .ne. e_ok$) then write(6,*)' No such index file' c write(*,*) ' debug findevein ',seiclen(base_dir) status=9 return endif c c-- flag index file is open index_open=1 c-- must be a new month new_month=1 event_no=0 c c read file c i=0 77 continue i=i+1 c c check for max number of indexes c if(i.gt.max_index$) then write(6,*) 'Too many lines in index file:',i stop endif read(read01,'(a)',end=78) text if(text(8:12).eq.' ') goto 78 c j=index(text,'-')-2 call get_fstart(text,j) sfiles(i)=text(j:j+18) ! save file name without path if(j.gt.8) then ! only if 5 letter data base smonth(i)=text(j-3:j-2) ! save month and year since it might syear(i)= text(j-8:j-5) ! - change in index file endif c if(i.eq.1) then if(j.gt.8) then ! must have a path sdir(1:j-8)=text(8:j-1) ! save path test2000 c write(6,'(1x,a)') sdir slength=j-8 else slength=0 ! local index file with no path. but endif ! is it used anymore ???, yes, 1-98 jh fstart=slength+1 endif goto 77 78 continue c write(6,*)'fs,sle',fstart,slength call sei close (close$,read01,code) i=i-1 total_no_events=i if(i.eq.0.or.(i.eq.1.and.sfiles(1)(1:3).eq.' ')) then write(6,*)' No events in index file' index_open=0 total_no_events=0 status=9 return else write(6,*)' Number of events in index file: ', * total_no_events endif endif c c----------------------------------------------------------------------- c Loop to start time if a data base or first event if a local base c or index file c----------------------------------------------------------------------- c 1 continue event_no=0 111 continue c write(6,*)' loop to time' event_no=event_no+1 if(event_no.gt.total_no_events) goto 2 ! at end of list, below if(slength.gt.0) then if(base_dir.eq.' ') then ! index file, fix year and month sdir(slength-7:slength-4)=syear(event_no) sdir(slength-2:slength-1)=smonth(event_no) endif evfile=sdir(1:slength)//sfiles(event_no) else evfile=sfiles(event_no) endif old_evfile=evfile c write(6,'(1x,a)') evfile c c check time of this event against start time. c c fstart=index(evfile,'-')-2 call get_fstart(evfile,fstart) c write(6,*)'fstart',fstart call abstim(evfile,fstart,time) c c-- position not found or passed c if(time.lt.time1) go to 111 ! loop above to try next event c c-- position found to nearest sec c if(time.le.time2) then status=0 c-- save index number old_no=event_no return else c-- first event found was after end time status=3 index_open = 0 return endif c c-- end of list of files for month or in index file c if a data base, there might be more months to check since there c could be data in the next month c 2 continue if(base_dir.ne.' ') then ! not an index file ldummy=.TRUE. goto 7365 ! check if next month has data in the endif ! - the interval c c-- position not found status=1 c-- at beginning of file, no is 1 old_no=1 return endif c----------------------------------------------------------------------------- c SAME EVENT # SELECTED c----------------------------------------------------------------------------- c c same event by number, can be a different event c if(key(1:4).eq.'same'.or.key(1:4).eq.'SAME')then event_no=old_no if(event_no.eq.0) then write(6,*)' No more events' status=9 return endif if(event_no.gt.total_no_events) then event_no=1 endif if(slength.gt.0) then if(base_dir.eq.' ') then ! index file, fix year and month sdir(slength-7:slength-4)=syear(event_no) sdir(slength-2:slength-1)=smonth(event_no) endif evfile=sdir(1:slength)//sfiles(event_no) else evfile=sfiles(event_no) endif old_evfile=evfile c- save current event number old_no=event_no status=0 return endif c c--------------------------------------------------------------------------- c PREVIOUS EVENT SELECTED c--------------------------------------------------------------------------- if(key(1:4).eq.'BACK'.or.key(1:4).eq.'back') then c-- cannot backspace from beginning of list if(old_no.ne.1) then event_no=event_no-1 if(slength.gt.0) then if(base_dir.eq.' ') then ! index file, fix year and month sdir(slength-7:slength-4)=syear(event_no) sdir(slength-2:slength-1)=smonth(event_no) endif evfile=sdir(1:slength)//sfiles(event_no) else evfile=sfiles(event_no) endif old_evfile=evfile c-- save current event number old_no=event_no status=0 endif return endif c--------------------------------------------------------------------------- c FIND EVENT BY NUMBER c--------------------------------------------------------------------------- c c find event number in current index file c if(key(1:1).eq.'#'.or.key(1:1).eq.'1'.or.key(1:1).eq.'2'. * or.key(1:1).eq.'3'.or.key(1:1).eq.'4'.or.key(1:1).eq.'5'. * or.key(1:1).eq.'6'.or.key(1:1).eq.'7'.or.key(1:1).eq.'8'. * or.key(1:1).eq.'9'.or.key(1:1).eq.'0') then if(key(1:1).eq.'#') then if(key(2:2).ne.' ') read(key(2:2),'(i1)',err=374) ev_no_wanted if(key(3:3).ne.' ') read(key(2:3),'(i2)',err=374) ev_no_wanted if(key(4:4).ne.' ') read(key(2:4),'(i3)',err=374) ev_no_wanted if(key(5:5).ne.' ') read(key(2:5),'(i4)',err=374) ev_no_wanted if(key(6:6).ne.' ') read(key(2:6),'(i5)',err=374) ev_no_wanted else if(key(1:1).ne.' ') read(key(1:1),'(i1)',err=374) ev_no_wanted if(key(2:2).ne.' ') read(key(1:2),'(i2)',err=374) ev_no_wanted if(key(3:3).ne.' ') read(key(1:3),'(i3)',err=374) ev_no_wanted if(key(4:4).ne.' ') read(key(1:4),'(i4)',err=374) ev_no_wanted if(key(5:5).ne.' ') read(key(1:5),'(i5)',err=374) ev_no_wanted endif if(ev_no_wanted.eq.0) ev_no_wanted=1 goto 375 374 continue write(6,*)' Number not valid' status=9 return 375 continue c c start of search loop, one file only c if(ev_no_wanted.gt.total_no_events) then if(total_no_events.eq.0) then write(6,*)' No more events' status=9 return endif write(6,*)' Number too large' status=1 return endif c old_evfile=evfile !!!????? should it be here ????? event_no=ev_no_wanted if(slength.gt.0) then if(base_dir.eq.' ') then ! index file, fix year and month sdir(slength-7:slength-4)=syear(event_no) sdir(slength-2:slength-1)=smonth(event_no) endif evfile=sdir(1:slength)//sfiles(event_no) else evfile=sfiles(event_no) endif status=0 c-- save current index number old_evfile=evfile old_no=event_no return c-- end of number select block endif c c----------------------------------------------------------------------------- c FIND EVENT FROM DATE OF CURRENT MONTH c----------------------------------------------------------------------------- c c go to nearest date in current month, local index file or local data base c if(key(1:1).eq.'d'.or.key(1:1).eq.'D') then hour_wanted=0 min_wanted=0 if(key(2:2).ne.' ') then read(key(2:2),'(i1)',err=628) ev_day_wanted endif if(key(3:3).ne.' ') then read(key(2:3),'(i2)',err=628) ev_day_wanted endif read(key(4:5),'(i2)',err=628) hour_wanted read(key(6:7),'(i2)',err=628) min_wanted abs_min_wanted=ev_day_wanted*24*60+hour_wanted*60+min_wanted goto 629 628 continue write(6,*)' Invalid date' return 629 continue c c-- start searching from beginning if one month in regular data base, c if index file or local data base, find next event with EXACT match of day c if(base_dir.ne.' '.and.base_dir(1:2).ne.',,') event_no=0 8 continue event_no=event_no+1 if(base_dir.eq.' '.or.base_dir(1:2).eq.',,') then if(event_no.gt.total_no_events) event_no=1 ! wrap around if(event_no.eq.old_no) goto 9 ! gone round once, stop else if(event_no.gt.total_no_events) goto 9 endif if(slength.gt.0) then c c if an index file with a complete path, the data base year and month c might change throughout the file. Since sdir only hase one name for the c first file, it must be corrected. c if(base_dir.eq.' ') then ! index file, fix year and month sdir(slength-7:slength-4)=syear(event_no) sdir(slength-2:slength-1)=smonth(event_no) endif evfile=sdir(1:slength)//sfiles(event_no) else evfile=sfiles(event_no) endif call get_fstart(evfile,fstart) read(evfile(fstart:fstart+6),'(i2,1x,2i2)',err=3847) *current_day,current_hour,current_min abs_min_current=current_day*24*60+current_hour*60+current_min goto 3848 3847 continue write(6,'(a,a)')' Error in s-file name ',evfile stop 3848 continue c c check date and time c if(base_dir.eq.' '.or.base_dir(1:2).eq.',,') then ! local base or in. if(abs_min_current.ge.abs_min_wanted) then c if(current_day.eq.ev_day_wanted.and.current_hour.ge. c * hour_wanted) then status=0 old_no=event_no return endif else c write(6,*) 'cur, want', abs_min_current,abs_min_wanted c if(current_day.ge.ev_day_wanted.and.current_hour.ge. c * hour_wanted.and.current_min.ge.min_wanted) then if(abs_min_current.ge.abs_min_wanted) then status=0 old_no=event_no return endif endif c-- try next event go to 8 c-- no date larger then current 9 continue evfile=old_evfile event_no=old_no status=1 return c-- end of day select block endif c c----------------------------------------------------------------------------- c Find events associated in time c----------------------------------------------------------------------------- c c go to nearest date in current month or local index file c if(key(1:1).eq.'s'.or.key(1:1).eq.'S') then c c get abstime of current event c call abstim(old_evfile,fstart,tim1) c c get max time differnece, first set default if not set before c if(old_time_dif.le.0.or.old_time_dif.gt.9999) old_time_dif=180 if(key(2:2).eq.' ') time_dif=old_time_dif if(key(2:2).ne.' ') * read(key(2:2),'(i1)',err=1628) time_dif if(key(3:3).ne.' ') * read(key(2:3),'(i2)',err=1628) time_dif if(key(4:4).ne.' ') * read(key(2:4),'(i3)',err=1628) time_dif if(key(5:5).ne.' ') * read(key(2:5),'(i4)',err=1628) time_dif if(key(6:6).ne.' ') * read(key(2:6),'(i5)',err=1628) time_dif if(key(7:7).ne.' ') * read(key(2:7),'(i6)',err=1628) time_dif goto 1629 1628 continue write(6,*)' Invalid time difference' return 1629 continue c-- start searching from current position 1608 continue event_no=event_no+1 if(event_no.gt.total_no_events) goto 1609 if(slength.gt.0) then if(base_dir.eq.' ') then ! index file, fix year and month sdir(slength-7:slength-4)=syear(event_no) sdir(slength-2:slength-1)=smonth(event_no) endif evfile=sdir(1:slength)//sfiles(event_no) else evfile=sfiles(event_no) endif old_evfile=evfile call get_fstart(evfile,fstart) c c get abs time current event c call abstim(evfile,fstart,tim2) c c check if within difference c if(abs(tim1-tim2).lt.time_dif) then status=0 old_no=event_no old_time_dif=time_dif return endif c-- try next event tim1=tim2 go to 1608 c-- no more associations 1609 continue status=1 return c-- end of time association block endif c---------------------------------------------------------------------------- c GO TO NEXT EVENT c---------------------------------------------------------------------------- c c go to next event c if(key(1:4).eq.'next'.or.key(1:4).eq.'NEXT' *.or.key(1:4).eq.' ') then 5 continue event_no=event_no+1 if(event_no.gt.total_no_events) then if(from_eev.eq.0.or.from_eev.eq.2) then ! eev over months c write(6,*)' goto 6' goto 6 ! next month else event_no=1 ! start again c c indicate wrap around with a blank line c write(6,*) c goto 5 ! true january ?? endif endif if(slength.gt.0) then if(base_dir.eq.' ') then ! 3 letter data base, fix year and month sdir(slength-7:slength-4)=syear(event_no) sdir(slength-2:slength-1)=smonth(event_no) endif evfile=sdir(1:slength)//sfiles(event_no) else evfile=sfiles(event_no) endif old_evfile=evfile c-- save current event number old_no=event_no c c if call from eev, return since time check not needed c if(from_eev.eq.1) then status=0 return endif c c check if inside time window call get_fstart(evfile,fstart) call abstim(evfile,fstart,time) c-- still within time window if(time.le.time2) then status=0 return c-- end of time window else status=3 index_open = 0 return endif c c-- end of month, go to next month c 6 continue index_open=0 c write(6,*)'base dir',base_dir c c only continue if standard data base type c c if(base_dir.eq.' ') then ! until 25-3-97 if(base_dir.eq.' '.or.base_dir(1:2).eq.',,') then c-- end of single index file status=2 return endif c c-- year and month, time of next index file c month=month+1 if(month.eq.13) then month=1 year=year+1 endif c c get abs time from 0000 c call timsec(year,month,1,0,0,0.0,time) c write(6,*) year,month c write(6,*)'t,t2',time,time2 c-- not yet end of desired time interval if(time.lt.time2) then c-- make new sdir write(sdir(i2+12:i2+15),'(i4)') year write(sdir(i2+17:i2+18),'(i2)') month if(sdir(i2+14:i2+14).eq.' ') sdir(i2+14:i2+14)='0' if(sdir(i2+17:i2+17).eq.' ') sdir(i2+17:i2+17)='0' c write(6,*)'new index',sdir,slength write(6,'(1x,i4,1x,i2,1x,$)') year,month call sfil(sdir,slength,sfiles,max_index$, * total_no_events,se_out) c c update log file c call base_update(total_no_events,base_dir,year,month) c c c check if no events for new month, if so write a message c if (total_no_events.eq.0) go to 9364 c-- new month new_month=1 event_no=0 index_open=1 goto 5 9364 continue write(6,'(a,i4,1x,i2)')' No data for year and month: ', * year,month goto 5 c-- end of time interval else status=3 return endif endif c return end c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c subroutine base_address(year,month,base_no,pointer) c c calulate address of data base info in data base log file c addres is in terms of 4 byte pointers c implicit none integer base_no ! base no integer year, month integer pointer ! address in log file c c pv if(year.lt.1900.or.year.gt.2049) then if(year.lt.1900.or.year.gt.2099) then write(6,*)' Wrong year:',year stop endif pointer=((year-1900)*12+month-1)*100+200+base_no c return end c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c subroutine base_get_bases(nbase,base) c c get a list of all data bases (base) in data base, nbase c is the number of bases c if nbase is -1, some error has occurred c if the central data base file does not exist, create it c implicit none include 'libsei.inc' character*60 top_directory ! seisan top directory name character*800 bases ! all bases in one string character*8 bas(100) ! ----------- character*5 base(100) ! individual bases integer nbase ! number of bases character*80 base_file ! data base log file integer ini(100) ! to initialize integer code ! error code integer log_unit ! unit to read and write from logical b_old ! logical if file is old integer i c equivalence (bases,bas) c c c get location of log file c call topdir(top_directory) i=index(top_directory,' ')-1 base_file = top_directory(1:i)//'/REA/REA.LOG' nbase=-1 c c c open data base log file c chr_f_access$='direct' f_recl$=800 call sei open(old$+warn$, ! Open a existing file. & ' ', ! Prompt file name (n/a). & base_file, ! File name & log_unit, ! Read unit #1 & b_old, ! Already exists? (n/a). & code) ! Returned condition if (code .ne. e_ok$) then write(6,*)' No data base log file, now make it' c chr_f_access$='direct' f_recl$=400 call sei open(new$+warn$, ! Open a existing file. & ' ', ! Prompt file name (n/a). & base_file, ! File name & log_unit, ! Read unit #1 & b_old, ! Already exists? (n/a). & code) ! Returned condition if (code .ne. e_ok$) then nbase=-1 return endif c bases=' ' c c put blank for base names c write(log_unit,rec=1) bases(1:400) write(log_unit,rec=2) bases(1:400) c c put -1 for number of events pr month c do i=1,100 ini(i)=0 enddo c c initialize for 150 years, 150*12 c do i=3,1802 write(log_unit,rec=i) ini enddo call sei close(close$,log_unit,code) nbase=0 return endif c c------------------------------------- c a data base log file was present c------------------------------------- c c c read data base names and find how many c read(log_unit,rec=1) bases do i=1,100 base(i)=bas(i)(1:5) if(base(i)(1:1).eq.' ') then nbase=i-1 c write(6,*)' found',i call sei close(close$,log_unit,code) return endif enddo c return end c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c subroutine base_update(nevents,base,year,month) c c updata data base log file with new number of events, nevents c for a particular year and month for a given base c implicit none include 'libsei.inc' integer nevents,year,month character*5 base character*60 top_directory ! seisan top directory name character*5 bases(100) ! max 100 data bases character*800 b800 ! ----------------- character*8 bas(100) ! ----------- integer nbases ! number of bases character*80 base_file ! data base log file integer code ! error code integer log_unit ! unit to read and write from logical b_old ! logical if file is old integer pointer ! address of element with data base info integer ibase ! number of the data base character*1 ucase integer i c equivalence (b800,bas) log_unit=77 c c if no events, return c if(nevents.eq.0) return c c if before 1900 retuen c if(year.lt.1900) return c c do not update a local data base or a local index file c if(base(1:2).eq.',,'.or.base.eq.' ') return c c make sure only upper case is used c do i=1,5 base(i:i)= ucase(base(i:i)) enddo c c get location of log file c call topdir(top_directory) i=index(top_directory,' ')-1 base_file = top_directory(1:i)//'/REA/REA.LOG' c c get number of data bases c call base_get_bases(nbases,bases) if(nbases.eq.-1) goto 99 c write(6,*)' Number of bases ',nbases c c find the number of the data base to use c ibase=0 do i=1,nbases if(base.eq.bases(i)) then ibase=i goto 1 endif enddo 1 continue c c check if data base was registered in data base log file, if not, do it c if(ibase.eq.0) then ibase=nbases+1 ! number of new data base nbases=nbases+1 ! number of bases after adding one c c open data base log file c c chr_f_access$='direct' c f_recl$=800 c c call sei open(old$+warn$, ! Open a existing file. c & ' ', ! Prompt file name (n/a). c & base_file, ! File name c & log_unit, ! Read unit #1 c & b_old, ! Already exists? (n/a). c & code) ! Returned condition c if(code.ne.e_ok$) goto 99 open(77,file=base_file,access='direct',recl=800) c c put name in string and write it c bases(ibase)=base b800=' ' do i=1,nbases bas(i)(1:5)=bases(i) bas(i)(6:8)=' ' enddo write(log_unit,rec=1,err=99) b800 c call sei close(close$,log_unit,code) close(77) write(6,*)' Data base log file updated with a new data base' endif c c open data base file c c chr_f_access$='direct' c f_recl$=4 c call sei open(old$+warn$, ! Open a existing file. c & ' ', ! Prompt file name (n/a). c & base_file, ! File name c & log_unit, ! Read unit #1 c & b_old, ! Already exists? (n/a). c & code) ! Returned condition c if(code.ne.e_ok$) goto 99 c open(77,file=base_file,access='direct',recl=4) c calculate address to put info c call base_address(year,month,ibase,pointer) c c write info c c write(6,*) 'nev,point',nevents,pointer write(log_unit,rec=pointer,err=99) nevents c call sei close(close$,log_unit,code) close(77) c return c 99 continue write(6,*)' Error with data base log file, REA.LOG' write(6,*)' or you do not have write permission' return end subroutine get_fstart(filename,fstart) c c find start of s-file name and check name c implicit none integer fstart,sei clen,i1,i2,i3,i4 character*80 filename c c fstart=sei clen(filename)-18 read(filename(fstart:fstart+18),'(i2,1x,i4,1x,i2,3x,i6)', ! check name *err=1)i1,i2,i3,i4 if(filename(fstart+2:fstart+2).ne.'-'.and. * filename(fstart+7:fstart+7).ne.'-') then goto 1 endif goto 2 c c errror c 1 continue write(6,*)' Corrupted S-file name, name is:' write(6,'(1x,a)') filename write(6,*)' Return to stop' read(5,'(a)') filename stop 2 continue return end