c
c   converts pde monthly and weekly bulletins files to nordic format
c   files can be received on email or picked up  at 
c   hazards.cr.usgs.gov, dir pde for monthly files and
c   hazards.cr.usgs.gov, weekly  for weekly files, must be ehdf type.
c
c   reads monthly filefes in both formats before 2004 and after
c
c   jh august 1993
c   updates:
c   apr 14, 96 by jh: add automatic year,month reading, weekly files
c   apr 19          : fix name, append weekly files
c   apr 25          : fix monthly if retransmitted mail
c   may 30, 97      : format read for weekly files was wrong in latitude
c   jun 23          : new PDE format
c   sep 9           : bug
c   dec 19          : bug with s and w for weekly files
c                     be able to read yearly files in monthly format
c   fen 4   99 jh   : ---------   version 7.0 ---------------------
c   jan 27 2002 jh  : make all events type D, put weekly file sin PDEWE base
c   feb 19          : also split to s-files
c   mar 12          : more fixing in above
c   apr 4           _ --------------------
c   aug 20          : put in line type 1
c   mar 24 2003     : for monthly files, number of stations was GAP, fixed
c   may 10 2004     : more comments
c   jul 7  2005     : small format change for monthly files
c   dec 7  2005 jh  :  more changes to monthly files, some #$@%^% changed
c                     the format jan 01, 2004, 
c   oct 28 2008 jh  : file_open initial value of false was commented out,
c                     so it did not work on linux, rms gives wrong values
c                     on weekly files and linux, do not write out of larger
c                     then 5.0


c
       IMPLICIT NONE
c  ARRAY WITH ORIGINAL READINGS, only header here
      CHARACTER*80 DATA
      character*80 data1(10)   ! more lines
c-- TOP DIR FOR REA
      CHARACTER*40 TOP_DIRECTORY
c   length of top_directory
      integer topdirlen
      character*80 text,new_text
      character*5 base         ! data base to write to
c-- dir separator
      character*1 dchar
      CHARACTER*3 AGENCY
      integer id                ! id line number
      character*4 trms
      character*80 outfile
      logical file_open          ! true if outfile is open
      character*3 tmonth(12)     ! first 3 letters of month
      character*80 infile
      character*4  type          ! file type
      character*4  magaga1,magaga2 ! magnitude type and agency
      character*4  magaga3,magaga4 ! magnitude type and agency
      real mag1,mag2,mag3,mag4     ! magnitude
c---time of writing s-file
      character*12 p_time
      character*14 proc_time
c---operator id
      character*4 operator
C  NUMBER OF DIFFERENT STATIONS IN DATA
      INTEGER NSTAT
      INTEGER YEAR,MONTH,DAY,HOUR,MIN
      integer old_month            ! previous month
      REAL SEC
C  DECIMAL LATITUDE AND LONGITUDE
      REAL DLAT,DLON
C  DEPTH,  RMS OF RESIDUALS
      REAL DEPTH,RMS
      INTEGER IDEPTH
      integer nhead, nrecord
c magntudes
      character*3 ms,mb
      INTEGER I,nevent,l,k
      data tmonth/'JAN','FEB','MAR','APR','MAY','JUN',
     *            'JUL','AUG','SEP','OCT','NOV','DEC'/



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

C
c
c   get system time so time of update can be time stamped
c
      call systime(p_time,proc_time)


      nevent=0
c     file_open=.false.
      old_month=999
      call topdir(top_directory)
      topdirlen=index(top_directory,' ') -1
      call dir_char(dchar)
      write(6,*)' Input file'
      read(5,'(a)') infile
      open(1,file=infile,status='old')

 6666    continue 
         WRITE(6,*)'OPERATOR ID (max 4 char):'
         READ(5,'(A4)') OPERATOR
c
         IF(OPERATOR.EQ.'    ') then
           write(6,*) ' You must give operator'
           goto 6666
         endif
c
c   find which type of file, monthly or weekly, have different format
c
      type='    '
      do i=1,80
        read(1,'(a)') text
c      enddo
      if(text(1:2).eq.'GS') then
         type='week'
         write(6,*)' Weekly file'
         write(6,*)' Enter to continue'
         read(5,'(a)') k
         goto 3333
      endif
      if(text(3:4).eq.'  '.and.
     *(text(24:24).eq.'N'.or.text(24:24).eq.'S')) then
         type='mont'
         write(6,*) ' Monthly file'
         write(6,*)' Enter to continue'
         read(5,'(a)') k
         goto 3333
      endif
      enddo
 3333 continue
