c$DEBUG
c
c  program to auto register waveform files
c
c  j. havskov, mar 93
c  Updates:
c  jul 93 by jh: version 3.0 
c  apr 94      : also possible to register in local data base
c  nov 24, 1994  : opening files changed
c  dec  15     : **********   version 5.0 ********************
c  jan 96    96: new seisinc
c  nov 97      : put line type 1 in header line
c  dec 8, 97   : change local to ,,,
c  dec 23      : error when asking for overwrite
c---------------------------------------------------------------------
c  oct 98      : ------------   version 7.0 check --------------------
c                make new id, 5 letter base, year 2000
c  jan 99, 5 lo: bug fix with reading base
c  mar 2 99  jh: REG to ARG
c  may2  00  jh: new wave structure
c  apr 29 01 lo: add check for blank line, if blank lines, add all names
c                up to next blank line to one event, this makes it possible
c                to register events with several waveform file names
c
c
      implicit none
C
C    Seisan library inserts and routines...
C    ======================================
C
       include 'libsei.inc'                ! Open file definitions
       include 'seidim.inc'
       include 'waveform.inc'
C
       external sei open,                  ! Open file routine.
     &          sei close,                 ! Close file routine.
     &          sei code                   ! Error encoder.
       integer seiclen
C
C    ============= end of list ==========
C
c-- input file name
      character*80 infile,wave_file(990),xx
c-- output file name 
      character*80 event_name	
      integer nf    ! length of name  
c-- operator
      character*4 operator
c-- id line
      character*80 idline
c-- event type
      character*1 type,type_in
c-- base name
      character*5 base
c-- main header date and time
      integer year,month,day,hour,min,isec
c-- processing time
      character*12 p_time
      character*14 proc_time
c-- file existence
      logical exist
      real sec	  
C-- s file data
      character*80 data(999)
c-- counters
      integer i,j,k,cnt
c logical for end of file
       logical          b_eof
c logical for existing file or not
       logical          b_old
c returned code
       integer          code
c read unit #1 .. #6
       integer          read01, read02
c write unit #1 .. #5
       integer          write01
c file name
       character*80     chr_file
       logical          nwrite_all,owrite_all ! for writing files
       logical          ignore_all            ! ignore all dublicates
       character*1      choise                ! choise form questions
       logical with_blanks  ! true if filenr.lis has blank lines to sep events
c

c
c print version
c
      include 'version.inc'
      out_version_date='July 23, 2001'
      if (version_new) out_version_date=version_date
      call print_ver

      nwrite_all=.false.
      owrite_all=.false.
      ignore_all=.false.
      b_f_debug$=.false.                  ! file debugging
      b_eof=.false.
c
c   set event type to local
c
 1000 continue
      write(6,*)' Event type for all events: Local:    L (default)'
      write(6,*)'                            Regional: R'
      write(6,*)'                            Distant:  D'
      read(5,'(a)') type_in
      if(type_in.eq.' ') then
         type='L'
      else
         type=type_in
      endif
      if(type.eq.'l') type='L'
      if(type.eq.'r') type='R'
      if(type.eq.'d') type='D'
      if(type.ne.'L'.and.type.ne.'R'.and.type.ne.'D') then
         write(6,*)' Wrong type, enter again'
         goto 1000
      endif
c
c  get base name
c
      write(6,*)
     *' 1-5 letter base name, return for standard base, '
     *,',, for local base'
      read(5,'(a)') base

      if (base(1:1).ne.' ') then
        do i=2,5
          if (base(i:i).eq.' ') base(i:i)='_'
        enddo
      endif

c
c   get operator
c
 60   continue
      write(6,*) ' Operator, max 4 chars'
      read(5,'(a)') operator
      if(operator.eq.'    ') then
         write(6,*)' You must give operator id'
         goto 60
      endif
