c$DEBUG
c     Program to make Seismological Bulletins
c
c     January 1993, Conrad Lindholm
c     Updates:
c     jul 8 93 by jh: VERSION 3.0 *****
c     jul 16        : bul.inp to BUL.INP
c     aug   93      : conrad fixes ?????
c     aug26    by jh: pc adoption, many changes and bugs !!!!
c     sep 10        ; bug, scratch file 8, pc
c     sep 16        : check month range, bug with -onlyhypo
c     sep 21,22     : check for non existing phases, residual 
c     apr 27 94     : print one line pr event
c     jul           : bug with several months
c     nov 16        : august
c     jan 95        : ************ version 5.0 ****************
c     jan 20        : amplitude to 8 digits
c     feb 7         : check for ctl z, pc problem
c     mar 27  95  jh: add page selection
c     april 25      : always give explosion info
c     aug 4         : write amplitudes lt 1
c     aug 16        : bug page selection
c     may 31 96     : enable 8 character phase names
c     sept 96     lo: dont print probable explosions without readings 
c     jan 97      ha: bug in weight in phase
c     May 97      mv: Now possible to change default fontsize for
c                   : event data (see %fontsize=)
c     Nov 5 97    jh: do not print an explosion if only one phase
c     Jan 13 98     : do not print explosions if no epicenter
c-----------------------------------------------------------------------------
c     oct 17 98   jh: -------------   verson 7.0 check -------------      
c                     5 char station check, no change
c     sep 19 2001 jh: dist to integer
c     jan 30 2003 jh: allow negative magnitudes
c     feb 19          diabled temporarely
c     jan 6, 04 jh  : also do not print explosions without location
c                     and/or readings
c     jan 27 04 jh  : do not print event with no phases
c     jan 5  07 jh  : now really fix so neg magnitudes can be printed
c
c     To make a defintion in PostScript:  /t {postscript_command} def
c         t is after this synonymous with postscript_command
c
C  Font index
C         1 = Times-Roman
C         2 = Times-Italic
C         3 = Times-Bold
C         4 = Helvetica
C         5 = Helvetica-Oblique
C         6 = Helvectica-Bold
C         7 = Courier               Must be used on tabular data !!!!
C         8 = Courier-Oblique
C         9 = Courier-Bold
c
c  Input files:
c         A Nordic formatted F-file
c         A file called "BUL.INP" which is expected to be found in ~/DAT
c  Output file:
c         A PostScript bulletin file: "bul.ps"
c
      
      implicit none
      include 'seidim.inc'
      character*80 data(max_data),infile/' '/
      character*60 top_directory,timecard,hypcard,agcard,depcard
      character*150 card,dummy,dummy2,arg,outcard
      character*1 type, exp,t1,t2,t3,cult,answer
      character*1 ucase,fixed,ns,ew
      character*2 intscale
      character*3 agency,ag1,ag2,ag3
      character*10 disttype
      character*80 args(20)
      character tmonth(12)*9
      integer nstat,nhead,nrecord,nphas
      integer year,month,day,hour,min
      integer oport,font
      integer nargs, nars,iargc
      integer maxint,id
      real sec
      real xdummy
      real lat,lon,depth,rms
      real size,x,y,dx,dy,xleft,ytop,ybottom,fontsize
      real m1,m2,m3,xminmag
      real rmspos,hyppos,agpos,indent,deppos
      integer firstmonth,lastmonth,npage
      integer i,j,k,nbend
      logical pc,unix,vax,frontpage,center,exist
      logical onlyhypo,nofrontpage,minmag
      integer*2 i2,istatus

c
c ------ Initialize
c
c      data tmonth / 'Enero       ', 'Febrero     ', 
c     &'Marzo       ', 'Abril       ',
c     &'Mayo        ', 'Junio       ', 'Julio     ', 
c     &'Agosto      ', 'Septiembre  ',
c     &'Octubre     ', 'Noviembre   ', 'Diciembre  ' /
      data tmonth / 'January  ', 'February ', 
     &'March    ', 'April     ',
     &'May      ', 'June      ', 'July     ', 
     &'August   ', 'September ',
     &'October  ', 'November  ', 'December ' /


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
      frontpage = .false.
      nofrontpage = .false.
      onlyhypo = .false.
      center = .false.
      minmag = .false.