c
      if(type.eq.'mont') then
c
c   find year and month
c
         rewind 1
c
c   find first header line
c
  20     continue
         read(1,'(a)') text
         if(text(1:3).ne.'DAY') goto 20
c
c   find line with year and month
c
 30      continue
         backspace 1
         backspace 1
         backspace 1
         backspace 1
         backspace 1
         read(1,'(a)') text
         if(text.eq.' ') goto 30
c
c  get rid of blanks
c
         do i=1,80
          if(text(i:i).ne.' ') goto 40
         enddo
40       continue
         k=0
         new_text=' '
         do l=i,80,2
           k=k+1
           new_text(k:k)=text(l:l)
         enddo
c        write(6,*) new_text
c
c  find year and month
c
         do i=1,80
           if(new_text(i:i).eq.' ') then
              read(new_text(i+1:i+4),'(i4)') year
              goto 45
           endif
          enddo
          write(6,*) 'Year and month ',year,month
 45       continue
c
c   find month
c
         do i=1,12
           if(tmonth(i).eq.new_text(1:3)) then
             month=i
             goto 2233
           endif
         enddo
         write(6,*)' Could not find a valid month'
         stop
 2233    continue
         write(6,*) 'Year and month ',year,month
      endif
      if(type.eq.'    ') then
         write(6,*)' Not a PDE type input file'
         stop
      endif
      rewind 1
c
c   reading loop
c
 50   continue 
      read(1,'(a)',end=99) text
      if(text(1:20).eq.'                    ') goto 50
      if(text(24:24).ne.'N'.and.text(24:24).ne.'S'.and.
     *text(26:26).ne.'N'.and.text(26:26).ne.'S') goto 50
      if(text(35:35).ne.'W'.and.text(35:35).ne.'E'.and.
     *text(33:33).ne.'W'.and.text(33:33).ne.'E') goto 50
      mag1=-10.0
      mag2=-10.0
      mag3=-10.0
      mag4=-10.0
      magaga1='    '
      magaga2='    '
      magaga3='    '
      magaga4='    '
      nevent=nevent+1
      if(type.eq.'mont') then
c        write(6,*) text(1:70)
         read(text(1:14),'(i2,2x,i2,1x,i2,1x,f4.1)') day,hour,min,sec
         read(text(17:22),'(f6.3)')dlat 
         read(text(27:33),'(f7.3)')dlon
         if(year.lt.2004) read(text(38:40),'(i3)') idepth
         if(year.ge.2004) read(text(37:39),'(i3)') idepth
         depth=idepth
         if(year.lt.2004) read(text(45:51),'(a3,1x,a3)')mb,ms
         if(year.ge.2004) read(text(44:50),'(a3,1x,a3)')mb,ms  ! changed dec7, 2005 , jh
         if(mb.ne.'   ') then
            read(mb,'(f3.1)') mag1
            magaga1='BPDE'
         endif
         if(ms.ne.'   ') then
            read(ms,'(f3.1)') mag2
            magaga2='SPDE'
         endif
         if(year.lt.2004) read(text(53:56),'(f4.1)') rms
         if(year.ge.2004) read(text(54:57),'(f4.1)') rms    ! change july 2005 jh
         if(year.lt.2004) read(text(62:66),'(i5)') nstat    
         if(year.ge.2004) read(text(63:67),'(i5)') nstat    ! change dec 7, 2005 jh
         if(text(24:24).eq.'S') dlat=-dlat
         if(text(35:35).eq.'W') dlon=-dlon
      else
         read(text(5:25),'(i4,4i2,f4.2,f5.3)')
     *   year,month,day,hour,min,sec,dlat
c
c   check if a new month
c
         if(month.ne.old_month) then
            file_open=.false.
            old_month=month
         endif
         read(text(27:32),'(f6.3)') dlon
         mb(1:2)=text(48:49)
         ms(1:2)=text(52:53)
         if(mb(1:2).ne.' ') then
            read(mb(1:2),'(f2.1)') mag1
            magaga1='BPDE'
         endif
         if(ms(1:2).ne.' ') then
            read(ms(1:2),'(f2.1)') mag2
            magaga2='SPDE'
         endif
         read(text(34:37),'(f4.1)') depth
         if(text(26:26).eq.'S') dlat=-dlat
         if(text(33:33).eq.'W') dlon=-dlon
         if(text(57:59).ne.'   ') then
            read(text(57:59),'(f3.2)') mag3
            magaga3=text(61:64)
            if(magaga3(1:1).eq.'D') magaga3(1:1)='C'
         endif
         if(text(67:69).ne.'   ') then
            read(text(67:69),'(f3.2)') mag4
            magaga4=text(71:74)
            if(magaga4(1:1).eq.'D') magaga4(1:1)='C'
         endif
         read(text(41:43),'(i3)') nstat
      endif
