c
c  program to split seisan waveform files
c
c  j. havskov, march 1993
c  Updates:
c  jul 8 93 by jh  : version 3.0
c  jan 2 94        : bug with outfile if same on pc
c  jun 94          : 999 channels, bug when first and secon outfiles same on pc
c  dec 7           : include seidim
C  dec 8        : Installed file & error handling (libsei)
c  dec 13         ************** version 5.0 *************************
c  jul 27 95 jh    : bug with 30 channles
c  aug 21          : still ------------
c  nov 1  95 jh    : new seisinc routine
c  march 8 99      : ----------------   verison 7.0 check ---------------
c                    stat, year 2000
c  jan5 99 jh      : file name wrong for 2000
c  apr  08 lo      : use filenr.lis and use station in filename if all
c                    channels form same station
c
      implicit none
c
c  dimentions include defs.
c
      include 'seidim.inc'
c-- main header
      character*80 mainhead(max_trace/3+3)
c-- channel header
      character*1040 chahead	  
c-- input file names
      character*80 infile
c-- output file name 
      character*80 outfile,first_outfile
c-- input question
      character*80 question	  	  
c-- station counter
      integer nstat	  
c-- indicator if first or second file to make
      integer file_sel
      character*5 net_code
c-- number of stations and samples
      integer nsamp,nchan,nchan_out	  
c-- stations and components
      character*5 stat(max_trace)
      character*4 comp(max_trace)	  
c-- main header date and time
      integer myear,mmonth,mday,mdoy,mhour,mmin
      real msec	  
c-- channel start time and interval
      real cstart(max_trace)
      double precision cinter(max_trace)
c-- event start time
      double precision ev_time
c-- number of channels to remove
      integer n_remove	  	  
c-- channel number to remove
      integer chan_remove(max_trace)
c-- channels marked for removal
      integer chan_sel(max_trace)
c-- total window length
      real total_window
c-- channel absolute start time relative earliest channel, from  1900, in sec 
      double precision cabstim(max_trace)     	  	  
c-- channel end time absolute
      double precision cendtim(max_trace)
c-- maximum and minumum of above and their difference
      double precision first_time,last_time
c-- data samples
      integer*2 data2(2*max_sample)
      integer*4 data4(max_sample)	  	  
c-- counters
      integer i,j,k,l,ichan
C    Seisan library inserts and routines...
C    ======================================
C
       include 'libsei.inc'                ! Library definitions & data defns.
       external sei open,                  ! Open file routine.
     &          sei close,                 ! Close file routine.
     &          sei code,                  ! Error encoder.
     &          sei real num               ! Get real number
C
       integer  write01,                   ! Output unit 1.
     &          read01,                    ! Input unit1.
     &          code                       ! Local condition.
       logical  b_flag                     ! Flag end of file?.
       real sei real num                   ! Real number
c-- for component rotation, not used in this routine
      real caz,saz
      real baz(max_trace)
      real        del_rot       ! delay rotated trace
      character*1 rot_comp(max_trace)  ! T or R
      logical rotate
      integer nchan_last                   ! save number of channels
      integer in                           ! 1 for filenr.lis
      logical singleflag                   ! true if all channels from single station
      character*5 singlestat
c
      real x(max_sample)
      equivalence (data2,data4)
c      equivalence (data4,x)
      common /signalx/x,rotate,baz,rot_comp,del_rot
C
C    ============= end of list ==========
      include 'version.inc'


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

c      question=' Filename or number'
c
c  get file name
c
      in=0
      nchan_last=0
      question=' Filename, ?, number or filenr.lis for all'
      call filename(question,infile)
c
c   check which type of input file
c
      if(infile(1:10).eq.'filenr.lis'
     *   .or.infile.eq.'FILENR.LIS') then
            open(8,file='filenr.lis',status='old')
            in=1
      endif
      write(6,*)'No of channels to remove'
      read(5,*)n_remove 
      write(6,*)'Channels to remove'
      read(5,*)(chan_remove(i),i=1,n_remove)

10    continue
      if(in.eq.1) then
         read(8,'(7x,a)') infile
         write(6,*)
         write(6,'(1x,a)') infile
         if(infile(1:4).eq.'    ') goto 99
      endif

      if(infile(1:3).eq.'EOF') goto 99       
          chr_f_access$='direct'
          f_recl$=2048
          call sei open( old$+stop$,       ! Open file & stop if erro.
     &                   ' ',              ! Prompt (n/a).
     &                   infile,           ! Filename.
     &                   read01,           ! Unit opened on.
     &                   b_flag,           ! Flag.
     &                   code )            ! Returned condition.