c
c   open file with file names
c	  	  
      call sei open(old$+warn$,            ! Open a existing file.
     &                     ' ',                   ! Prompt file name (n/a).
     &                     'filenr.lis',          ! File name
     &                     read01,                ! Read unit #1
     &                     b_old,                 ! Already exists? (n/a).
     &                     code)                  ! Returned condition
      if (code .ne. e_ok$) go to 10
      goto 11
 10   continue
        write(6,*)' No filenr.lis file, make a dirf first'
        stop
 11   continue

      i=0
      with_blanks=.false.

 12   continue

      read(read01,'(7x,a)',iostat=code) infile
      call sei code(stop$,code,read01,b_eof)
      if (b_eof) go to 14  

      if (seiclen(infile).le.3) then
        i=1
      else
        if (i.eq.1) then
          with_blanks=.true.
          goto 14
        endif
      endif

      goto 12
 14   continue
      call sei close (close$,read01,code)
      b_eof=.false.
      call sei open(old$+warn$,            ! Open a existing file.
     &                     ' ',                   ! Prompt file name (n/a).
     &                     'filenr.lis',          ! File name
     &                     read01,                ! Read unit #1
     &                     b_old,                 ! Already exists? (n/a).
     &                     code)                  ! Returned condition.

      do i=1,990
        wave_file(i)=' '
      enddo
c 
c----------------------------------------------
c   enter here for new  event to register
c----------------------------------------------
c
 1    continue 
      read(read01,'(7x,a)',iostat=code) infile
      call sei code(stop$,code,read01,b_eof)
      if (b_eof) go to 999
      if (infile(1:1).eq.' ') goto 1
c
c read lines until next blank
c
      j=0
      xx='x'
      if (with_blanks) then
        do while (.not.b_eof.and.
     &            xx(1:1).ne.' ')
          read(read01,'(7x,a)',iostat=code) xx
          call sei code(stop$,code,read01,b_eof)
          if (b_eof) go to 111
          if (xx(1:1).ne.' ') then
            j=j+1
            wave_file(j)=xx
          else
            goto 111
          endif
        enddo
      endif
111   continue

      write(6,'(1x,a)') infile(1:60)
c-- check if end of group of filenr.lis	  
      if(infile(1:4).eq.'    ') goto 999	  	  	   	  	  
      wav_filename(1)=infile
c
c   now read first header for one event
c	  
      call wav_init
      call read_wav_header(1)
      if(wav_error_message.ne.' ') then
         write(6,'(1x,a)') wav_error_message
         goto 1
      endif
c
c   make output file name
c
      year=wav_year(wav_first)
      month=wav_month(wav_first)
      day=wav_day(wav_first)
      hour=wav_hour(wav_first)
      min=wav_min(wav_first)
      sec=wav_sec(wav_first)
      isec=sec
      call sfilname
     *(year,month,day,hour,min,isec,base,type,event_name,nf)

c
c   write header line in file
c
      data(1)=' '
      write(data(1),'(1x,i4,1x,2i2,1x,2i2,1x,f4.1,1x,a1)')     
     *year,month,day,hour,min,sec,type
      data(2)(1:1)=' '
      data(1)(80:80)='1'
c
c
c   next line is id line
c
      idline(1:40)= ' ACTION:                   OP:     STATU'
      idline(41:80)='S:               ID:                   I'
      WRITE(IDLINE(61:75),'(i4,5I2)')
     *YEAR,MONTH,DAY,HouR,MIN,ISEC
      DO I=61,74
         IF(IDLINE(I:I).EQ.' ') IDLINE(I:I)='0'
      ENDDO
      call systime(p_time,proc_time)
      WRITE(IDLINE(31:34),'(A)')OPERATOR
      WRITE(IDLINE(13:26),'(A)')PROC_TIME
      WRITE(IDLINE(9:11),'(A)')'ARG'
c
c  trace file name
c
      i=index(infile,'.')
      if(i.lt.0) 
     *write(6,*)' *** No . in trace file name ****'
c
c  write trace file name
c
      do i=1,80
         data(3)(i:i)=' '
      enddo
      i=index(infile,' ') -1
      if(i.lt.1) then
         data(3)(2:13)=infile(1:12)
      else
         data(3)(2:i+1)=infile(1:i)
      endif
      data(3)(80:80)='6'	  

c
c add more waveform files
c
      cnt=0
      do k=1,j
        if (seiclen(wave_file(k)).gt.1) then 
          i=0
          data(k+3)='                                        '//
     &              '                                       6' 
          cnt=cnt+1
          i=index(wave_file(k),' ') -1 
          data(k+3)(2:i+1)=wave_file(k)(1:i)
        endif
      enddo