C
         do i=1,80
           data(i:i)=' '
         enddo
         agency='PDE'
         WRITE(DATA(2:20),'(I4,1X,2I2,1X,2I2,1X,F4.1)')
     *   YEAR,MONTH,DAY,HOUR,MIN,SEC
         trms='    '
         if(rms.gt.0.0.and.rms.lt.5.0)write(trms,'(f4.1)') rms ! jh oct 08
         if(nstat.gt.999) nstat=999
         WRITE(DATA(46:55),'(A3,I3,a4)') AGENCY,NSTAT,TRMS
         WRITE(DATA(24:43),'(F7.3,F8.3,F5.1)') DLAT,DLON,DEPTH
c
c   reshuffel magnitudes
c
         if(mag3.gt.-9.9) then
            if(mag1.eq.-10.0) then
               mag1=mag3
               magaga1=magaga3
               mag3=-10.0
            elseif(mag2.eq.-10.0) then
               mag2=mag3
               magaga2=magaga3
               mag3=-10.0
            endif
         endif
         if(mag4.gt.-10.0) then
            if(mag1.eq.-10.0) then
               mag1=mag4
               magaga1=magaga4
               mag4=-10.0
            elseif(mag2.eq.-10.0) then
               mag2=mag4
               magaga2=magaga4
               mag4=-10.0
            elseif(mag3.eq.-10.0) then
               mag3=mag4
               magaga3=magaga4
               mag4=-10.0
            endif
         endif
      if(mag1.gt.-9.0) write(data(57:63),'(f3.1,a4)')mag1,magaga1 
      if(mag2.gt.-9.0) write(data(65:71),'(f3.1,a4)')mag2,magaga2 
      if(mag3.gt.-9.0) write(data(73:79),'(f3.1,a4)')mag3,magaga3 
c
c   open file if not already open
c
      if(.not.file_open) then
         write(outfile,'(i4,i2)') year,month
         do i=1,6
           if(outfile(i:i).eq.' ') outfile(i:i)='0'
         enddo
         outfile(7:10)='.CAT'
c
c   set path to where PDE is, if a weekly file, append to a possible older file
c

         write(6,*)'Open file for year and month', year,month
         if(type.eq.'week') then
          open(2,file=top_directory
     *    (1:topdirlen)//dchar//'REA'//dchar//'PDEWE'//dchar//'CAT'
     *    //dchar//outfile,
     *    status='unknown',access='append')
          base='PDEWE'
         else
          open(2,file=top_directory
     *    (1:topdirlen)//dchar//'REA'//dchar//'PDE__'//dchar//'CAT'
     *    //dchar//outfile,
     *    status='unknown')
          base='PDE__'
         endif

         file_open=.true.
      endif
c
c   set event type to distant
c
      data(22:22)='D'
      write(2,'(a)') data
c
c   put in line type
c
      data(80:80)='1'
c
c   put in s-file
c
       data1(1)=data
       data1(2)=' '
       nhead=1
       nrecord=2
       id=0         ! no id line

       call write_sfile
     *(data1,base,proc_time,operator,nhead,nrecord,id)

      goto 50
99    continue
      write(6,*)
      write(6,*)' Number of events converted', nevent
      write(6,'(1x,a,a)') 'Output file name ',outfile
      stop
      end 



      subroutine write_sfile
     *(data,base,proc_time,operator,nhead,nrecord,id)
c
c  routine runs the split function on one event in seisan data base base.
c  data in data
c  only one event is written out. 
c  proc_time and operator as in program update.
c  special for this version is that the file name and id is always taken
c  from the origin time since it is used in connection with update.
c
c
       implicit none

C
C    Seisan library inserts and routines...
C    ======================================
C
       include 'seidim.inc'
       include 'libsei.inc'                ! Open file definitions
C
       external sei open,                  ! Open file routine.
     &          sei close,                 ! Close file routine.
     &          sei code                   ! Error encoder.
C
C    ============= end of list ==========
C
c-- OUTPUT FILE NAME                                   
      CHARACTER*80 OUTFL
      integer nf            ! length of file name