c
c   now read headers for input event
c	  
      call seisinc                                                             
     *(read01,0,nchan,0,MAINHEAD,chahead,0.0,0.0)                     
c
c check that number of channels is the same
c
      if (nchan_last.ne.0.and.nchan.ne.nchan_last) then
        write(*,*) ' number of channels changed -> exit '
        goto 99
      endif
      nchan_last=nchan
c
c-- date and time of first channel
c
      read(mainhead(1)(34:59),'(i3,5x,i2,1x,i2,1x,i2,1x,i2,1x,f6.3)')
     *myear,mmonth,mday,mhour,mmin,msec 	   	  	 
      myear=myear+1900
      call timsec
     *(myear,mmonth,mday,mhour,mmin,msec,ev_time)
c
c-- get channel codes, start times and durations
c
      nstat=1
      do i=3,(nchan-1)/3+3
         read(mainhead(i),'(3(1x,2a4,a1,f7.2,1x,f8.2))')
     *   stat(nstat)(1:4),comp(nstat),stat(nstat)(5:5),
     *   cstart(nstat),cinter(nstat),
     *   stat(nstat+1)(1:4),comp(nstat+1),stat(nstat+1)(5:5),
     *   cstart(nstat+1),cinter(nstat+1),	 
     *   stat(nstat+2)(1:4),comp(nstat+2),stat(nstat+2)(5:5),
     *   cstart(nstat+2),cinter(nstat+2)	 
         do k=1,3
            l=nstat+k-1		 		 
            cabstim(l)=ev_time+cstart(l)
            cendtim(l)=cabstim(l)+cinter(l)			
         enddo		 
         nstat=nstat+3		   		 
      enddo
      rewind read01	  
c
c--------------------------------------------------------
c   file header read, sort out channels to extract/delete
c--------------------------------------------------------
c
c   mark channels to remove
c	
      do ichan=1,nchan
        chan_sel(ichan)=0  	  	 
        do k=1,n_remove
           if(chan_remove(k).eq.ichan) then
              chan_sel(ichan)=1
           endif
        enddo
      enddo
	  
c---------------------------------------------------------
c   back here after making file without selected channels
c   selected with variable file_sel 0: traces not selected
c                                   1: traces selected
c---------------------------------------------------------
c
      file_sel=0
      first_outfile(1:30)='                              '
c
 1000 continue
	  
c
c   find earliest trace and total time window 
c
      first_time=1.0e20
      last_time=0.0	  
      singleflag=.true.
      singlestat=' '
      do i=1,nchan
         if(chan_sel(i).eq.file_sel) then 
           if(cabstim(i).lt.first_time) first_time=cabstim(i)
           if(cendtim(i).gt.last_time)  last_time=cendtim(i)
           if (singlestat.ne.' '.and.singlestat.ne.stat(i))
     &       singleflag=.false.
           singlestat=stat(i)
         endif
      enddo
      if (.not.singleflag) singlestat=' '
c
c   find new start times relative to new main header
c
      do i=1,nchan
         if(chan_sel(i).eq.file_sel) cstart(i)=cabstim(i)-first_time
      enddo	
c
      total_window=last_time-first_time
c
c   make new main header, clear first
c
      if(nchan.gt.30) then
         k=(nchan-31)/3+13
      else
         k=12
      endif
      do i=1,k
         do j=1,80
            mainhead(i)(j:j)=' '
         enddo
      enddo		 					 	  
      k=0
      do i=1,nchan
        if(chan_sel(i).eq.file_sel) k=k+1
      enddo
      write(mainhead(1)(31:33),'(i3)') k
      nchan_out=k
c-- start time	  
      call sectim(first_time,myear,mdoy,mmonth,mday,mhour,mmin,msec)
      write(mainhead(1)(34:69),'(i3,1x,i3,1x,i2,1x,i2,1x,i2,1x,
     *i2,1x,f6.3,1x,f9.3)') myear-1900,mdoy,mmonth,mday,mhour,mmin,msec,
     *total_window