c
c   make help line
c
      data(4+cnt)(1:57)=
     *' STAT SP IPHASW D HRMM SECON CODA AMPLIT PERI AZIMU VELO '
c      data(4+cnt)(58:80)='SNR AR TRES W  DIS CAZ7'
      data(4+cnt)(58:80)='AIN AR TRES W  DIS CAZ7'
c
c   blank last line
c
      do i=1,80
         data(5+cnt)(i:i)=' '		
      enddo
c
c   check if file exists
c
 3    continue       ! get here from below to again check file existance
c
      inquire(file=event_name,exist=exist)
c
c  If file exists, check what to do
c
c   ignore
c
      if(exist.and.ignore_all) then ! was there but do not overwrite
         write(6,*)' New event ignored'
         goto 1       ! never overwrite
      endif
c
c   over write
c
      if(exist.and.owrite_all) then
         write(6,*)' New event overwriting old'
         go to 100    ! overwrite all
      endif
c
c   make new index
c
      if((exist.and.nwrite_all).or.(exist.and.(choise.eq.'N'.or.
     *    choise.eq.'n'))) then
          write(6,*)' Creating a new id for event'
          call inc_id(idline,event_name,nf)
          goto 3                            ! go and try to open again
      endif

 5    continue      ! here to make a new choise
c
c   make choises here
c
      if(exist) then
          write(6,*)
          write(6,'(a)')' File already registered, options are:'
          write(6,'(a)')' Ignore (leave old event):             Return'
          write(6,'(a)')' Ignore all                            I'
          write(6,'(a)')' Overwrite duplicate:                  O'
          write(6,'(a)')' Overwite all duplicates:              A'
          write(6,'(a)')' Create a new event, different ID:     N'
          write(6,'(a,$)')' Create new events for ALL duplicates: *'
          read(5,'(a)') choise
c
          write(6,*)
        
          if(choise.eq.' ') then
             goto 1     ! get next event
          endif
          if(choise.eq.'i'.or.choise.eq.'I') then
             ignore_all=.true.
             goto 1
          endif
          if(choise.eq.'a'.or.choise.eq.'A') then
             write(6,*)' Sure you want to overwrite ALL (y/n)'
             read(5,'(a)') choise
             if(choise.eq.'y'.or.choise.eq.'Y') then
                 owrite_all=.true.
                 goto 100
             endif
             goto 5 ! another choise  
          endif
          if(choise.eq.'o'.or.choise.eq.'O') then
             write(6,*)' Sure you want to overwrite(y/n)'
             read(5,'(a)') choise
             if(choise.eq.'y'.or.choise.eq.'Y') then
                goto 100
             else
                goto 5   
             endif
          endif
          if(choise.eq.'n'.or.choise.eq.'N'.or.choise.eq.'*') then
             call inc_id(idline,event_name,nf)
             if(choise.eq.'*') nwrite_all=.true.
             goto 3     ! test again
          endif
          goto 5   ! no valid choise
      endif
c
  100 continue 
      choise=' '    ! reset choise
c
      data(2)=idline
      write(6,'(1x,a)') event_name(1:seiclen(event_name))
      write(6,*)

c
c   open and write s-file 
c
      chr_file = event_name(1:80)
              call sei open(unknown$+warn$,       ! Open an unknown status file.
     &                      ' ',                  ! Prompt file name (n/a).
     &                      chr_file,             ! File name
     &                      write01,              ! Write unit #1
     &                      b_old,                ! Already exists? (n/a).
     &                      code)                 ! Returned condition
      if (code .ne. e_ok$) go to 50
      goto 51
 50   continue
        write(6,*)' Data base sub directory not made'
        stop
 51   continue
          write(write01,'(a80)',iostat=code) (data(i),i=1,5+cnt)
          call sei code(stop$,code,write01,b_eof)
      call sei close (close$,write01,code)
c
c   back for next event
c	  
      goto 1	  	  	   
c
 999  continue	  
      call sei close (close$,read01,code) 
      stop
      end	  	  	 