c-- EVENT TYPE, L,R OR D                              
      CHARACTER*1  EVTYPE			
c-- idline
      character*80 idline
c-- TOP DIR FOR REA               
      CHARACTER*40 TOP_DIRECTORY                
c-- dir separator
      character*1 dchar
C-- SYSTEM TIME FOR USED FOR TIME OF OPERATION
      character*14 proc_time 
C-- OPERATOR ID
      CHARACTER*4 OPERATOR
c-- HELP FORMAT LINE 0: NO, 1: YES               
      INTEGER FORMAT_INDICATOR			
c-- RECORDS IN FILE                                
      CHARACTER*80 DATA(*)			
c-- DATES AND TIMES                             
      INTEGER century,YEAR,MONTH		        
     *,DAY,HR,MIN,ISEC                                                          
c-- SECONDS                                                    
      REAL SEC					
      character*1 answer
c-- INDICATOR FOR USE OF DATA BASE                      
      CHARACTER*5 BASE				
c-- NUMBER OF RECORDS FOR EVENT                          
      INTEGER NRECORD				
c-- NUMBER OF HEADERS FOR EVENT                            
      INTEGER NHEAD				
C-- ID LINE NUMBER
      INTEGER ID
c-- TIME IN SEC SINCE 1900 EVENT                    
      DOUBLE PRECISION TIME			
c-- MINIMUM TIME --------------   
      DOUBLE PRECISION MIN_TIME                 
c-- DAY OF YEAR, NOT USED                                    
      INTEGER DOY				
c-- COUNTER                                                  
      INTEGER I,K	
c   length of top_directory
      integer topdirlen
c  agency
      character*3 agency
      character*80 sfil    ! name of sfile returned
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 write unit #1
       integer          write01
c file name
       character*80     chr_file
C                                                                               
C    SET DEFAULTS AND INITIAL PARAMETERS                                        
C
      call topdir(top_directory)
      call get_def_base(agency)
      topdirlen=index(top_directory,' ') -1
      call dir_char(dchar)
      b_f_debug$=.false.                  ! file debugging

C                                                                               
C   CHECK IF FORMAT EXPLANATORY LINE IN FILE                        
C                                                                               
      FORMAT_INDICATOR=0                                                        
      DO K=1,NHEAD                                                              
         IF(DATA(K)(80:80).EQ.'7') FORMAT_INDICATOR=1                           
      ENDDO                                                                     
C                                                                               
C   GET ABS TIME FOR  EVENT, READ YEAR,MONTH AND DAY FROM HEADER,               
C   HR, MIN AND SEC FROM EARLIEST STATION IF NOT GIVEN IN HEADER
C                                                                               
      READ(DATA(1),'(1X,2I2,1X,2I2,1X,2I2,1X,F4.1)')                             
     *CENTURY,YEAR,MONTH,DAY,HR,MIN,SEC
C
C   ASSUME 1900 IF NO CENTURY GIVEN
C
      IF(CENTURY.EQ.0) CENTURY=19
      year=century*100+year                                                               
      evtype=data(1)(22:22)
C                                                                               
C   CHECK IF HR AND MIN IN HEADER                                               
C                                                                               
c-- FIND EARLIEST TIME if phase records available                  
      IF(DATA(1)(12:15).EQ.'    '.and.(nrecord-1).gt.nhead) THEN		
         MIN_TIME=10E20                                                         
         DO I=NHEAD+1,NRECORD-1                                                 
            READ(DATA(I),'(18X,2I2,1X,F5.1)') HR,MIN,SEC                        
c-- ABS TIME              
            CALL TIMSEC(YEAR,MONTH,DAY,HR,MIN,SEC,TIME)	
            IF(TIME.LT.MIN_TIME) MIN_TIME=TIME                                  
         ENDDO                                                                  
         CALL SECTIM(MIN_TIME,YEAR,DOY,MONTH,DAY,HR,MIN,SEC)                    
c--  EARLIEST TIME  
         WRITE(DATA(1)(1:20),'(1X,I4,1X,2I2,1X,2I2,1X,F4.1)') 
     *   YEAR,MONTH,DAY,HR,MIN,SEC                   
         DATA(1)(80:80)='1'
      ENDIF                                                                     
c
C                                                                               
C  GENERATE OUTPUT FILE NAME                                                    
C     
      ISEC=SEC      