c
c-- channels, check for channels not used
c
      l=2
      k=3	  
      do j=1,nchan
        if(chan_sel(j).eq.file_sel) then
           write(mainhead(k)(l:l+24),'(2a4,a1,f7.2,1x,f8.2)')	  	 
     *     stat(j)(1:4),comp(j),stat(j)(5:5),cstart(j),cinter(j)   
           l=l+26
           if(l.gt.60) then
              l=2
              k=k+1
           endif
        endif
      enddo		
c
c   determine net code
c
      if (singleflag) then
        net_code=singlestat
      else
        net_code=mainhead(1)(2:6)
      endif
      if(net_code(1:1).eq.' ') net_code='SPLIT'
      do i=1,5
         if(net_code(i:i).eq.' ') net_code(i:i)='_'
      enddo
c                                                                               
c  make file name
c
c    century
c
         if(myear.ge.2000) then
           outfile(1:2)='20'
         else
           outfile(1:2)='19'
         endif
c             
c-- year                          
         outfile(3:5)=mainhead(1)(35:36)//'-'               
c-- month                                    
         outfile(6:7)=mainhead(1)(42:43)		
         outfile(8:8)='-'
c-- day                                      
         outfile(9:10)=mainhead(1)(45:46)		
         outfile(11:11)='-'
c-- hr                                       
         outfile(12:13)=mainhead(1)(48:49)		
c-- min                                    
         outfile(14:15)=mainhead(1)(51:52)		
         outfile(16:16)='-'
c-- sec                                    
         outfile(17:18)=mainhead(1)(54:55)		
         outfile(19:20)='S.'
c-- network or station code                  
         outfile(21:25)=net_code		
         outfile(26:26)='_'
c-- number of channels
         outfile(27:29)=mainhead(1)(31:33)
c-- check for blanks                                        
         do i=1,29				
            if(outfile(i:i).eq.' ') outfile(i:i)='0'                            
         enddo                                                                  
         write(6,200) outfile(1:29)                                             
 200     format(/,' Output file name is: ',a29)                                
c
c   check that outfile name is not the same as the input
c   file or first output file name 
c   in which case the event should not be written out
c   on sun that should not happend often since file name is to nearest
c   second and number of channels is given
c
         if(infile(1:29).eq.outfile(1:29).or.outfile(1:29).eq.
     *      first_outfile(1:29)) then
            write(6,*)'**************************************'
            write(6,*)'Output file already exists, stop '
            write(6,*)'**************************************'
            stop 
          endif
c
c   save filename to be able to compare when second file is written out
c
         if(file_sel.eq.0) first_outfile=outfile
c
c   open file and write main header
c
          chr_f_form$ = 'unformatted'
          call sei open( unknown$,         ! Open file (default=stop on error)
     &                   ' ',              ! Prompt (n/a).
     &                   outfile,          ! Filename.
     &                   write01,          ! Unit opened on.
     &                   b_flag,           ! Flag.
     &                   code )            ! Returned condition.
c-- calculate number of main header lines
         if(nchan_out.gt.30) then
            k=(nchan_out-31)/3+13
         else
            k=12
         endif
      do i=1,k
         write(write01)mainhead(i)
         write(6,'(a80)') mainhead(i)		 
      enddo
c
c   channel loop
c 
          call seisinc                                                             
     *    (read01,0,nchan,0,MAINHEAD,chahead,0.0,0.0)                     
c
         do j=1,nchan	
c
c-- write out again if not selected out
c-- put in response in future
c
            if(chan_sel(j).eq.file_sel) then
               call seisinc                                                             
     *         (read01,j,nchan,2,MAINHEAD,chahead,0.0,0.0)                     
               read(chahead(45:50),'(i6)') nsamp
               write(write01) chahead
               write(6,*) ' Channel copied --------------------'
               write(6,'(1x,a)') chahead(1:60)			
               if(chahead(77:77).eq.'4') then
                  do i=1,nsamp
                     data4(i)=x(i)
                  enddo
                  write(write01)(data4(i),i=1,nsamp)
               else
                  do i=1,nsamp
                     data2(i)=x(i)
                  enddo
                  write(write01)(data2(i),i=1,nsamp)
               endif
            else
c	           write(6,*) ' Channel selected out, not copied *****' 
            endif
         enddo
         call sei close(close$,write01,code)
c
c   check if going back and making second file
c
         if(file_sel.eq.0) then
            file_sel=1
            goto 1000
         endif
c
      goto 10
99    continue

      call sei close(close$+all$,read01, code)       ! Close all open files.
      stop
      end	  	  	 