c
c------- Define standard top bottom of the page and line spacing in incheottoms
c------- Default font is Times-Roman  (1)
c
c------- rmspos =x position of rms information in inches
c------- hyppos =x position of hypoinformation in inches
c------- agpos  =x position of agencyinformation in inches
      deppos = 5.5
      rmspos = 5.5
      hyppos = 3.55
      agpos = 6.25

      indent = 1.1
      xleft = 1.0
      ytop = 10.5
      ybottom = 1.00
      dy = 0.15
      font = 1
      fontsize = 0.15
      npage = 1
c
c------ Find arguments passed
c
       call get_arguments(nars,args)
       if(nars .ne. 0)then
	do i = 1,nars
      i2=i
	 if(args(i)(1:2).eq.'-h'.or.args(i)(1:2).eq.'-H')then
	   write(*,*)'  Options:'
	   write(*,*)' -frontpage: Only frontpages are printed.'
	   write(*,*)' -nofrontpage: No frontpages are printed.'
	   write(*,*)' -onlyhypo: Only hypocenter solutions are printed.'
	  write(*,*)' -minmag x.x : Only hypocenter solutions are printed',
     +'          if magnitude is lower than the requested.'
	   stop
	 endif
	 if(args(i)(1:10) .eq. '-frontpage')then
	   frontpage = .true.
	 endif
	 if(args(i)(1:9) .eq. '-onlyhypo')then
	   onlyhypo = .true.
	 endif
	 if(args(i)(1:12) .eq. '-nofrontpage')then
	   nofrontpage = .true.
	 endif
	 if(args(i)(1:7) .eq. '-minmag')then
           i2 = i2 + 1
            read(args(i2),'(f5.1)') xminmag
	   minmag = .true.
	 endif
	enddo
      endif
c
c------- Get first and last month in the data
c
      write(*,'(a,$)')' Enter name of your file (Nordic format): '
      read(*,'(a)')infile

      open(1,file=infile,status='old')
c
c   scratch file for interactive input
c
      open(8,status='scratch')
      i = 0
1     call indata(1,nstat,nphas,NHEAD,NRECORD,TYPE,EXP,DATA,id)
      if(nrecord .eq. 0) go to 2
      read(data(1)(2:8),'(i4,1x,i2)')year,month
      i = i + 1
      if(i .eq. 1)firstmonth = month
      go to 1
2     lastmonth = month
      close(1)
      if(firstmonth.le.0) then
         write(6,*)' Something wrong with data of first event'
         stop
      endif
      if(lastmonth.gt.12) then
         write(6,*)' Something wrong with date of last event'
         stop
      endif
      write(6,'(5a)') ' You are going to make a bulletin for the ','
     *months ',tmonth(firstmonth), ' to ',tmonth(lastmonth)
      write(6,'(a,$)')' Is that ok (y/n)'
      read(5,'(a1)') answer
      if(answer.ne.'Y'.and.answer.ne.'y') stop
      