C
      IF(BASE.NE.'     '.and.base(1:2).ne.',,') THEN
         WRITE                                                                  
     *   (OUTFL,307)BASE,YEAR,MONTH,DAY,HR,MIN,ISEC,EVTYPE,YEAR,MONTH           
 307     FORMAT(
     *   '/',A5,'/',I4,'/',I2,'/',I2,'-',2i2,'-',i2,a1,'.S',i4,I2)               
C
         DO I=1,34                                                              
            IF(OUTFL(I:I).EQ.' ') OUTFL(I:I)='0'                                
         ENDDO   
         nf=34                                                               
      ELSE                                                                      
         WRITE(OUTFL,303)DAY,HR,MIN,ISEC,EVTYPE,'S',YEAR,MONTH                      
 303     FORMAT(I2,'-',2i2,'-',i2,a1,'.',a1,i4,I2)                                  
         DO I=1,19                                                                 
            IF(OUTFL(I:I).EQ.' ') OUTFL(I:I)='0'                                   
         ENDDO
         nf=19          
      ENDIF
c
c   make id line if not there, else update current id line
c
      if(id.ne.0) idline=data(id)
      if(id.eq.0) THEN
         idline(1:40)= ' ACTION:                   OP:     STATU'
         idline(41:80)='S:               ID:                   I'
         WRITE(IDLINE(31:34),'(A)')OPERATOR
         WRITE(IDLINE(13:26),'(A)')PROC_TIME
         WRITE(IDLINE(9:11),'(A)')'SPL' 
      endif
c
c  update id line
c
      WRITE(IDLINE(61:75),'(i4,5I2)')
     *YEAR,MONTH,DAY,HR,MIN,ISEC
      DO I=61,74
         IF(IDLINE(I:I).EQ.' ') IDLINE(I:I)='0'
      ENDDO
C                                                                               
C  OPEN AND WRITE OUTPUT FILE                                                   
C
 3    continue                 ! get here from below when file did exist
      IF(BASE(1:2).NE.',,') THEN                                                    
         chr_file=' '
         chr_file = top_directory(1:topdirlen)//dchar//'REA'//
     *   outfl(1:nf)
c        write(6,*) chr_file
            call sei open(unknown$+warn$,        ! Open a 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.
            sfil=chr_file
      ELSE
            call sei open(unknown$+warn$,        ! Open a unknown status file.
     &                    ' ',                   ! Prompt file name (n/a).
     &                    outfl,                 ! File name
     &                    write01,               ! Write unit #1
     &                    b_old,                 ! Already exists? (n/a).
     &                    code)                  ! Returned condition.
            sfil=outfl
      ENDIF
      write(6,'(a)') data(1)(1:78)
      
c
c   make new index
c
      if(b_old) then
          write(6,*)' Creating a new id for event'
          write(6,*)' Please confirm (y/n)'
          read(5,'(a)') answer
          if(answer.eq.'y') then
             call inc_id(idline,outfl,nf)
             call sei close (close$,write01,code) ! close
             goto 3                            ! go and try to open again
          endif
      endif
c
  10  continue 
C
C   WRITE FILE
C                                  

C                                                                     
c-- ORIGINAL HEADER LINES FIRST
C   IF NO ID LINE, PUT IN AS NUMBER 2
C
          write(write01,'(a80)',iostat=code) data(1)
          call sei code(fort$,code,write01,b_eof)
c
c  if new id line, write as #2, else where it was before
c
      if(id.eq.0) then
          write(write01,'(a80)',iostat=code) idline
          call sei code(fort$,code,write01,b_eof)
      else
         data(id)=idline
      endif
c
c   write rest of header lines, skip format help lines
c
      if(nhead.ge.2) then
	     do i=2,nhead 
            if(data(i)(80:80).ne.'7') then
               write(write01,'(a80)',iostat=code) data(i)
            endif
	     enddo
      endif
      call sei code(fort$,code,write01,b_eof)
C
c-- write help line 
C
      write(write01,243,iostat=code)
      call sei code(fort$,code,write01,b_eof)
 243  FORMAT(
     *' STAT SP IPHASW D HRMM SECON CODA AMPLIT PERI AZIMU VELO ',
c     *'SNR AR TRES W  DIS CAZ7')              
     *'AIN AR TRES W  DIS CAZ7')              
c-- WRITE REST OF EVENT         
       write(write01,'(a80)',iostat=code)
     * (data(i),i=nhead+1,nrecord)
      call sei code(fort$,code,write01,b_eof)
      call sei close (close$,write01,code)
c
 2    continue
      return                                                                      
      END                                                                       
                                                                                