c
c-------- Make the first page
c
      oport = 2
      call PSOPEN('bul.ps',6,oport,font)

      if(nofrontpage)then
	  call psfont(oport,font,fontsize)
          go to 10
      endif

      call topdir(top_directory)
      i=index(top_directory,' ') - 1
      inquire(file='BUL.INP',exist=exist)
      if(exist)then
        open(1,file='BUL.INP',status='old')
      else
        open(1,file=top_directory(1:i)//'/DAT/BUL.INP',status='old')
      endif
c
c----- Top left corner of page is x = 1 inch and y = 11 inches
c
      x = xleft
      y = ytop

3     card= ' '
      read(1,'(a)',end=10)card
c
c   check for ctlz, a problem on pc files moved forth and back on the net
c
      do i=1,80
        if(ichar(card(i:i)).eq.26) goto 3
      enddo
      if( card(1:1) .eq. '#') go to 3
      if( card(1:10) .eq. '%Next Page') go to 5
c
c----- Read position, size etc. of the next line
c
      if( card(1:6) .eq. '%xpos=')then
         rewind 8
         write(8,'(a)') card(7:80)
         rewind 8
         read(8,*)x
conrad	 read(card(7:80),*)x
	 go to 3
      endif
      if( card(1:6) .eq. '%ypos=')then
conrad	 read(card(7:80),*)y
         rewind 8
         write(8,'(a)') card(7:80)
         rewind 8
         read(8,*)y
         go to 3
      endif
      if( card(1:6) .eq. '%font=')then
conrad	  read(card(7:80),*)font
         rewind 8
         write(8,'(a)') card(7:80)
         rewind 8
         read(8,*)font
	  call psfont(oport,font,size)
          go to 3
      endif
      if( card(1:6) .eq. '%size=')then
conrad	  read(card(7:80),*)size
         rewind 8
         write(8,'(a)') card(7:80)
         rewind 8
         read(8,*)size
	  call psfont(oport,font,size)
          go to 3
      endif
c changes default fontsize value
      if( card(1:10) .eq. '%fontsize=')then
         rewind 8
         write(8,'(a)') card(11:80)
         rewind 8
         read(8,*)fontsize
         goto 3
      endif
      if( card(1:7) .eq. '%Months') then
conrad	write(card,*)(tmonth(i),i=firstmonth,lastmonth)
        
c       write(card,'(a)')(tmonth(i),i=firstmonth,lastmonth)
        card(1:9)=tmonth(firstmonth)
        if(lastmonth.ne.firstmonth) then
           card(10:13)=' to '
           card(14:22)=tmonth(lastmonth)
        endif
        if(center)then
  	  call pscenter(oport,x,y,card,NBEND(card))
          center = .false.
        else
          call pswrite(oport,x,y,card,NBEND(card))
        endif
	go to 3
      endif
      if( card(1:5) .eq. '%Year') then
	write(card,'(i4)')year
        if(center)then
  	  call pscenter(oport,x,y,card,NBEND(card))
          center = .false.
        else
          call pswrite(oport,x,y,card,NBEND(card))
        endif
	go to 3
      endif
      if( card(1:7) .eq. '%center') then
	center = .true.
	go to 3
      endif

      if(center)then
	call pscenter(oport,x,y,card,NBEND(card))
      else
        call pswrite(oport,x,y,card,NBEND(card))
      endif
      call position(x,y,dx,dy)
      center = .false.

      go to 3

5     call psclear(oport)
      x = xleft
      y = ytop
      go to 3

10    continue
      if(frontpage) then
         write(6,*)' You have selected to only print front pages'
         go to 999
      endif
c
c---------------------------------------------
c---------- Now start to work with the data
c---------------------------------------------
c
      call psclear(oport)
      x = xleft
      y = ytop


      open(1,file=infile,status='old')
7     call indata(1,nstat,nphas,NHEAD,NRECORD,TYPE,EXP,DATA,id)
      if(nrecord .eq. 0) go to 999
c
c dont print events that are probable explosions or explosion
c without phase readings
c
      if (EXP.EQ.'P'.or.exp.eq.'p'.or.exp.eq.'E') THEN
        if (NRECORD-1-NHEAD.EQ.0) THEN
          GOTO 7
        ENDIF

      if(nphas.lt.2) goto 7   
c
c   also do not print if no hypocenter
c
        if(data(1)(24:38).eq.'               ') goto 7
      ENDIF
c
c   if no phases at all, skip
c
      if(nphas.lt.1) goto 7   !jh jan 27 03
        
      write(6,'(a)')data(1)
      if(type .eq. 'L')disttype='  Local   '
      if(type .eq. 'R')disttype='  Regional'
      if(type .eq. 'D')disttype='  Distant '

      read(data(1),100)year,month,day,hour,min,sec,
     + lat,lon,depth,fixed,agency,rms,m1,t1,ag1,m2,
     + t2,ag2,m3,t3,ag3
100   format(1x,i4,1x,2i2,1x,2i2,1x,f4.0,3x,f7.3,f8.3,
     + f5.0,a1,1x,a3,3x,f4.0,3(f4.1,a1,a3))
c
c------- Write event header card
c
      write(timecard,300)tmonth(month),day,year,hour,min,sec
300   format(a,' ',i2,'  ',i4,'   Hour:  ',i2,':',i2,' ',f4.1)

      ns = 'N'
      ew = 'E'
      if(lat .lt. 0.001)then
         ns = 'S'
         lat = -lat
      endif
      if(lon .lt. 0.001)then
         ew = 'W'
         lon = -lon
      endif
      write(hypcard,400)lat,ns,lon,ew
400   format('Lat:  ',f6.2,a1,'    Lon:  ',f7.2,a1)

      write(depcard,500)int(depth),fixed
500   format('Depth:',i3,a1)

      write(agcard,600)'Agency: ',agency,disttype
600   format(a,a3,'  ',a10)

      if(lat .eq. 0.0 .and. lon .eq. 0.0)then
        hypcard = ' '
        depcard = ' '
      endif

c
c----- New page if the header comes too low
c
      if(onlyhypo)then
        xdummy = ybottom + 0.75
      else
        xdummy = ybottom + 1.0
      endif
      if(y .lt. xdummy)then
	write(dummy,'(i3)')npage
	x = 4.0
	y = 0.5
	call psfont(oport,font,fontsize)
	CALL PSWRITE(oport,x,y,dummy,3)
	npage = npage + 1
	CALL PSCLEAR(oport)
	call psfont(oport,3,fontsize)
	x = xleft
	y = ytop
      else
	call psfont(oport,3,fontsize)
      endif
c
c------- write main header; Time and position
c
      call position(x,y,dx,dy)
      call pswrite(oport,x,y,timecard,NBEND(timecard))
      call pswrite(oport,hyppos,y,hypcard,NBEND(hypcard))
      call pswrite(oport,deppos,y,depcard,NBEND(depcard))
      call pswrite(oport,agpos,y,agcard,NBEND(agcard))
c
c------- Write Magnitudes and RMS INFO
c
      card = ' '
      write(card,301)m1,'M',t1,ag1,m2,'M',t2,
     + ag2,m3,'M',t3,ag3
301   format('Magnitudes:  ',3(f4.1,2a1,1x,a3,4x))
cjh to be fixd to report neg mag
c     if(m1 .le. 0.0)card(14:26) = '       '
c     if(m2 .le. 0.0)card(27:39) = '       '
c     if(m3 .le. 0.0)card(40:52) = '       '
c
c   report magnitude if agency is not blank
c   assuming then the magnitude is not valid
c
      if(ag1 .eq.'   ')card(14:26) = '       '
      if(ag2 .eq.'   ')card(27:39) = '       '
      if(ag3 .eq.'   ')card(40:52) = '       '

      if(m1.ne.0.0 .or. m2.ne.0.0 .or. m3.ne.0.0 )then
        call position(x,y,dx,dy)
        call pswrite(oport,indent,y,card,NBEND(card))
      endif
c
c---- RMS iNfo written on fixed 5.0 inches x-coordinate
c
      if(lat .ne. 0.0 .and. lon .ne. 0.0)then
        write(card,302)rms
302     format('Rms:',f4.1,' secs')
        if(exp .eq. 'E')card(20:29)='Explosion'
        if(exp .eq. 'P')card(20:36)='Likely Explosion'
        if(m1.eq.0.0 .and. m2.eq.0.0 .and. m3.eq.0.0 )then
          call position(x,y,dx,dy)
        endif
        call pswrite(oport,rmspos,y,card,NBEND(card))
      else
        if(exp.eq.'E'.or.exp.eq.'P') then
            if(exp .eq. 'E')card(20:29)='Explosion'
            if(exp .eq. 'P')card(20:36)='Likely Explosion'
            card(1:11)='           '   ! take magnitude away
            if(m1.eq.0.0 .and. m2.eq.0.0 .and. m3.eq.0.0 )then
               call position(x,y,dx,dy)
            endif
            call pswrite(oport,rmspos,y,card,NBEND(card))
        endif
      endif
c
c------- Write extra "Bul-headers" and macro information
c
      do i = 2,nhead
	if(data(i)(80:80).eq.'3'.and.data(i)(1:5).eq.' Bul:')then
	  write(card,'(a)')data(i)(6:79)
	  call position(x,y,dx,dy)
	  call pswrite(oport,indent,y,card,NBEND(card))
	endif
        if(data(i)(80:80) .eq. '2')then
          read(data(i),200)cult,maxint
200       format(24x,a1,2x,i2)
	  dummy = ' '
	  if(cult .eq. 'C')dummy = '  Casualties reported'
	  if(cult .eq. 'D')dummy = '  Damage reported'
	  if(maxint .gt. 0.)then
            write(card,401)maxint,dummy(1:21)
401         format('Earthquake was felt;   Maximum intensity: ',
     +       i2,'  ',a)
          else
            write(card,'(a)')'Earthquake was felt'
          endif
        call position(x,y,dx,dy)
        call pswrite(oport,indent,y,card,NBEND(card))
        endif
	   
      enddo
c
c-------- If only hypocenter wanted, then skip the rest
c
      xdummy = max(m1,m2,m3)
      if(onlyhypo .or. (minmag .and. xdummy .lt. xminmag))then
        card = ' '
        call position(x,y,dx,dy)
        call pagecheck(x,y,ybottom,xleft,ytop,npage,oport,
     +                                        font,fontsize)
        call psfont(oport,font,fontsize)
        call pswrite(oport,x,y,card,NBEND(card))
        go to 7
      endif

c
c-------- Now read and write phase information; Font Courirer
c
      call psfont(oport,7,fontsize)
      outcard=' STAT CO DIST AZI PHASE '
      dummy  =' P HRMN SECON TRES CODA'
      dummy2 =' AMPL PERI BAZ ARES VELO  WT'
      card = outcard(1:24)//dummy(1:23)//dummy2(1:28)
      call position(x,y,dx,dy)
      call pagecheck(x,y,ybottom,xleft,ytop,npage,oport,
     +                                        font,fontsize)
      call pswrite(oport,x,y,card,NBEND(card))
      do i = nhead+1,nrecord
	card = data(i)
	call position(x,y,dx,dy)
        call pagecheck(x,y,ybottom,xleft,ytop,npage,oport,
     +                                        font,fontsize)
        call reformat(card,outcard)
	call pswrite(oport,x,y,outcard,NBEND(outcard))
      enddo
c
c--------- Back for a new event; Font is reset   
c

      go to 7

999   continue
      write(dummy,'(i3)')npage
      x = 4.0
      y = 0.5
      call psfont(oport,font,fontsize)
      CALL PSWRITE(oport,x,y,dummy,3)

      write(*,*)' Bulletin is now written in the file: bul.ps'
      call select_pages(oport)  ! page selection
      call psclose(oport)

      end
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine position(x,y,dx,dy)
      real x,y,dx,dy
c     Position is given in units of inches where
c     origo is in the lower left corner of an A4 page

      y = y - dy

      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      SUBROUTINE PSOPEN(CNAME,ILEN,IUNIT,font)
      CHARACTER*(*) CNAME
      integer font
C Input: CNAME, ILEN
C Output: IUNIT
      open(unit=iunit,file=cname(1:ilen),status='unknown')

      WRITE(IUNIT,'(A23)') '%!PS-Adobe-2.0 EPSF-2.0'
      WRITE(IUNIT,'(A26)') '%%BoundingBox: 0 0 539 539'
      WRITE(IUNIT,'(A13)') '%%EndComments'
C defintions necessary for pscenter routine
      WRITE(IUNIT,'(A12)') '/WIDTH 8 def'
      WRITE(IUNIT,'(A37)') '% Usage: ypos pagewidth string center'
      WRITE(IUNIT,'(A35)') '/center { stringwidth pop sub 2 div'
      WRITE(IUNIT,'(A17)') 'exch moveto } def'
C transform from 1 unit = 1/72 inch to 1 unit = 1 inch
      WRITE(IUNIT,'(A11)') '72 72 scale'
      CALL PSFONT(IUNIT,font,0.15)
C save these definitions
      WRITE(IUNIT,'(A5)') 'gsave'
      RETURN
      END
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      SUBROUTINE PSCLOSE(IUNIT)
      WRITE(IUNIT,'(A8)') 'showpage'
      WRITE(IUNIT,'(A8)') 'grestore'
      close(unit=IUNIT)
      RETURN
      END
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      SUBROUTINE PSCLEAR(IUNIT)
      WRITE(IUNIT,'(A8)') 'showpage'
C restore old definitions      
      WRITE(IUNIT,'(A8)') 'grestore'
C save these definitions
      WRITE(IUNIT,'(A5)') 'gsave'
      RETURN
      END
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      SUBROUTINE PSCENTER(IUNIT,X,Y,STR,ILEN)
      REAL X,Y
C Units in inches, (0,0) at lower-left corner of page
      CHARACTER*(*) STR
      INTEGER ILEN
      WRITE(IUNIT,*) X, Y, ' moveto'
conrad      WRITE(IUNIT,*) Y,' WIDTH '//'('//STR(1:ILEN)//')',' center'
conad      WRITE(IUNIT,*) '('//STR(1:ILEN)//') show'
      WRITE(IUNIT,200) Y,STR(1:ILEN)
 200  format(f10.2,' WIDTH (',a,') center')
      WRITE(IUNIT,201) STR(1:ILEN)
 201  format('(',a,') show')
      RETURN
      END
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      SUBROUTINE PSWRITE(IUNIT,X,Y,STR,ILEN)
      REAL X,Y
C Units in inches, (0,0) at lower-left corner of page
      CHARACTER*(*) STR
      INTEGER ILEN
      WRITE(IUNIT,*) X, Y, ' moveto'
conrad      WRITE(IUNIT,*) '('//STR(1:ILEN)//') show'
      write(iunit,201) str(1:ilen)
 201  format('(',a,') show')
      RETURN
      END
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      SUBROUTINE PSFONT(IUNIT,IFONT,SIZE)
      INTEGER IUNIT,IFONT
      REAL SIZE
C IUNIT - File unit number
C IFONT - Font index
C         1 = Times-Roman
C         2 = Times-Italic
C         3 = Times-Bold
C         4 = Helvetica
C         5 = Helvetica-Oblique
C         6 = Helvectica-Bold
C         7 = Courier
C         8 = Courier-Oblique
C         9 = Courier-Bold
C SIZE  - Size of fonts in inches
C
C Note that the Courier font family (font 7-9) is a monospaced,
C or fixed-pitch (fixed width) font suitable for use in
C tabular material, program listings, or word processing.
C
      CHARACTER*17 CFONTS(9)
      INTEGER      LFONTS(9)
      DATA CFONTS / 'Times-Roman',
     +              'Times-Italic',
     +              'Times-Bold',
     +              'Helvetica',
     +              'Helvetica-Oblique',
     +              'Helvectica-Bold',
     +              'Courier',
     +              'Courier-Oblique',
     +              'Courier-Bold' /
      DATA LFONTS / 11, 12, 10, 9, 17, 15, 7, 15, 12 /
 
      IF2 = MIN0(9,MAX0(1,IFONT))
 
      WRITE(IUNIT,'(A)') '/'//CFONTS(IF2)(1:LFONTS(IF2))//' findfont'
      WRITE(IUNIT,*) SIZE,' scalefont'
      WRITE(IUNIT,'(A7)') 'setfont'
      RETURN
      END

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C NBEND    UT-F-U   Created: 8/11/89 Copied : 08/28/89 Made at NORSAR
      INTEGER FUNCTION NBEND(STRING)
      CHARACTER*(*) STRING
C.======================================================================
C.    PURPOSE
C     find_Non_Blank_END_of_string                                  UT<<
C.----------------------------------------------------------------------
C.    KEYWORDS
C.----------------------------------------------------------------------
C.    INPUT
C..   STRING - Character string
C
C.    OUTPUT
C..   NBEND  - Position of last non blank character in string
C.----------------------------------------------------------------------
C.    PROGRAMMER    Stein Holger Pettersen
C.    CREATION_DATE 19 Jun 1989
C.    MADE_AT  NTNF/NORSAR
C     Pb. 51
C     N-2007 Kjeller
C
C.    MODIFICATION
C.    CORRECTION
C.======================================================================
 
      LS = LEN(STRING)
      DO 10 I = LS,1,-1
         IF (STRING(I:I).NE.' ') GO TO 20
   10 CONTINUE
      I = 1
 
   20 NBEND = I
      RETURN
      END
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      character*1 function ucase(a)
c     convert lower case single char to upper case - machine independent
      
      character*1 chr(26),ucchr(26),a
      data chr/'a','b','c','d','e','f','g','h','i','j','k','l','m',
     &'n','o','p','q','r','s','t','u','v','w','x','y','z'/
      data ucchr/'A','B','C','D','E','F','G','H','I','J','K','L','M',
     &'N','O','P','Q','R','S','T','U','V','W','X','Y','Z'/
      do 10 i=1,26
        if(a.eq.chr(i))then
          ucase=ucchr(i)
          return
        endif
10    continue
      ucase=a
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine pagecheck(x,y,ybottom,xleft,ytop,npage,oport,
     +                                        font,size)
      real x,y,ybottom,xleft,ytop,size
      integer font
      character*100 dummy
	  integer oport

      if(y .lt. ybottom )then
	write(dummy,'(i3)')npage
	x = 4.0
	y = 0.5
	call psfont(oport,font,size)
	CALL PSWRITE(oport,x,y,dummy,3)
	npage = npage + 1
	CALL PSCLEAR(oport)
c----- Font must be 7 (Courier)
	call psfont(oport,7,size)
	x = xleft
	y = ytop
      endif
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine reformat(incard,outcard)
      character*80 incard,outcard
      character*1 uncertain
      real ampl,peri,bazi,wt
      real xdist 		! distance
      integer idist		! distance

c      outcard = 
c  +' STAT CO DIST AZI PHAS P HRMN SECON TRES CODA AMPL PERI BAZ ARES VELO  WT'
c
      outcard = ' '

c
c  put in if time not accurate
c
      uncertain=' '
      if(incard(15:15) .eq. '9')then
        uncertain = '*'
      endif
c
c   remove input weight from incard if not a phase
c
      if(incard(15:15).eq.'0'.or.incard(15:15).eq.'1'.or.incard(15:15)
     *.eq.'3'.or.incard(15:15).eq.'4'.or.incard(15:15).eq.'9'.or.
     *incard(15:15).eq.'2') then
      if(incard(16:16).ne.' ') then
        continue             ! character 15 must be part of phase name
      else 
        incard(15:15)=' '    ! character 15 is probably an input weight
      endif
      endif
      outcard(1:8) = incard(1:8)
c
c   distance to integer, jh sep 2001
c
      read(incard(71:75),'(f5.0)') xdist
      xdist=xdist+0.5
      idist=xdist
      if(xdist.gt.0.51) write(outcard(9:13),'(i5)') idist
cjh sep 2001      outcard(9:13) = incard(71:75)
      outcard(15:17) = incard(77:79)
      outcard(19:27) = incard(10:18)
      outcard(28:31) = incard(19:22)
      outcard(33:37) = incard(24:28)
      outcard(38:42) = incard(64:68)
      outcard(44:47) = incard(30:33)
      if(outcard(27:27).eq.' ') outcard(27:27)=uncertain ! assume long phase 
                                                         ! name has ok time
      read(incard(34:40),'(g8.0)')ampl
      if(ampl.ne.0.0) then
         if(ampl.gt.1.0) then
            write(outcard(45:52),'(i8)')nint(ampl)
         else
            write(outcard(45:52),'(f8.2)') ampl
         endif
      endif
      read(incard(42:45),'(f4.0)')peri
      if(peri.ne.0.0)write(outcard(54:57),'(f4.1)')peri
      read(incard(47:51),'(f5.0)')bazi
      if(bazi.ne.0.0)write(outcard(58:61),'(i4)')nint(bazi)
      outcard(64:66) = incard(61:63)
      outcard(68:71) = incard(53:56)
      read(incard(69:70),'(i2)')iwt
       wt = real(iwt)/10.
      write(outcard(73:75),'(f3.1)')wt
c
c   check for nonexisting phase
c
      if(incard(69:70).eq.'-9') then
         outcard(73:75)='  '
         outcard(15:17)='   '
         outcard(39:42)='    '
       endif
      if(incard(69:70) .eq. ' ')outcard(73:75)=' '

      return
      end
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine select_pages(oport)
c
c  edit output file to select certain pages
c
      implicit none
      include 'libsei.inc'
      character*80 text
      integer first_page, last_page   ! first and last page to use
      integer code   ! error code
      integer npage  ! page counter
      integer oport  ! file unit for original file
c
      write(6,*)' Select pages, give first and last, return for all'
      read(5,'(a)') text
      if(text(1:2).eq.'  ') return           ! stop if default
      call sei get values( 2, text, code )   ! Extract 2 values.
      code = e_ok$                           ! re-store.
      first_page = array$(1)+1                    ! Retrieve.
      last_page =  array$(2)+1                    ! Ditto.
c
c   open selected page output file
c
      open(22,file='bul1.ps',status='unknown')
      rewind oport
c
c   read foreward to pages wanted, always leave first
c
      npage=-2
 1    continue
      read(oport,'(a)',end=99) text
      if((npage.ge.first_page.and.npage.le.last_page).or.npage.eq.-2) 
     *write(22,'(a)') text               ! write out page if set
      if(text(1:8).eq.'showpage') then
         npage=npage+1
         write(6,*)' Page ',npage
      endif
      goto 1
c
c  end of file
c
  99  continue
      backspace oport
	  backspace 22
      call psclose(22)

      close(22)
      write(6,*)' Selected pages in file bul1.ps'
      return
      end
