      subroutine newtillmix(jj,bmix)

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine mixes residue and nutrients during tillage and
!!    biological mixing
!!    New version developed by Armen R. Kemanian in collaboration with Stefan Julich and Cole Rossi
!!    Mixing was extended to all layers
!!    A subroutine to simulate stimulation of organic matter decomposition was added
!!    March 2009: testing has been minimal and further adjustments are expected
!!    use with caution

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name          |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    bactlpq(:)    |# colonies/ha |less persistent bacteria in soil solution
!!    bactlps(:)    |# colonies/ha |less persistent bacteria attached to soil
!!                                 |particles
!!    bactpq(:)     |# colonies/ha |persistent bacteria in soil solution
!!    bactps(:)     |# colonies/ha |persistent bacteria attached to soil
!!                                 |particles
!!    cnop          |none          |SCS runoff curve number for moisture
!!                                 |condition II
!!    curyr         |none          |current year of simulation
!!    deptil(:)     |mm            |depth of mixing caused by tillage
!!                                 |operation
!!    effmix(:)     |none          |mixing efficiency of tillage operation
!!    sol_nly(jj)          |none          |maximum number of soil layers
!!    npmx          |none          |number of different pesticides used in
!!                                 |the simulation
!!    nro(:)        |none          |sequence number of year in rotation
!!    ntil(:)       |none          |sequence number of tillage operation within
!!                                 |current year
!!    nyskip        |none          |number of years to skip output printing/
!!                                 |summarization
!!    sol_actp(:,:) |kg P/ha       |amount of phosphorus stored in the
!!                                 |active mineral phosphorus pool
!!    sol_aorgn(:,:)|kg N/ha       |amount of nitrogen stored in the active
!!                                 |organic (humic) nitrogen pool
!!    sol_fon(:,:)  |kg N/ha       |amount of nitrogen stored in the fresh
!!                                 |organic (residue) pool
!!    sol_fop(:,:)  |kg P/ha       |amount of phosphorus stored in the fresh
!!                                 |organic (residue) pool
!!    sol_nh3(:,:)  |kg N/ha       |amount of nitrogen stored in the ammonium
!!                                 |pool in soil layer
!!    sol_nly(:)    |none          |number of soil layers
!!    sol_no3(:,:)  |kg N/ha       |amount of nitrogen stored in the
!!                                 |nitrate pool.
!!    sol_orgn(:,:) |kg N/ha       |amount of nitrogen stored in the stable
!!                                 |organic N pool
!!    sol_orgp(:,:) |kg P/ha       |amount of phosphorus stored in the organic
!!                                 |P pool
!!    sol_pst(:,:,:)|kg/ha         |amount of pesticide in layer
!!    sol_rsd(:,:)  |kg/ha         |amount of organic matter in the soil
!!                                 |classified as residue
!!    sol_solp(:,:) |kg P/ha       |amount of phosohorus stored in solution
!!    sol_stap(:,:) |kg P/ha       |amount of phosphorus in the soil layer
!!                                 |stored in the stable mineral phosphorus pool
!!    sol_z(:,:)    |mm            |depth to bottom of soil layer
!!    sumix(:)      |none          |sum of mixing efficiencies in HRU
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name          |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    bactlpq(:)    |# colonies/ha |less persistent bacteria in soil solution
!!    bactlps(:)    |# colonies/ha |less persistent bacteria attached to soil
!!                                 |particles
!!    bactpq(:)     |# colonies/ha |persistent bacteria in soil solution
!!    bactps(:)     |# colonies/ha |persistent bacteria attached to soil
!!                                 |particles
!!    ntil(:)       |none          |sequence number of tillage operation within
!!                                 |current year
!!    sol_actp(:,:) |kg P/ha       |amount of phosphorus stored in the
!!                                 |active mineral phosphorus pool
!!    sol_aorgn(:,:)|kg N/ha       |amount of nitrogen stored in the active
!!                                 |organic (humic) nitrogen pool
!!    sol_fon(:,:)  |kg N/ha       |amount of nitrogen stored in the fresh
!!                                 |organic (residue) pool
!!    sol_fop(:,:)  |kg P/ha       |amount of phosphorus stored in the fresh
!!                                 |organic (residue) pool
!!    sol_nh3(:,:)  |kg N/ha       |amount of nitrogen stored in the ammonium
!!                                 |pool in soil layer
!!    sol_no3(:,:)  |kg N/ha       |amount of nitrogen stored in the
!!                                 |nitrate pool.
!!    sol_orgn(:,:) |kg N/ha       |amount of nitrogen stored in the stable
!!                                 |organic N pool
!!    sol_orgp(:,:) |kg P/ha       |amount of phosphorus stored in the organic
!!                                 |P pool
!!    sol_rsd(:,:)  |kg/ha         |amount of organic matter in the soil
!!                                 |classified as residue
!!    sol_solp(:,:) |kg P/ha       |amount of phosohorus stored in solution
!!    sol_stap(:,:) |kg P/ha       |amount of phosphorus in the soil layer
!!                                 |stored in the stable mineral phosphorus pool
!!    sumix(:)      |none          |sum of mixing efficiencies in HRU
!!    min_res(:)	|kg/ha		   |Min residue allowed due to implementation of
!!                                 |residue managment in the OPS file.
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    bmix        |none          |biological mixing efficiency: this
!!                               |number is zero for tillage operations
!!    dg          |mm            |depth of soil layer
!!    dtil        |mm            |depth of mixing
!!    emix        |none          |mixing efficiency
!!    jj          |none          |HRU number
!!    k           |none          |counter
!!    l           |none          |counter
!!    nl          |none          |number of layers being mixed
!!    smix(:)     |varies        |amount of substance in soil profile
!!                               |that is being redistributed between
!!                               |mixed layers
!!    thtill(:)   |none          |fraction of soil layer that is mixed
!!    sol_msm					 | sol_mass mixed
!!    sol_msn					 | sol_mass not mixed
!!    maxmix      |none          | maximum mixing eff to preserve specified minimum residue cover
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Min, Max
!!    SWAT: curno

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use parm

      integer, intent (in) :: jj
      real, intent (in) :: bmix
!$$$$$$       integer :: l, k, nl, a
      integer :: l, k              !CB 12/2/09 nl and a are not used.
      real :: emix, dtil, XX, WW1, WW2, WW3, WW4, maxmix
!$$$$$$       real :: thtill(sol_nly(jj)), smix(20+npmx)
      !!by zhang
      !!=============
      real :: smix(22+npmx+12)        !CB 12/2/09 thtill is not used. mjw rev 490
      !!changed the dimension from 22 + npmx to 22 + npmx + 12
      !!by zhang
      !!=============
      real :: sol_mass(sol_nly(jj))
      real :: sol_thick(sol_nly(jj)), sol_msm(sol_nly(jj))
      real :: sol_msn(sol_nly(jj))

      XX = 0.
      WW1 = 0.
      WW2 = 0.
      WW3 = 0.
      WW4 = 0.
      emix = 0.
      dtil = 0.
      if (bmix > 1.e-6) then
        !! biological mixing
        emix = bmix !bmix MJW (rev 412)
        dtil = Min(sol_z(sol_nly(jj),jj), 50.) ! it was 300.  MJW (rev 412)
      else
        !! tillage operation
        emix = effmix(idtill)
        dtil = deptil(idtill)
      end if
      ! -------------------------------- Original D. Moriasi code replaced by code below
!	Drainmod  07/2006
!      if(itill(jj) == 1) then
!	  cumei(jj) = 0.
!	  cumeira(jj) = 0.
!	  cumrt(jj) = 0.
!        cumrai(jj) = 0.
!	  ranrns_hru(jj) = ranrns(idtill)
!      end if
!!    Drainmod 7/2006
! --------------------------------------------------------------------
        if (idtill.GE. 1) then ! Updated dynamic depressional storage D.Moriasi 4/8/2014
          cumei(jj)   = 0.
	    cumeira(jj) = 0.
	    cumrt(jj)   = 0.
          cumrai(jj)  = 0.
	    ranrns_hru(jj) = ranrns(idtill)
        end if
! --------------------------------------------------------------------

      !!by zhang DSSAT tillage
      !!=======================
      !!    deptil(:)   |mm  |depth of mixing caused by tillage operation
      !jj is hru number
      if (cswat == 2) then
          tillage_days(jj) = 0
          tillage_depth(jj) = dtil
          tillage_switch(jj) = 1
      end if
      !!by zhang DSSAT tillage
      !!=======================

      smix = 0.
      sol_mass = 0.
      sol_thick = 0.
      sol_msm = 0.
      sol_msn = 0.

	!! incorporate bacteria - no mixing - lost from transport
      if (dtil > 10.) then
        bactpq(jj) = bactpq(jj) * (1. - emix)
        bactps(jj) = bactps(jj) * (1. - emix)
        bactlpq(jj) = bactlpq(jj) * (1. - emix)
        bactlps(jj) = bactlps(jj) * (1. - emix)
	end if

	!! calculate max mixing to preserve target surface residue MJW rev 490
	!! Assume residue in all other layers is negligible to simplify calculation and remove depth dependency
      if (min_res(jj) > 1. .and. bmix < 0.001) then
	  maxmix = 1 - min_res(jj)/sol_rsd(1,jj)
	  if (maxmix <0.05)  maxmix = 0.05
	  if (emix > maxmix)  emix = maxmix
      end if

      do l=1, sol_nly(jj)
        if ( l == 1) then
          sol_thick(l) = sol_z(l,jj)
        else
          sol_thick(l) = sol_z(l,jj) - sol_z(l-1,jj)
        end if

      sol_mass(l) = (sol_thick(l) / 1000.) * 10000. *
     &       sol_bd(l,jj) * 1000. * (1.- sol_rock(l,jj) / 100.)

      end do

!       do l=1,20+npmx
!         smix(l)=0.
!       end do
      smix = 0.

      if (dtil > 0.) then
!!!  added by Armen 09/10/2010 next line only
        if (dtil < 10.0) dtil = 11.0
	 do l=1, sol_nly(jj)

          if (sol_z(l,jj) <= dtil) then
            !! msm = mass of soil mixed for the layer
            !! msn = mass of soil not mixed for the layer
            sol_msm(l) = emix * sol_mass(l)
            sol_msn(l) = sol_mass(l) - sol_msm(l)
          else if (sol_z(l,jj) > dtil.AND.sol_z(l-1,jj) < dtil) then
            sol_msm(l) = emix * sol_mass(l) *
     &      (dtil - sol_z(l-1,jj)) / sol_thick(l)
            sol_msn(l) =  sol_mass(l) -  sol_msm(l)
          else
            sol_msm(l) = 0.
            sol_msn(l) = sol_mass(l)
          end if

          !! calculate the mass or concentration of each mixed element
          !! mass based mixing
          WW1 = sol_msm(l)/(sol_msm(l) + sol_msn(l))
          smix(1) = smix(1) + sol_no3(l,jj) * WW1
          smix(2) = smix(2) + sol_orgn(l,jj) * WW1
          smix(3) = smix(3) + sol_nh3(l,jj) * WW1
          smix(4) = smix(4) + sol_solp(l,jj) * WW1
          smix(5) = smix(5) + sol_orgp(l,jj) * WW1
          smix(6) = smix(6) + sol_aorgn(l,jj) * WW1
          smix(7) = smix(7) + sol_actp(l,jj) * WW1
          smix(8) = smix(8) + sol_fon(l,jj) * WW1
          smix(9) = smix(9) + sol_fop(l,jj) * WW1
          smix(10) = smix(10) + sol_stap(l,jj) * WW1
          smix(11) = smix(11) + sol_rsd(l,jj) * WW1
          smix(12) = smix(12) + sol_mc(l,jj) * WW1
          smix(13) = smix(13) + sol_mn(l,jj) * WW1
          smix(14) = smix(14) + sol_mp(l,jj) * WW1

		!! concentration based mixing
          WW2 = XX + sol_msm(l)
          smix(15) = (XX * smix(15) + sol_cbn(l,jj) * sol_msm(l)) /WW2
          smix(16) = (XX * smix(16) + sol_n(l,jj) * sol_msm(l)) /WW2
          smix(17) = (XX * smix(17) + sol_clay(l,jj) * sol_msm(l)) /WW2
          smix(18) = (XX * smix(18) + sol_silt(l,jj) * sol_msm(l)) /WW2
          smix(19) = (XX * smix(19) + sol_sand(l,jj) * sol_msm(l)) /WW2
!          smix(20) = (XX * smix(20) + sol_rock(l,jj) * sol_msm(l)) / WW2
!          smix(21) = (XX * smix(21) + sol_ph(l,jj) * sol_msm(l)) /WW2 !! mjw rev490
!          smix(22) = (XX * smix(22) + sol_cal(l,jj) * sol_msm(l)) /WW2 !! mjw rev490
		!! mass based distribution
          do k = 1, npmx
          	smix(20+k) = smix(20+k) + sol_pst(k,jj,l) * WW1
          end do

            !!by zhang
            !!==============
            if (cswat == 2) then
	        smix(20+npmx+1) = smix(20+npmx+1) +sol_LSC(l,jj)* WW1
	        smix(20+npmx+2) = smix(20+npmx+2) +sol_LSLC(l,jj)* WW1
	        smix(20+npmx+3) = smix(20+npmx+3) +sol_LSLNC(l,jj)* WW1
	        smix(20+npmx+4) = smix(20+npmx+4) +sol_LMC(l,jj)* WW1
	        smix(20+npmx+5) = smix(20+npmx+5) +sol_LM(l,jj)* WW1
	        smix(20+npmx+6) = smix(20+npmx+6) +sol_LSL(l,jj)* WW1
	        smix(20+npmx+7) = smix(20+npmx+7) +sol_LS(l,jj)* WW1

	        smix(20+npmx+8) = smix(20+npmx+8) +sol_LSN(l,jj)* WW1
	        smix(20+npmx+9) = smix(20+npmx+9) +sol_LMN(l,jj)* WW1
	        smix(20+npmx+10) = smix(20+npmx+10) +sol_BMN(l,jj)* WW1
	        smix(20+npmx+11) = smix(20+npmx+11) +sol_HSN(l,jj)* WW1
	        smix(20+npmx+12) = smix(20+npmx+12) +sol_HPN(l,jj)* WW1
	      end if
            !!by zhang
            !!=============

          XX = XX + sol_msm(l)
        end do

          do l=1, sol_nly(jj)

            ! reconstitute each soil layer
            WW3 = sol_msn(l) / sol_mass(l)
            WW4 = sol_msm(l) / XX

            sol_no3(l,jj) = sol_no3(l,jj) * WW3 + smix(1) * WW4
            sol_orgn(l,jj) = sol_orgn(l,jj) * WW3 + smix(2) * WW4
            sol_nh3(l,jj) = sol_nh3(l,jj) * WW3 + smix(3) * WW4
            sol_solp(l,jj) = sol_solp(l,jj) * WW3 + smix(4) * WW4
            sol_orgp(l,jj) = sol_orgp(l,jj) * WW3 + smix(5) * WW4
            sol_aorgn(l,jj) = sol_aorgn(l,jj) * WW3 + smix(6) * WW4
            sol_actp(l,jj) = sol_actp(l,jj) * WW3 + smix(7) * WW4
            sol_fon(l,jj) = sol_fon(l,jj) * WW3 + smix(8) * WW4
            sol_fop(l,jj) = sol_fop(l,jj) * WW3 + smix(9) * WW4
            sol_stap(l,jj) = sol_stap(l,jj) * WW3 + smix(10) * WW4
            sol_rsd(l,jj) = sol_rsd(l,jj) * WW3 + smix(11) * WW4
            if (sol_rsd(l,jj) < 1.e-10) sol_rsd(l,jj) = 1.e-10
            sol_mc(l,jj) = sol_mc(l,jj) * WW3 + smix(12) * WW4
            sol_mn(l,jj) = sol_mn(l,jj) * WW3 + smix(13) * WW4
            sol_mp(l,jj) = sol_mp(l,jj) * WW3 + smix(14) * WW4

            sol_cbn(l,jj) = (sol_cbn(l,jj) * sol_msn(l) + smix(15)
     &           * sol_msm(l)) / sol_mass(l)
            sol_n(l,jj) = (sol_n(l,jj) * sol_msn(l) + smix(16)
     &           * sol_msm(l)) / sol_mass(l)
            sol_clay(l,jj) = (sol_clay(l,jj) * sol_msn(l) + smix(17)
     &           * sol_msm(l)) / sol_mass(l)
            sol_silt(l,jj) = (sol_silt(l,jj) * sol_msn(l) + smix(18)
     &           * sol_msm(l)) / sol_mass(l)
            sol_sand(l,jj) = (sol_sand(l,jj) * sol_msn(l) + smix(19)
     &           * sol_msm(l)) / sol_mass(l)
!		sol_rock(l,jj) = (sol_rock(l,jj) * sol_msn(l) + smix(20) * sol_msm(l)) / sol_mass(l)
!            sol_ph(l,jj) = (sol_ph(l,jj) * sol_msn(l) + smix(21)        &
!     &           * sol_msm(l)) / sol_mass(l) !! mjw rev 490 simplified, PH not linear
!            sol_cal(l,jj) = (sol_cal(l,jj) * sol_msn(l) + smix(22)      &
!     &           * sol_msm(l)) / sol_mass(l) !! mjw rev 490

            do k = 1, npmx
              sol_pst(k,jj,l) = sol_pst(k,jj,l) * WW3 + smix(20+k) * WW4
            end do

             !!by zhang
             !!=============
             if (cswat == 2) then
             sol_LSC(l,jj) = sol_LSC(l,jj)*WW3+smix(20+npmx+1)* WW4
             sol_LSLC(l,jj) = sol_LSLC(l,jj)*WW3+smix(20+npmx+2)* WW4
             sol_LSLNC(l,jj) = sol_LSLNC(l,jj)*WW3+smix(20+npmx+3)* WW4
             sol_LMC(l,jj) = sol_LMC(l,jj)*WW3 + smix(20+npmx+4)* WW4
             sol_LM(l,jj) = sol_LM(l,jj)*WW3 + smix(20+npmx+5)* WW4
             sol_LSL(l,jj) = sol_LSL(l,jj)*WW3 + smix(20+npmx+6)* WW4
             sol_LS(l,jj) = sol_LS(l,jj)*WW3 + smix(20+npmx+7)* WW4
             sol_LSN(l,jj) = sol_LSN(l,jj)*WW3 + smix(20+npmx+8)* WW4
             sol_LMN(l,jj) = sol_LMN(l,jj)*WW3 + smix(20+npmx+9)* WW4
             sol_BMN(l,jj) = sol_BMN(l,jj)*WW3 + smix(20+npmx+10)* WW4
             sol_HSN(l,jj) = sol_HSN(l,jj)*WW3 + smix(20+npmx+11)* WW4
             sol_HPN(l,jj) = sol_HPN(l,jj)*WW3 + smix(20+npmx+12)* WW4
             end if
            !!by zhang
            !!==============

	  end do

        if (cswat == 1) then
            call tillfactor(jj,bmix,emix,dtil,sol_thick)
        end if

		!! summary calculations
        if (curyr > nyskip) then
            sumix(jj) = sumix(jj) + emix
        end if

      end if

      !! perform final calculations for tillage operation

      !! count the tillage only if it is a scheduled operation biomix does not count MJW Rev 490
      if (bmix <= 1.e-6) then
        ntil(jj) = ntil(jj) + 1
      end if
      if (cnop > 1.e-4) call curno(cnop,jj)

      !ntil(jj) = ntil(jj) + 1 ' orig code

      return
      end


! wind/waves fft data collection and shade plot program

 	program		fft_grayplot
 	implicit	integer*4 (a-z)

 	ok = 1
 	if (ok) ok = get_set_tm_stream()
 	TYPE*,'GOING TO COLLECT EVENT DATA'
 	nchgp = 2
 	if (ok) ok = wait_for_events(nchgp)
 	nchgp = 3
 	ok = wait_for_events(nchgp)
 	ITERM = -1
 	CALL SHPLOT(ITERM)
 	ITERM = -1
 	CALL TPLOT(ITERM)
C
 	end
 	options/extend_source
!------------------------------------------------------------------------------
 	integer*4	function	get_set_tm_stream()
c	implicit	none
 	include		'wind_examples:wind_tm_routine_def.for'
 	include		'wind_examples:wind_return_code_def.for'
 	integer*4	ok
 	character*4	event,pa(9)
 	integer*4	iq,i,j,k,n,iterm,nchgp,npt,np,nday
 	integer*4	iw
 	integer*4	get_stream_name
 	integer*4	wait_for_events			! an entry point
 	integer*4	err_count
 	character*80	stream
 	parameter	size=1024
 	integer*4	return_size
 	integer*4	raw(size)
 	integer*4	mantissa(size)
 	integer*4	gain(size)
 	integer*4	pwrdb(size)    ! actually, .5 db steps
 	integer*4	fft_channel
 	integer*4	temp_waves
 	character*32	s
 	real*8		scet8,scetsrt
 	character*32	s_scet
 	integer*4	scet(2)
 	integer*4	ch, chhk, major, minor,itmcorr,iraw
 	character*80	file
 	character*10	title(4)
 	character*32	item
 	integer*4	ios,yyyy,idoy,msec
 	integer*4	NHRMN,IPNT,LAST,NPTMX,N1,N2,NFILL,NPPL
 	REAL		PTIME,DELT,DELTS
 	REAL		tstart,eltime,evtime,tend,tintv
 	REAL		FFTSPACE(4),COUNT(4),SPACE
 	real		nhist(100,10),vdata(1024),dbspec(1024)
 	integer*2	pwrl
 	integer*2	pwrlt(1000,511)
 	integer*4 	ncount
!

 	common /fftblk/ gain,mantissa,pwrdb
 	COMMON /PLTPAR/ NDAY,IPNT(4),ITMCORR,IDOY
 	COMMON /SHBLK/ PTIME(1000),PWRL(1000,511,4)
 	common /headblk/ major,minor,fft_channel,s_scet,title
!
 	DATA ITMCORR /1/     ! 1 = CORRECT FOR TIME, 0 = PLOT
C					CONSECUTIVE SPECTRA
 	data ncount /0/
 	DATA IPNT /4*0/
 	DATA PA /'EXAC','EYAC','EZAC','EXDC','EYDC','EZDC',
     1		'BX','BY','BZ'/
 	DATA JP /0/
C
 	ok = get_stream_name(stream)
 	if (.not. ok) stop 'no file supplied.'
 	ok = w_channel_open(ch,stream)
 	if (.not. ok) stop 'cannot open tm channel'

 	write(6,*) 'type hr,min to start,end, e.g. 0414,0800'
 	read(5,*) nhrmn,last
 	type*,nhrmn,last
 	tstart = (nhrmn/100) + mod(nhrmn,100)/60.
  3	format(q,i10)
  4	format(1x,'enter 1 for hi channels, 2 for mid, 3 for low')
  5	format(q,a)
 	do n = 1,4
 	  title(n) = '          '
 	  fftspace(n) = 0.
 	  count(n) = 1.E-8
 	enddo

 	ok = w_channel_filename(ch,file)
 	print*,'file',file

 	scet8 = 0.
 	call w_channel_position(ch,scet8)
 	nday = scet8
 	type*,'first channel position ',scet8,' ch',ch
 	scet8 = dfloat(nday) + ((nhrmn/100) + mod(nhrmn,100)/60.)/24.
 	scetsrt = scet8
 	type*,'set channel position to',scetsrt,' ch',ch
C**********  TEMPORARY CODE TO GET PAST START
 	OK = WIND_TM_GET_MFMF(CH,MAJOR,MINOR)
 	MAJOR = MAJOR+1
 	OK = WIND_TM_GET_WORD(CH,MAJOR,MINOR,24,I)
C*********** END OF TEMPORARY CODE
c 	ok = wind_tm_get_mfmf(ch,major,minor)
c	if (.not. ok) stop 'cannot get stream position'

 	get_set_tm_stream = 1
 	return

!----------------------------------------------------------------------
 	entry	wait_for_events(nchgp)
c
 	PRINT*,'START NCHGP=',NCHGP
C
 	call w_channel_position(ch,scetsrt)
 	type*,'channel position set to',scetsrt

 	  event = 'FFT'
 	  if(nchgp.eq.1) event = 'FFTH'
 	  if(nchgp.eq.2) event = 'FFTM'
 	  if(nchgp.eq.3) event = 'FFTL'
 	  ok = w_event(ch,event)
 	  if(ok.eq.82) then
 		PRINT*,'END OF FILE'
C		TYPE*,'GO TO PLOT AT ',S_SCET,' previous'
 		print*,'rawcount',rawcount
 		print*,'fftcount',fftcount
 		RETURN
 	  endif
 	  NEWOLD = 0
 	  IF(NCHGP.EQ.0) THEN
 		NCHGP = 3
 	        NEWOLD = 1
 	  ENDIF
 	  print*,'collect events: ',event

 	   item = 'EVENT_SCET'
 	   ok = w_item_i4(ch, item, scet, 2, return_size)
C	   if (.not. ok) type *, 'cannot get item ', item, ', ok=', ok
 	   evtime = (scet(2)/10000) + (mod(scet(2),10000)/100)/60.
     1		+ mod(scet(2),100)/3600.
 	   type*,'first event at',scet,'  evtime',evtime
C
	   item = 'EVENT_SCET_R8'
 	   ok = w_item_r8(ch, item, scet8, 1, return_size)
C	   if (.not. ok) type *, 'cannot get item ', item, ', ok=', ok
 	   call w_ur8_to_ydoy(scet8,yyyy,idoy,msec)
c
 	  go to 110

 	! this is the main program loop

  100	   continue

c	  if( w_end_of_file(ch) ) then

           ok = w_event(ch,event)
 	   if (.not. ok) then
 	      type *, char(7), '******** missing packet in event ********'
 	      type *, 'Cannot get event at MF.mf: ', major, minor
 	      if( ok .eq. 82) then
 		type*,'npt=',npt
 		return
 	      endif
 	      err_count = err_count + 1
 	      if (err_count .lt. 2) goto 100
 	      if (err_count .ge. 2) goto 200
 	   end if

  110	  if(wind_tm_eof(ch,major,minor)) then
 		PRINT*,'END OF FILE'
 		TYPE*,'GO TO PLOT AT ',S_SCET
 		print*,'rawcount',rawcount
 		print*,'fftcount',fftcount
 		RETURN
 	  endif

 	   ! now get the items

 	   item = 'channel_number'
 	   ok = w_item_i4(ch, item, fft_channel, 1, return_size)
 	   if (.not. ok) type *, 'cannot get item ', item, ', ok=', ok
 	   if(ok .eq. 82) type *,' end of file'
 	   if(ok .eq. 82) return

C******************
 	     iw = fft_channel-6
 	     if(nchgp.eq.1) iw = fft_channel
 	     if(nchgp.eq.2) iw = fft_channel-2
 	     if(nchgp.eq.3) iw = fft_channel-6
 	     iw = max0(iw,1)
 	     iw = min0(iw,4)
C
C	PLOT ONLY BX AND BY
C
 	   item = 'SOURCE'
 	   ok = w_item_i4(ch, item, IQ, 1, return_size)
 	   if (.not. ok) type *, 'cannot get item ', item, ', ok=', ok
C
 	   IF(IQ.NE.7.AND.IQ.NE.8) GO TO 100
C
 	   IF(IQ.EQ.7.AND.NCHGP.EQ.3) IW = 2
 	   IF(IQ.EQ.8.AND.NCHGP.EQ.3) IW = 1
 	   IF(IQ.EQ.7.AND.NCHGP.EQ.2) IW = 4
 	   IF(IQ.EQ.8.AND.NCHGP.EQ.2) IW = 3
 	   IF(TITLE(iw).EQ.'          ') THEN
 	     WRITE(TITLE(iw),1001) FFT_CHANNEL,PA(IQ)
C	     TITLE(iw) = PA(IQ)
 	   ENDIF
 1001	   FORMAT('CH',I2,'  ',A4)

C
C	TYPE*,'CALL FFT_PHYS'
C
C	call fft_phys(ch,iraw,vdata,dbspec)
 	   item = 'SPECTRUM_DB'
 	   ok = w_item_R4(ch, item, DBSPEC, 1024, return_size)
C
C	CALCULATE TOTAL POWER
C
 	      TPOWER = 0.
 	      do n = 128,512
 		TPOWER = TPOWER + EXP(.23026*DBSPEC(N))
 	      enddo
 	      TPOWERDB = 10.*ALOG10(TPOWER)
c
c
C	IW is the number of the window in the shade plot, 1-4 for mid,low
c	NW = 4 here is the number of windows

C
 	IF(NCHGP.EQ.2) THEN
 	  NW1 = 3
 	  NW2 = 4
 	ELSE
 	  NW1 = 1
 	  NW2 = 2
 	ENDIF
C
 	      do i = 1,4		! to take care of a problem
 		space = amax1(space,fftspace(i))
 		fftspace(i) = space
 	      enddo

c	   endif

 	   item = 'EVENT_SCET'
 	   ok = w_item_i4(ch, item, scet, 2, return_size)
 	   if (.not. ok) type *, 'cannot get item ', item, ', ok=', ok
 	   evtime = (scet(2)/10000) + (mod(scet(2),10000)/100)/60.
     1		+ mod(scet(2),100)/3600.
 	   eltime = evtime - tstart
C
 1002	FORMAT(2I8,I4,F9.3,E12.3)
C

c*************
 	if(iraw.eq.0) then
 		fftcount = fftcount + 1.
 	else
 		rawcount = rawcount + 1.
 	endif
c
c	load histogram of intervals
c
 	ihist = amin1((eltime - eltimes)*1800.,100.) + .5
 	ihist = max0(ihist,1)
 	nhist(ihist,fft_channel) = nhist(ihist,fft_channel) + 1
 	eltimes = eltime

 	if(ipnt(iw).gt.0) then
 	   if(iraw.eq.0) then
 		iq = ipnt(iw)
 	  	fftspace(iw) = fftspace(iw) + evtime - ptime(iq)
 	     	count(iw) = count(iw) + 1.
 	   else
 		iq = ipnt(iw)
 	  	fftspace(iw) = fftspace(iw) + .25*(evtime - ptime(iq))
 	     	count(iw) = count(iw) + 1.
 	   endif
 	endif

 	   write(s,'(i8.8,i6.6)',iostat=ios) scet(1), scet(2)
 	   s_scet = s(1:4)//'/'//s(5:6)//'/'//s(7:8)//' '//
     1    	s(9:10)//':'//s(11:12)//':'//s(13:14)
 	   ! type the report
c
 	   NPT = IPNT(IW) + 1
 	   IPNT(IW) = NPT
 	   PTIME(NPT) = (scet(2)/10000) + (mod(scet(2),10000)/100)/60.
     1		+ mod(scet(2),100)/3600.
 	 type*,'npt,channel,ptime,scet(2)',npt,fft_channel,ptime(npt)
     1     ,scet(2)
 	   do i=1,511
c		PWRL(NPT,I,IW) = RAW(I+1)
 		PWRL(NPT,I,IW) = DBSPEC(I+1)
 	   end do

 	   IF(NPT.GT.995) GO TO 200
 	   IF(scet(2).LT.(100*LAST)) GO TO 100

  200	continue

 	TYPE*,NPT,' SPECTRA FOUND, EACH CHANNEL'
C	TYPE*,'GO TO PLOT AT ',S_SCET

c	do i = 1,100
c	  write(44,*) 2*i,nhist(i,1),nhist(i,3),nhist(i,7)
c	enddo
c	write(44,*) file
c
 	IF(ITMCORR.EQ.0) THEN
 	  print*,'rawcount,CORR=0',rawcount
 	  print*,'fftcount,CORR=0',fftcount
C	call rawprint
 	  RETURN
 	ENDIF

 	TEND = 0.
 	NPTMX = 0
 	DO I = NW1,NW2
 	  NPT = IPNT(I)
 	  NPTMX = MAX0(NPT,NPTMX)
 	  IF(NPT.GT.0) TEND = AMAX1(TEND,PTIME(NPT))
 	ENDDO
 	print*,'nptmx,ipnt',nptmx,ipnt

C
C	NPT IS NOW USED AS AN ESTIMATE OF THE NEXT PWRL TIME INDEX CORRESPONDING
C		TO THE EXACT TIME   PTIME(1) + (NP-1)*TINTV
C
c	NPT = 1
C
C	DO N = 1,NPTMX-1
C	PRINT*,N,PTIME(N),(PTIME(N)-PTIME(1))/TINTV
C	ENDDO
C
 	      do i = NW1,nw2
 		space = amax1(space,fftspace(i))
 	      enddo

 	DO I = NW1,NW2
 	  IF(IPNT(I).NE.0) THEN
C	    COPY PWRL INTO PWRLT
 	    DO NP = 1,NPTMX
 	       DO J = 1,511
 	  	PWRLT(NP,J) = PWRL(NP,J,I)
 	       ENDDO
 	    ENDDO
C
C	FIND TINTV = AVERAGE SPACING OF FFT'S, NOT COUNTING RAW'S
 	    TINTV = SPACE/COUNT(I)
C	FIND NPPL = NUMBER OF PIXELS IN TIME DIRECTION
 	    NPPL = (PTIME(NPTMX) - PTIME(1))/TINTV
 	PRINT*,'SPACE,NO OF SLICES,INT',SPACE,NPPL,TINTV
 	    IF(NPPL.GT.997) THEN
 	print*,'************** warning, too many slices ********'
 	       NPPL = 997
 	       TINTV = (PTIME(NPTMX) - PTIME(1))/NPPL
 	    ENDIF
C
C	  DO NP = 1,NPPL
 	  NP = 0
 	  NPT = 0
 	  DOWHILE (NPT.LE.NPTMX.AND.NP.LE.IPNT(IW))
 	    NP = NP+1
 	    ELTIME = PTIME(1) + (NP-1)*TINTV
C	PRINT*,'NP,pt,eltm',NP,ptime(np),eltime,tintv
C
 	    IF(ABS(PTIME(NP)-ELTIME).LT..5*TINTV) THEN
C		NO CORRECTION REQUIRED
 	      NPT = NP+1
 	      GO TO 210
 	    ENDIF
C
C	    SEARCH THE RANGE NPT+-25 FOR NEAREST SPECTRUM
 	    N1 = MAX0(NPT-25,1)
 	    N2 = MIN0(NPT+25,NPTMX)
 	    NFILL = 0
 	    DELTS = 20.*TINTV
C	FIND NEAREST SPECTRUM
 	    DO N = N1,N2
 	      DELT = ABS(PTIME(N)-ELTIME)
 	      IF(DELT.LT.DELTS) THEN
 		  DELTS = DELT
 		  NFILL = NFILL+1
 		  NPT = N
 	      ENDIF
 	    ENDDO

C
C	IF NEAREST SPECTRUM IS TOO FAR AWAY, LOAD ZERO'S, ELSE LOAD SPECTRUM
c	no, this turned out to be a bad idea
C	    IF(DELTS.GT.2.*TINTV) THEN
C		print*,'skipped a spectrum at',n1,n2
C		DO J = 1,511
C		  PWRL(NP,J,I) = 0.
C		ENDDO
C	    ELSE
C
C	TYPE*,'PUT NUMBER',NPT,' INTO SLOT',NP,' TIME',PTIME(NPT)
C
 		DO J = 1,511
 		  PWRL(NP,J,I) = PWRLT(NPT,J)
 		ENDDO
C	    ENDIF
  210	    CONTINUE
  	    NPT = MIN0(NPT+1,NPTMX)
 	  ENDDO
  	  ENDIF
 	ENDDO
C
C	(N_CHANNEL_GROUP)  NCHGP=1 IS HIGH, 2 IS MID, 3 IS LOW
 	   NPT = NPTMX
C	call rawprint
 		print*,'fftcount,RETURN',fftcount
 		print*,'rawcount,RETURN',rawcount
C	   IF(1) STOP
 	PRINT*,'RETURN FROM WAIT FOR EVENTS'
 	return
 	end
 	options/extend_source
 !------------------------------------------------------------------------------
 	integer*4	function	get_stream_name(stream)
 ! This routine gets the user's TM stream type specification.
 !
 	implicit	none
 	character*(*)	stream
 	common /nrblk/ NHRMN
 	integer*4	iq,NHRMN

   6	format(1x,'Enter TM stream type [O=offline(default), R=realtime ]: ',$)
   5	format(q,a)
   4	format(1x,'enter number of events to find and process')
   3	format(q,i10)

  10	write(6,6)
 	read(5,5,err=10,end=20) iq, stream

 	if (iq .lt. 1) then
 	   stream = 'offline'
 	else if (stream(1:1) .eq. 'o' .or. stream(1:1) .eq. 'O') then
 	   stream = 'offline'
 	else if (stream(1:1) .eq. 'r' .or. stream(1:1) .eq. 'R') then
 	   stream = 'realtime'
 	else
 	   ! assume the user entered the name of an offline file
 	end if

 	get_stream_name = 1

  20	return
 	end
 	SUBROUTINE SHPLOT(ITERM)
C
 	character*32 scet
 	integer*2 npwrl
 	COMMON /SHBLK/ PTIME(1000),NPWRL(1000,511,4)
 	COMMON /PLTPAR/ NDAY,IPNT(4),ITMCORR,IDOY
 	common /headblk/ major,minor,ifftch,scet,title
C
 	COMMON /MONGOPAR/
     1  X1,X2,Y1,Y2,GX1,GX2,GY1,GY2,LX1,LX2,LY1,LY2,
     1  GX,GY,CX,CY,
     1  EXPAND,ANGLE,LTYPE,LWEIGHT,
     1  CHEIGHT,CWIDTH,CXDEF,CYDEF,PSDEF,PYDEF,COFF,
     1  TERMOUT,XYSWAPPED,NUMDEV,
     1  PI,USERVAR(10),AUTODOT
 	INTEGER*4 LX1,LX2,LY1,LY2,LTYPE,LWEIGHT,NUMDEV
C
 	CHARACTER*10 TITLE(4)
 	CHARACTER*120 STR
 	REAL FUNDF(3)
 	DIMENSION PWRL(511000)
 	DATA FUNDF /.021348,.005337, .33356/
C
C
 	NWNDOW = 4
 	XSTART = 400.
 	XEND = 2300.
 	IW = 1
 	NPT = IPNT(IW)
 	PRINT*,' IN SHPLOT,NPT',NPT
 	IF(NPT.LT.1) THEN
 	  IW = 2
 	  NPT = IPNT(IW)
 	ENDIF
 	IF(NPT.LT.1) THEN
 	  IW = 3
 	  NPT = IPNT(IW)
 	ENDIF
 	IF(NPT.LT.1) THEN
 	  IW = 4
 	  NPT = IPNT(IW)
 	  IF(NPT.LT.1) RETURN
 	ENDIF
 	PRINT*,' IN SHPLOT,TIMES',PTIME(1),PTIME(NPT),NPT
C	CALCULATE BOX SIZE
 	PIXSIZ = .1
 	IF(NPT.GT.1) PIXSIZ = (PTIME(NPT) - PTIME(1))/(NPT-1)
 	HSTART = PTIME(1) - .5*PIXSIZ
 	HEND =   PTIME(NPT) + .5*PIXSIZ
 	PRINT*,' IN SHPLOT,TIMES,NPT',HSTART,HEND,NPT
 	  CALL MGOINIT
 	  CALL MGOSETUP(ITERM)
 	  CALL MGOERASE
C

 	IF(ITERM.LT.0) THEN
 	  CALL MGOSETLOC(XSTART,280.,XEND,3100.)
 	ENDIF
C
 	DO IW = 1,NWNDOW
 	  CALL MGOWINDOW(1,NWNDOW,IW)          !
 	  NPT = IPNT(IW)
 	  IF(NPT.LT.1) GO TO 200
 	  LIMFREQ = 511
 	  NCHGP = 3
 	  IF(IW.GE.3) THEN
 		LIMFREQ = 37
 		NCHGP = 2
 	  ENDIF
 	  PRINT*,' IN SHPLOT,IW,NPT',IW,NPT
 	  YMIN = 1.E6
 	  YMAX = -YMIN
 	  CALL HISTOG(2,TJUNK,256,-250.,0.,.01,TOTAL,RET)     ! CLEAR AND INIT
 	  DO M = 1,NPT
 	  DO N = 1,LIMFREQ
 	    NM = M + (N-1)*NPT
 	    PWRL(NM) = NPWRL(M,N,IW)
 	    CALL HISTOG(1,PWRL(NM),256,-250.,0.,.5,TOTAL,RET)    ! LOAD ARRAY
C
 	    YMIN = AMIN1(YMIN,PWRL(NM))
 	    YMAX = AMAX1(YMAX,PWRL(NM))
 	  ENDDO
 	  ENDDO
 	  PRINT*,' YMIN,MAX ACTUAL',YMIN,YMAX
C
 	  CALL HISTOG(0,TJUNK,256,-250.,0.,.03,TOTAL,YHMIN)   !DETERMINE 3 PCTILE
 	  CALL HISTOG(0,TJUNK,256,-250.,0.,.97,TOTAL,YHMAX)  !DETERMINE 97 PCTILE
C	  RAISING YMIN MAKES THE BACKGROUND LIGHTER
C	  LOWERING YMAX MAKES THE SIGNAL DARKER

 	  YAMIN = YHMIN
 	  YAMAX = YHMAX
 	  PRINT*,'YMIN,MAX SET TO',YAMIN,YAMAX
c	  arguments are: array(m,n),m,n,white,black,linearity
c	  m is the x direction
 	  CALL MGOHALFTONE(PWRL,NPT,LIMFREQ,YAMIN,YAMAX,1.E7)
 	  CALL MGOSETEXPAND(.7)
 	  CALL MGOSETLIM(HSTART,FUNDF(NCHGP),HEND,LIMFREQ*FUNDF(NCHGP))
 	  IF(NCHGP.EQ.3) THEN
 	    CALL MGOYLABEL(13,'FREQUENCY, Hz')
 	  ELSE
 	    CALL MGOYLABEL(14,'FREQUENCY, kHz')
 	  ENDIF
 	  CALL MGOBOX(1,2)
 	  CALL MGOGRELOCATE(GX1,GY2)
 	  CALL MGOPUTLABEL(10,TITLE(IW),9)
 	print*,'title in shplot  ',title(iw)
C
 	  WRITE(STR,704) .5*YAMIN,.5*YAMAX
 704	  FORMAT('WHITE,BLACK ',2F6.1,' DB ')
 	  CALL MGOSETANGLE(90.)
 	  CALL MGOSETEXPAND(.5)
 	  XPR = GX2 + .005*(GX2-GX1)
 	  YPR = .5*(GY1+GY2)
 	  CALL MGOGRELOCATE(XPR,YPR)
 	  CALL MGOPUTLABEL(28,STR,2)
 	  CALL MGOSETANGLE(0.)
 	  CALL MGOSETEXPAND(1.)
  200	  CONTINUE
 	  IF(IW.EQ.1) THEN
C	   s_scet = s(1:4)//'/'//s(5:6)//'/'//s(7:8)//' '//
C	1	s(9:10)//':'//s(11:12)//':'//s(13:14)
          WRITE(STR,1001) SCET(1:10),IDOY
 1001	  FORMAT('HOURS OF ',A10,' DOY ',I3)
 	  CALL MGOSETEXPAND(.8)
          CALL MGOXLABEL(28,STR)
 	    CALL MGOSETEXPAND(.5)
 	    IF(ITMCORR.EQ.0) THEN
 		CALL MGOPUTLABEL(23,'    consecutive spectra',6)
 	    ELSE
 		CALL MGOPUTLABEL(18,'    corrected time',6)
 	    ENDIF
 	    CALL MGOSETEXPAND(1.)
 	  ENDIF
C
 	  IF(IW.EQ.NWNDOW) THEN
 	    CALL MGOSETEXPAND(.8)
 	    CALL MGOPLOTID('[.WIND]FFTMNB','SHPLOT')
 	    CALL MGOSETEXPAND(1.)
 	  ENDIF
 	ENDDO
C
 	  CALL MGOSETEXPAND(1.)
 	  IF(ITERM.LT.0) THEN
 	    CALL MGOPRNTPLOT(NVEC)
 	    PRINT*,' NO. VECTORS PLOTTED',NVEC
 	  ELSE
 	    CALL MGOTCLOSE
 	  ENDIF
C
 	RETURN
 	END
 	SUBROUTINE RAWPRINT
C
 	common /fftblk/ nexpt(1024),ndata(1024),ipwrdb(1024)
 	common /headblk/ major,minor,ich,scet,title
 	character*32 scet
 	character*10	title(4)
C
 	write(36,*) 'fft data collection at ',scet,' channel',ich
C
 	DO I = 1,103
 	  I2 = 10*I
 	  I1 = I2 - 9
 	  I2 = MIN0(I2,1024)
 	  WRITE(36,1006) I1-1,(NEXPT(J),NDATA(J),J=I1,I2)
 	ENDDO
C
 	RETURN
 1006	FORMAT(I5,'.',(10(I3,I5)))
 	END
 	SUBROUTINE HISTOG(ILOAD,X,NBIN,XMIN,XMAX,PCTILE,TOTAL,RET)
C
C	THIS IS A SPECIAL VERSION TO CALCULATE LEVEL AT A CERTAIN PERCENTILE
C
C	INTEGER*4 NARR
 	DIMENSION NARR(256)
 	DATA NARR /256*0/
C
 	IF(ILOAD.GT.1) THEN
 	  DO N = 1,256
 	    NARR(N) = 0
 	  ENDDO
 	  TOTAL = 0.
 	  RETURN
 	ENDIF
C
 	IF(ILOAD.EQ.1) THEN
 	  XT = AMAX1(X,XMIN)
 	  XT = AMIN1(XT,XMAX)
 	  IBIN = (NBIN-1)*(XT-XMIN)/(XMAX-XMIN) + 1
 	  NARR(IBIN) = NARR(IBIN)+1
 	  TOTAL = TOTAL + 1.
 	  RETURN
 	ENDIF
C
 	IF(PCTILE.GT..5) THEN
C	  PRINT OUT RESULTS
C    	  PRINT*,' TOTAL NUMBER, NBIN',TOTAL,NBIN
C	  PRINT*,'XMIN,XMAX',XMIN,XMAX
c	  PRINT*,'HISTOGRAM'
c	  PRINT 1111, (NARR(J),J=1,NBIN)
 1111	  FORMAT(10I7)
 	ENDIF
C
C	NOW CALCULATE VALUE OF X CORRESPONDING TO PCTILE PERCENTILE
C
C	PCTILE = .2
 	SET = PCTILE*TOTAL
 	SUM = 0.
 	N = 0
  100	N = N+1
 	  SUM = SUM + NARR(N)
 	  IF(SUM.LT.SET) GO TO 100
C
C	NOW THE DESIRED VALUE LIES IN BIN N
C
 	SUMLOW = SUM - NARR(N)
 	XN = N
 	RETLOW = XMIN + ((XN-1.)/(NBIN-1.))*(XMAX-XMIN)
 	RETHI = XMIN +       (XN/(NBIN-1.))*(XMAX-XMIN)
 	RET = .5*(RETHI+RETLOW)
 	IF(NARR(N).NE.0)
     1	RET = RETLOW + (SET-SUMLOW)*(RETHI-RETLOW)/NARR(N)
C	PRINT*,'N,SET,SUMLOW,LOW,RET',N,SET,SUMLOW,RET
 	RETURN
 	END
 	SUBROUTINE TPLOT(ITERM)
C
C	PLOTS THE TIME DOMAIN DATA
C
 	character*32 scet
 	integer*2 npwrl
 	character*10	titlex(4)
 	REAL	FUNDF(3)
 	COMMON /SHBLK/ PTIME(1000),NPWRL(1000,511,4)
 	COMMON /PLTPAR/ NDAY,IPNT(4),ITMCORR,IDOY
 	COMMON /SPBLK/ PWRW(1024),PWRNW(1024),FDATA(1024),DATA(1024)
 	common /headblk/ major,minor,ifftch,scet,titlex
C
 	COMMON /MONGOPAR/
     1  X1,X2,Y1,Y2,GX1,GX2,GY1,GY2,LX1,LX2,LY1,LY2,
     1  GX,GY,CX,CY,
     1  EXPAND,ANGLE,LTYPE,LWEIGHT,
     1  CHEIGHT,CWIDTH,CXDEF,CYDEF,PSDEF,PYDEF,COFF,
     1  TERMOUT,XYSWAPPED,NUMDEV,
     1  PI,USERVAR(10),AUTODOT
 	INTEGER*4 LX1,LX2,LY1,LY2,LTYPE,LWEIGHT,NUMDEV
C
 	DIMENSION PP(1024),YY(1024)
 	CHARACTER*8 TITLE(4)
 	CHARACTER*120 STRG(5)
 	CHARACTER*120 STR
 	DATA TITLE/'RECT.','HAMMING','HANNING',' '/
 	DATA FUNDF /.021348,.005337, .33356/
C
C
 	  CALL MGOINIT
 	  CALL MGOSETUP(ITERM)
 	  CALL MGOERASE
 	IF(ITERM.LT.0) THEN
 	  PRINT*,'START TPLOT',GX1,GX2,GY1,GY2
C	  CALL MGOSETLOC(500.,330.,GY2-200.,3000.)
C	  CALL MGOSETLOC(GX1,GY1,GX2,GY2-100.)
 	ENDIF
C
 	IW = 1
 	NPT = IPNT(IW)
 	PRINT*,' IN TPLOT',NPT,iterm
 	IF(NPT.LT.1) THEN     	  ! protection
 	  IW = 2
 	  NPT = IPNT(IW)
 	  PRINT*,' IN TPLOT',NPT,' IW',IW
           IF(NPT.LT.1) RETURN
 	ENDIF
 	PRINT*,' IN TPLOT,TIMES',PTIME(1),PTIME(NPT),NPT
C	CALCULATE BOX SIZE
 	XRANGE = PTIME(NPT) - PTIME(1)
 	XMIN = PTIME(1) - .01*XRANGE
 	XMAX = PTIME(NPT) + .01*XRANGE
C
 	  CALL MGOSETEXPAND(.8)
 	CALL MGOGRELOCATE(GX1,120.)
 	CALL MGOPUTLABEL(79,SCET(1:10),3)
        WRITE(STR,1001) SCET(1:10),IDOY
 1001	  FORMAT('HOURS OF ',A10,' DOY ',I3)
 	  XPR = GX2 + .005*(GX2-GX1)
 	  YPR = .5*(GY1+GY2)
 	  CALL MGOGRELOCATE(XPR,YPR)
 	  CALL MGOPUTLABEL(28,STR,2)
 	  CALL MGOSETANGLE(0.)
 	  CALL MGOSETEXPAND(1.)
 200	  CONTINUE
 	  TOP = LY2
 	  CALL MGOGRELOCATE(GX1,TOP-100.)
 	  CALL MGOPUTLABEL(11,'FFT CHANNEL',3)
 	  WRITE(STR,802) IFFTCH
 	  CALL MGOPUTLABEL(8,STR,3)
 	  CALL MGOPUTLABEL(10,'   SOURCE ',3)
 	  IW = IFFTCH
 	  IF(IFFTCH.GT.2) IW = IFFTCH-2
 	  IF(IFFTCH.GT.6) IW = IFFTCH-6
 	  CALL MGOPUTLABEL(10,TITLEX(IW),3)
C
 	DO JW = 1,6
 	  CALL MGOWINDOW(1,6,JW)
 	  CALL MGOSETEXPAND(.6)
 	  TOP = LY2
 802	  FORMAT(2I6)
 	  CALL MGOSETEXPAND(1.)
C
 	  YMAX = -1000.
 	  YMAX = -YMIN
 	  JP = 1
 	  DO J = 1,NPT
 	    JP = J
 	    PP(JP) = PTIME(J)
 	    YY(JP) = NPWRL(J,JW,IW)
 	      YMAX = AMAX1(YY(JP),YMAX)
 	      YMIN = AMIN1(YY(JP),YMIN)
 	  ENDDO
C
 	  RANGE = ABS(YMAX-YMIN)
 	  YMAX = YMAX + .05*RANGE
 	  YMIN = YMIN - .05*RANGE
C	  CALL MGOTICKSIZE(20.,100.,0.,0.)
 	  CALL MGOSETLIM(XMIN,YMIN,XMAX,YMAX)
 	  CALL MGOCONNECT(PTIME,YY,JP)
 	  WRITE(STR,801) JW*FUNDF(3)
  801	  FORMAT(F6.2,' Hz')
 	  CALL MGORELOCATE(XMIN +.1*XRANGE,YMAX-.2*RANGE)
 	  CALL MGOLABEL(9,STR)
 	  CALL MGOSETEXPAND(.6)
 	  CALL MGOBOX(1,2)
 	  CALL MGOXLABEL(16,'HOURS OF THE DAY')
 	  CALL MGOYLABEL(5,'DB nT')
 	  CALL MGOSETEXPAND(1.)
 	ENDDO
C
 	CALL MGOSETEXPAND(.7)
 	CALL MGOPLOTID('[.WIND]FFTMNB','TPLOT')
 	CALL MGOSETEXPAND(1.)
 	IF(ITERM.LT.0) THEN
 	  CALL MGOPRNTPLOT(NVEC)
 	  PRINT*,' NO. VECTORS PLOTTED',NVEC
 	ELSE
 	  CALL MGOTCLOSE
 	ENDIF

C
 	RETURN
C
 	END


!-------------------------------------------------------------------------------
!> module ATMOSPHERE / Physics Cloud Microphysics / SDM
!!
!! @par Description
!!          Memory management of the SDM variables
!!
!! - Reference
!!  - Shima et al., 2009:
!!    The super-droplet method for the numerical simulation of clouds and precipitation:
!!    A particle-based and probabilistic microphysics model coupled with a non-hydrostatic model.
!!    Quart. J. Roy. Meteorol. Soc., 135: 1307-1320
!!
!! @author Team SCALE
!!
!! @par History
!! @li      2014-06-23 (S.Shima) [new] Separated from scale_atmos_phy_mp_sdm.F90
!! @li      2014-07-14 (S.Shima) [rev] Removed unused variables
!! @li      2014-07-18 (Y.Sato)  [add] add QTRC_sdm
!! @li      2014-07-22 (Y.Sato)  [mod] modify the bug at the allocation of QTRC_sdm
!! @li      2016-07-11 (S.Shima) [mod] allocate sdice variables
!! @li      2016-07-13 (S.Shima) [mod] Modified for cold SDM
!! @li      2016-07-14 (S.Shima) [mod] Evaluation of bufsiz1, bufsiz2_r8, etc. moved from sdm_allocinit to sdm_numset
!! @li      2016-07-16 (S.Shima) [mod] Dimension of sd_itmp1,sd_itmp2,sd_itmp2 modified.
!! @li      2016-07-16 (S.Shima) [mod] Definition of prr_cres modified.
!! @li      2016-07-21 (S.Shima) [mod] Allocation of the working arrays for restart output moved from scale_atmos_phy_mp_sdm.F90
!! @li      2017-11-30 (S.Shima) [mod] sd_dtmp2
!! @li      2018-02-28 (S.Shima) [add] sd_dtmp3,4,5,6
!! @li      2018-06-30 (S.Shima) [add] rime mass and number of monomers as SD attributes
!!
!<
!-------------------------------------------------------------------------------
module m_sdm_memmgr

  implicit none
  private
  public :: sdm_allocinit

contains
  !-----------------------------------------------------------------------------
  subroutine sdm_allocinit
    use scale_gridtrans, only: &
       I_XYZ, I_XYW,    &
       GTRANS_GSQRT, &
       GTRANS_J13G,  &
       GTRANS_J23G,  &
       GTRANS_J33G
    use scale_tracer_sdm, only: &
         QA_MP
    use scale_grid_index, only: &
         IE,IS,KE,KS,JE,JS,IA,KA,JA ! S:start, E: end of active grids. A: num of grids including HALO.
    use m_sdm_common
    integer :: n, s

    !--- Allocate arrays for SDM
    allocate(sdn_s2c(1:sdnum_s2c))
    allocate(sdri_s2c(1:sdnum_s2c))
    allocate(sdrj_s2c(1:sdnum_s2c))
    allocate(sdrk_s2c(1:sdnum_s2c))
    allocate(sdx_s2c(1:sdnum_s2c))
    allocate(sdy_s2c(1:sdnum_s2c))
    allocate(sdz_s2c(1:sdnum_s2c))
    allocate(sdr_s2c(1:sdnum_s2c))
    allocate(sdu_s2c(1:sdnum_s2c))
    allocate(sdv_s2c(1:sdnum_s2c))
    allocate(sdvz_s2c(1:sdnum_s2c))
    allocate(sdasl_s2c(1:sdnum_s2c,1:sdnumasl_s2c))
    allocate(sdn_fm(1:sdfmnum_s2c))
    allocate(sdri_fm(1:sdfmnum_s2c))
    allocate(sdrj_fm(1:sdfmnum_s2c))
    allocate(sdrk_fm(1:sdfmnum_s2c))
    allocate(sdx_fm(1:sdfmnum_s2c))
    allocate(sdy_fm(1:sdfmnum_s2c))
    allocate(sdz_fm(1:sdfmnum_s2c))
    allocate(sdr_fm(1:sdfmnum_s2c))
    allocate(sdvz_fm(1:sdfmnum_s2c))
    allocate(sdasl_fm(1:sdfmnum_s2c,1:sdnumasl_s2c))

    allocate(sdliqice_s2c(1:sdnum_s2c))
    allocate(sdliqice_fm(1:sdfmnum_s2c))

    if( sdm_cold ) then
       allocate(sdice_s2c%re(1:sdnum_s2c))
       allocate(sdice_s2c%rp(1:sdnum_s2c))
       allocate(sdice_s2c%rho(1:sdnum_s2c))
!       allocate(sdice_s2c%t(1:sdnum_s2c))
       allocate(sdice_s2c%tf(1:sdnum_s2c))
       allocate(sdice_s2c%mrime(1:sdnum_s2c))
       allocate(sdice_s2c%nmono(1:sdnum_s2c))

       allocate(sdice_fm%re(1:sdfmnum_s2c))
       allocate(sdice_fm%rp(1:sdfmnum_s2c))
       allocate(sdice_fm%rho(1:sdfmnum_s2c))
!       allocate(sdice_fm%t(1:sdfmnum_s2c))
       allocate(sdice_fm%tf(1:sdfmnum_s2c))
       allocate(sdice_fm%mrime(1:sdfmnum_s2c))
       allocate(sdice_fm%nmono(1:sdfmnum_s2c))
    else
       allocate(sdice_s2c%re(1:1))
       allocate(sdice_s2c%rp(1:1))
       allocate(sdice_s2c%rho(1:1))
!       allocate(sdice_s2c%t(1:1))
       allocate(sdice_s2c%tf(1:1))
       allocate(sdice_s2c%mrime(1:1))
       allocate(sdice_s2c%nmono(1:1))

       allocate(sdice_fm%re(1:1))
       allocate(sdice_fm%rp(1:1))
       allocate(sdice_fm%rho(1:1))
!       allocate(sdice_fm%t(1:1))
       allocate(sdice_fm%tf(1:1))
       allocate(sdice_fm%mrime(1:1))
       allocate(sdice_fm%nmono(1:1))
    end if

    allocate(sdrkl_s2c(IA,JA))
    allocate(sdrku_s2c(IA,JA))

    ! These variables are not needed for SCALE. They are for leap-frog scheme of CReSS.
    allocate(sdn_tmp(1:1))
    allocate(sdrk_tmp(1:1))
    allocate(sdx_tmp(1:1))
    allocate(sdy_tmp(1:1))
    allocate(sdz_tmp(1:1))
    allocate(sdr_tmp(1:1))
    allocate(sdu_tmp(1:1))
    allocate(sdv_tmp(1:1))
    allocate(sdvz_tmp(1:1))
    allocate(sdasl_tmp(1:1,1:1))

    allocate(rand_s2c(1:sdnum_s2c))
    allocate(sortid_s2c(1:sdnum_s2c))
    allocate(sortkey_s2c(1:sdnum_s2c))
    allocate(sortfreq_s2c(1:ni_s2c*nj_s2c*nk_s2c+1))
    allocate(sorttag_s2c(1:ni_s2c*nj_s2c*nk_s2c+2))

    allocate(rbuf_r8(1:bufsiz1,1:bufsiz2_r8,1:2))
    allocate(sbuf_r8(1:bufsiz1,1:bufsiz2_r8,1:2))
    allocate(rbuf_i8(1:bufsiz1,1:bufsiz2_i8,1:2))
    allocate(sbuf_i8(1:bufsiz1,1:bufsiz2_i8,1:2))
    allocate(rbuf_i2(1:bufsiz1,1:bufsiz2_i2,1:2))
    allocate(sbuf_i2(1:bufsiz1,1:bufsiz2_i2,1:2))
    if( sdm_cold ) then
       allocate(rbuf_i4(1:bufsiz1,1:bufsiz2_i4,1:2))
       allocate(sbuf_i4(1:bufsiz1,1:bufsiz2_i4,1:2))
    else
       allocate(rbuf_i4(1:1,1:1,1:2))
       allocate(sbuf_i4(1:1,1:1,1:2))
    end if

    allocate(sdm_itmp1(1:ni_s2c*nj_s2c*nk_s2c+2))
    allocate(sdm_itmp2(1:ni_s2c*nj_s2c*nk_s2c+2))
    allocate(sdm_itmp3(1:ni_s2c*nj_s2c*nk_s2c+2))

    allocate(sd_itmp1(1:sdnum_s2c))
    allocate(sd_itmp2(1:sdnum_s2c))
    allocate(sd_itmp3(1:sdnum_s2c))

    allocate(sd_dtmp1(1:sdnum_s2c))
    allocate(sd_dtmp2(1:sdnum_s2c))
    allocate(sd_dtmp3(1:sdnum_s2c))
    allocate(sd_dtmp4(1:sdnum_s2c))
    allocate(sd_dtmp5(1:sdnum_s2c))
    allocate(sd_dtmp6(1:sdnum_s2c))

    allocate( prr_crs(IA,JA,1:6) )
    allocate( dxiv_sdm(IA) )
    allocate( dyiv_sdm(JA) )
    allocate( dx_sdm(IA) )
    allocate( dy_sdm(JA) )

    allocate(QTRC_sdm(KA,IA,JA,QA_MP))

    ! Initialize allocated array
    QTRC_sdm(:,:,:,:) = 0.0_RP
    do n = 1, sdnum_s2c
       sortid_s2c(n) = 0
       sortkey_s2c(n) = 0
       rand_s2c(n) = 0.0_RP
       sdn_s2c(n) = int(0,kind=DP)
       sdx_s2c(n) = 0.0_RP
       sdy_s2c(n) = 0.0_RP
       sdz_s2c(n) = 0.0_RP
       sdr_s2c(n) = 0.0_RP
       sdu_s2c(n) = 0.0_RP
       sdv_s2c(n) = 0.0_RP
       sdvz_s2c(n) = 0.0_RP

       sd_itmp1(n) = 0
       sd_itmp2(n) = 0
       sd_itmp3(n) = 0

       sd_dtmp1(n) = 0.0_RP
       sd_dtmp2(n) = 0.0_RP
    enddo

    do s = 1, sdnumasl_s2c
       do n = 1, sdnum_s2c
          sdasl_s2c(n,s) = 0.0_RP
       enddo
    enddo

    if( abs(sdm_aslset) > 10 ) then
       do n = 1, sdfmnum_s2c
         sdn_fm(n) = int(0,kind=DP)
         sdx_fm(n) = 0.0_RP
         sdy_fm(n) = 0.0_RP
         sdz_fm(n) = 0.0_RP
         sdr_fm(n) = 0.0_RP
         sdvz_fm(n) = 0.0_RP
       enddo
       do s = 1, sdnumasl_s2c
            do n = 1, sdnum_s2c
              sdasl_fm(n,s) = 0.0_RP
            enddo
       enddo
    endif

    do n = 1, ni_s2c*nj_s2c*nk_s2c+1
       sortfreq_s2c(n) = 0
    enddo

    do n = 1, ni_s2c*nj_s2c*nk_s2c+2
       sorttag_s2c(n) = 0
       sdm_itmp1(n) = 0
       sdm_itmp2(n) = 0
       sdm_itmp3(n) = 0
    enddo

    allocate(sdn_s2c_restart(1:sdnum_s2c))
    allocate(sdrk_s2c_restart(1:sdnum_s2c))
    allocate(sdx_s2c_restart(1:sdnum_s2c))
    allocate(sdy_s2c_restart(1:sdnum_s2c))
    allocate(sdz_s2c_restart(1:sdnum_s2c))
    allocate(sdr_s2c_restart(1:sdnum_s2c))
    allocate(sdu_s2c_restart(1:sdnum_s2c))
    allocate(sdv_s2c_restart(1:sdnum_s2c))
    allocate(sdvz_s2c_restart(1:sdnum_s2c))
    allocate(sdasl_s2c_restart(1:sdnum_s2c,1:sdnumasl_s2c))
    allocate(sdliqice_s2c_restart(1:sdnum_s2c))
    if( sdm_cold ) then
       allocate(sdice_s2c_restart%re(1:sdnum_s2c))
       allocate(sdice_s2c_restart%rp(1:sdnum_s2c))
       allocate(sdice_s2c_restart%rho(1:sdnum_s2c))
       allocate(sdice_s2c_restart%tf(1:sdnum_s2c))
       allocate(sdice_s2c_restart%mrime(1:sdnum_s2c))
       allocate(sdice_s2c_restart%nmono(1:sdnum_s2c))
    else
       allocate(sdice_s2c_restart%re(1:1))
       allocate(sdice_s2c_restart%rp(1:1))
       allocate(sdice_s2c_restart%rho(1:1))
       allocate(sdice_s2c_restart%tf(1:1))
       allocate(sdice_s2c_restart%mrime(1:1))
       allocate(sdice_s2c_restart%nmono(1:1))
    end if

    return

   end subroutine sdm_allocinit
end module m_sdm_memmgr


      PROGRAM SPHQPT
      IMPLICIT NONE
C ********************************************************************
C *                                                                  *
C * This software is an unpublished work containing confidential and *
C * proprietary information of Birkbeck College. Use, disclosure,    *
C * reproduction and transfer of this work without the express       *
C * written consent of Birkbeck College are prohibited. This notice  *
C * must be attached to all copies or extracts of the software.      *
C *                                                                  *
C * (c) 1993, 1996 Oliver Smart & Birkbeck College,                  *
C * (c) 1998 Oliver Smart                    *
C *                                                                  *
C ********************************************************************
C
C Modification history:
C
C Date  Author          Modification
C 12/93 O.S. Smart        Original public release in HOLE suite beta1.0
C 06/94 OSS & J.Neduvelil Allow the colour coding of surface according
C                         to radius.
C 07/94 OSS & J.Neduvelil Option for more uniform spaced dots by distance
C                         search.
C 10/94 OSS 		  Support for capsule output/modifications
C			  to support "LAST-REC-END" record in .sph file.
C 28/02/97 O.S.S.	Release HOLE2 beta001
C 11/97    O.S.S.       vt control codes
C 03/98    O.S.S.	special output file for Guy Coates "solid_surf"
C 05/98	   O.S.S.	input radius filter question added (RLOWER)
C
C 11/00    O.S.S.  	sphqpt (an interactive question asking routine)
C			made into a command line driven program
C
C Reads a pdb format file produced by hole
C option SPHPDB which contains sphere centre info,
C and produces a quanta plot file output with
C dot surface and centre line (see hole.doc)

C screen, keyboard
C sph_process now command line driven - comment out all
C interactive question lines with !(inter)
!(cinter)      INTEGER                   NIN
!(cinter)      PARAMETER(                NIN = 5)
!(cinter)C input/output file stream
!(cinter)      INTEGER                   SIN, SOUT
      INTEGER                   NOUT
      PARAMETER(                NOUT= 6)

      CHARACTER*200		FINPUT      ! inputfilename (penultimate argument)
      INTEGER			SIN         ! its stream number
      INTEGER			END_FINPUT  ! last character in filename
      CHARACTER*200		FOUTPUT     ! inputfilename (penultimate argument)
      INTEGER			SOUT        ! its stream number
      INTEGER			END_FOUTPUT ! last character in filename

!(cinter)C filename
!(cinter)      CHARACTER*200             FNAME

C string for text records in hydra file
      CHARACTER*80              STRING

C abort indicator
      LOGICAL                   LABORT

C draw centre lines?
      LOGICAL                   LCEN

C override radius?
      DOUBLE PRECISION		ROVER

C lower limit radius - any smaller than this and ignore on read
      DOUBLE PRECISION		RLOWER
C number of ignored records
      INTEGER			NIGN

C sphere centre storage arrays
C maximum number, actual number, co-ords and radius
C logical indicates whether the record is the last centre
      INTEGER                   SPMAX, SPNO
      PARAMETER(                SPMAX = 500000)
      DOUBLE PRECISION          SPXYZ( 3, SPMAX), SPRAD( SPMAX)
      LOGICAL                   SPLAST( SPMAX)
C capsule option needs to have the second centre
C n.b. SPRAD is the real capsule radius not the effective rad`
      DOUBLE PRECISION          SPSEC( 3, SPMAX)
C store whether point is product of connolly - pick up by -999 	residue number
      LOGICAL			SPCONN( SPMAX)
      ! need effective radius for colouring connolly
      DOUBLE PRECISION		SPEFFR( SPMAX)

! VBLES FOR s/r SPHPEG
! flag to indicate that the sphere is peg accessible
!  0: not peg accessible
!  1: accessible from +ve end
! -1: accessible from -ve end
!  2: in the shell (within distance shell_add of a peg sphere)
! -2: ditto
      INTEGER			SP_PEG_ACC( SPMAX)

! now with  SHELL_ADD need to modify the radius of some spheres
! normally this would be equal to sprad but if sp_peg_acc = +/-2
! then this radius will be lower
      DOUBLE PRECISION		SP_PEG_RAD( SPMAX)

! SCOTDO -> SP_TDO
! SCOENC -> SP_ENC
! SCOCIRCRAD -> SP_CIRCRAD
! n.b. vble may now be changed in calculation if sphere has no intersection
! with plane under consideration
      LOGICAL			SP_TDO( SPMAX)
C s/r coarea needs a store for the east/north coords of
C each point on grid - these are measured relative to the
C initial point
! SCOCIRCRAD: the radius of the point in the plane under consideration
! in the case of calls from concal this we equal scocrad
      DOUBLE PRECISION		SP_ENC( 2, SPMAX),
     &				SP_CIRCRAD( SPMAX)

! working flag for s/r coarea
      LOGICAL			SP_PEG_FLAG( SPMAX)

C loop counts x,y&z; sphere centre count, dots count,
C 2nd sphere centre count, colour Pass count
      INTEGER                   XCOUNT, SCOUNT

C dot density to be used in output
      INTEGER                   DOTDEN

C program uses a sphere of isotropically distributed points
C on a sphere of unit radius. PTMAX is the array bound,
C PTNO is the number of dots (dependent on dotden)
      INTEGER                   PTMAX, PTNO
      PARAMETER(                PTMAX = 10000)
      DOUBLE PRECISION          PTXYZ( 3, PTMAX)

C error indicator
      LOGICAL                   LERR

C variable to define colours
      DOUBLE PRECISION          RCUT(0:3)
C if we are doing colour NPASS=3
C if we are not doing colour NPASS=1
      INTEGER                   NPASS

C if doing a grid surface then check each new potential vertex
C to see if it lies with distance 0.6*rad*dmult (where rad is
C the pore radius at the point) of any line already output
C- stored in linxyz.
C If the new point is outside this range then it is accepted
C it is joined to any vertex within the range rad*dmult the
C straight line is then corrected so that it curves with the local
C pore surface
C
C within a distance DOTD2 (the square of the minimum distance apart).
C VERMAX is the array bound, VERNO is the number of accepted dots.
C fourth number is the radius of the sphere which produced the dot
      INTEGER                   VERMAX, VERNO
      PARAMETER(                VERMAX = 10000)
      DOUBLE PRECISION          VERXYZ( 4, VERMAX)

C also store points taken from output lines
      INTEGER                   LINMAX, LINNO
      PARAMETER(                LINMAX = 30*VERMAX)
      DOUBLE PRECISION          LINXYZ( 4,LINMAX)

C 21/07/94 program changed so that dot is output if it is
C at least dmult*sphere-radius from any other dot
      DOUBLE PRECISION          DMULT

C control flag - if true do a grid surface
      LOGICAL			LGRID

C logical vble capsules on
      LOGICAL			LCAPS

C string for output
      CHARACTER*90		OUTSTR

C doing sos output
      LOGICAL			SOSOUT

      ! vbles for get_rec_commands
      CHARACTER*3000 		REC_COMMANDS_HELP_MESSAGE
      INTEGER			REC_MAX  ! array bound
      PARAMETER(		REC_MAX = 15)
      INTEGER     		REC_TOT  ! actual number of arguements
      CHARACTER*25		REC_COMMANDS(REC_MAX)
      INTEGER			REC_REQUIRE_NUM(REC_MAX)
      INTEGER			REC_REQUIRE_STRING(REC_MAX)
      INTEGER			RCOUNT
      LOGICAL			REC_FOUND( REC_MAX)
      DOUBLE PRECISION		REC_NUM( 10, REC_MAX)
      INTEGER			REC_NUM_NUM( REC_MAX)
      CHARACTER*200		REC_STRING( 10, REC_MAX)
      INTEGER			REC_STRING_NUM( REC_MAX)

      LOGICAL			LBIN		! binary file indicator
      LOGICAL                   OPENRO	! open files readonly function

! vbles for forpeg option - hole channel vector etc.
      DOUBLE PRECISION		CVECT(3)
! unit vectors in plane normal to cvect
! needed to a number of routines - originally h2dmap but now conn
! and addend
! these are normal - first is east direction (x on plane)
!                    and second is north     (y on plane)
      DOUBLE PRECISION		PERPVE(3), PERPVN(3)
! a sampling distance - the distance between planes
      DOUBLE PRECISION		SAMPLE
! option CONN introduced 1/00 -
! CONNR(1) is the connolly surface probe radius (default 1.15Angs)
!          the option is turned off by setting this radius negative
! CONNR(2) is the grid size to be used in the calculation - default 1/2 probe
      DOUBLE PRECISION		CONNR(2)
! the radius at which an end is reached
      DOUBLE PRECISION		ENDRAD

! PEG is on OR NOT
      LOGICAL 			LPEG

! vbles for working peg effect on conductance -
! first number the ratio of conductance with PEG about to water
! second number is the ratio for non-penetrating PEG
      DOUBLE PRECISION		PEGRAT(2)

! probe radius - +ve direction and -ve
      DOUBLE PRECISION		PROBE_PLUS, PROBE_NEG

! (n037) additional shell around peg spheres where the
! conductivity of the solvent is reduced.
      DOUBLE PRECISION		SHELL_ADD

! output of the triangle
      LOGICAL			TRIOUT

! end of decs ******************

!(cinter)C turn on VT codes  with bold after prompt-
!(cinter)      CALL VTCON( .TRUE.)

C initialise the no.of accepted dots to 0
      VERNO = 0

C capsule option defaults to off
      LCAPS = .FALSE.
C initialize
      LERR = .FALSE.

C write greeting
      WRITE( NOUT, '(A)')
     &' *** Program sph_process (replacing sphqpt) ***',
     &' Reads a .sph file produced by hole',
     &' option SPHPDB which contains sphere centre info,',
     &' and processes it to a either dot surface or a number'//
     &                                     ' of other options',
     &' either as a dot or grid representation',
     &' Written by Oliver Smart at Birkbeck College from 1996.',
     &' Copyright 1996,1997 Oliver Smart ',
     &' Copyright 2004 Oliver Smart ',
     &' Copyright 2014-2015 SmartSci Limited, All rights reserved.'

C write link time of program to screen
      CALL VERTIM( NOUT)

      ! get the controlling command line arguments

      ! establish values for s/r get
      REC_COMMANDS_HELP_MESSAGE =
     &'                     (help message start)\n'//
     &' sph_process works on .sph file produced by PDBSPH '//
     &                                             'option in hole.\n'//
     &' This file is then converted either to:\n'//
     &' (a) a dot or spaghetti surface - qpt format \n'//
     &' (b) an .sos input file for the sos_triangle program to \n'//
     &'     finally make a solid surface \n'//
     &' (c) PEG option (to be written)\n'//
     &' \n'//
     &' Usage: '//
     &' sph_process (-qpt) (-nocen) (-sos) ... '//
     &                                    ' input_file output_file\n'//
     &' options: \n'//
     &'  -qpt:  produce a dot surface to qpt file (default)\n'//
     &'  -sos:  produce a .sos file for use by sos_triangle \n'//
     &'  -dotden D: use a dot density of D used by -qpt and'//
     &                                           '-sos options\n'//
     &'             D should be between 5 and 30 the higher the\n'//
     &'             value the more dots. Default is 10. \n'//
     &'  -nocen: do not produce centre line (-qpt only) \n'//
     &'  -spaghetti (X): produce a spaghetti rather than a dot \n'//
     &'                  surface (for -qpt only \n'//
     &'                  controlled by X the grid density \n'//
     &'                  A X value of 2.0 will produce a rather\n '//
     &'                  rough surface, 1.3 a rather dense surface\n'//
     &'                  default is 1.8 a reasonable compromise.\n'//
     &'                  N.B. procedure takes much longer than '//
     &                                          ' dot surface.\n'//
     &'  -rover Rover: use an override radius of Rover angs.\n'//
     &'              every sphere read will be assigned radius R\n'//
     &'              instead of individual radii\n'//
     &'  -ignore_small (Rignore): ignore any spheres with a radius\n'//
     &'                           less than Rignore. If argument\n'//
     &'                           found then a default 1.15angs\n'//
     &'                           used unless a value is specified\n'//
     &'  -colour (Rlow Rmid): produce a coloured surface\n'//
     &'                       surface will be \n'//
     &'                       red for pore radii < Rlow \n'//
     &'                       green for Rlow < pore radii < Rmid\n'//
     &'                       blue  for pore radii > Rmid\n'//
     &'                       default Rlow = 1.15 angs\n'//
     &'                       default Rmid = 2.30 angs\n'//
     &'                       (for connolly use effective radius\n'//
     &'                        of slab rather than pore radius\n'//
     &'  -color same as -colour for yanks\n'//
     &'  -peg Rplus Rminus ThetaPEG ThetaNON\n'//
     &'       Graphical output - specify with -sosout for .sph file\n'//
     &'                          with accessible spheres in it\n'//
     &'                          defaults to drawing sections to qpt'

!      call chrend( rec_commands_help_message, line_end)
!      write( nout, '(a)') rec_commands_help_message(1:line_end)
      REC_TOT = 11
      DO RCOUNT = 1,REC_TOT          ! initialize require store
        REC_REQUIRE_NUM(RCOUNT) = 0
	REC_REQUIRE_STRING(RCOUNT) = 0
      ENDDO
      REC_COMMANDS(1) = 'qpt'     ! do not specify the -
      REC_COMMANDS(2) = 'sos'     !
      REC_COMMANDS(3) = 'dotden'  !
      REC_REQUIRE_NUM(3) = 1 ! require single value after dotden
      REC_COMMANDS(4) = 'nocen'
      REC_COMMANDS(5) = 'spaghetti'
      REC_COMMANDS(6) = 'rover'
      REC_REQUIRE_NUM(6) = 1 ! require a single value after rover
      REC_COMMANDS(7) = 'ignore_small'
      REC_COMMANDS(8) = 'colour'
      REC_COMMANDS(9) = 'color'
      REC_COMMANDS(10) = 'peg'
      REC_REQUIRE_STRING(10) = 4
      REC_COMMANDS(11) = 'tri'

      CALL GET_REC_COMMANDS( NOUT, LERR,
     &			     REC_COMMANDS_HELP_MESSAGE,
     &                       REC_TOT, REC_COMMANDS,
     &                       REC_REQUIRE_NUM, REC_REQUIRE_STRING,
     &                       REC_FOUND, REC_NUM, REC_NUM_NUM,
     &			     REC_STRING, REC_STRING_NUM,
     &			     .TRUE., FINPUT, .TRUE., FOUTPUT)
      IF (LERR) GOTO 55555

      ! REC_COMMANDS(2) = 'sos'     !
      SOSOUT = .FALSE.	! default to qpt rather sos type out
      IF (REC_FOUND(2)) SOSOUT = .TRUE. ! -sos arg?

      ! REC_COMMANDS(3) = 'dotden'  !
      DOTDEN = 10	! dot density (dot type output)
      IF (REC_FOUND(3)) THEN ! override dotden?
        DOTDEN = REC_NUM(1,3)
	IF ((DOTDEN.LT.1).OR.(DOTDEN.GT.100)) THEN
          WRITE( NOUT, '(A,I5,A/ A)')
     &' Error dot density found after -dotden card =', DOTDEN,
     &    ' this is out of range.',
     &' -dotden value must be between 1 and 100'
        LERR = .TRUE. ! have failed
          GOTO 55555
	ENDIF
      ENDIF

      ! REC_COMMANDS(4) = 'nocen'
      LCEN = .TRUE. 	               ! default draw centre lines
      IF (REC_FOUND(4)) LCEN = .FALSE. ! if argument found override

      ! REC_COMMANDS(5) = 'spaghetti'
      LGRID = .FALSE.	               ! default do dot surface rather than sphagetti grid
      IF (REC_FOUND(5)) THEN
        LGRID = .TRUE.                ! if argument found override
	DMULT = 1.8 ! has the dmult value been specified?
        IF (REC_NUM(1,5).GT.-1E10) DMULT = REC_NUM(1,5)
      ENDIF

      ! REC_COMMANDS(6) = 'rover'
      ROVER  = 0.	! default no override radius
      IF (REC_FOUND(6)) ROVER = REC_NUM(1,6)

      ! REC_COMMANDS(7) = 'ignore_small'
      RLOWER = -1D06    ! default no ignore low radius records
      IF (REC_FOUND(7)) THEN
        RLOWER = 1.15
	IF (REC_NUM(1,7).GT.-1E10) RLOWER = REC_NUM(1,7)
      ENDIF

      ! REC_COMMANDS(8) = 'colour'
      ! REC_COMMANDS(9) = 'color'
      ! if we are doing colour NPASS=3
      ! if we are not doing colour NPASS=1 accept any radii
      NPASS = 1
      RCUT(0) = -1.0
      RCUT(1) = 9999.0
      IF (REC_FOUND(8).OR.REC_FOUND(9)) THEN
        NPASS = 3
        RCUT(1) = 1.15
	RCUT(2) = 2.30
	RCUT(3) = 9999.0 ! default values for colour
	! pick up the radii if specified
	IF (REC_NUM(1,8).GT.-1E10) RCUT(1) = REC_NUM(1,8)
	IF (REC_NUM(1,9).GT.-1E10) RCUT(1) = REC_NUM(1,9)
	IF (REC_NUM(2,8).GT.-1E10) RCUT(2) = REC_NUM(2,8)
	IF (REC_NUM(2,9).GT.-1E10) RCUT(2) = REC_NUM(2,9)
      ENDIF

      ! REC_COMMANDS(10) = 'peg'
      !  Rplus Rminus ThetaPEG ThetaNON
      LPEG = .FALSE.	               ! default do dot surface rather than sphagetti grid
      IF (REC_FOUND(10)) THEN
        LPEG = .TRUE.                ! if argument found override
        SAMPLE = -1E10   ! to detect lack of proper keys in .sph
	CVECT(1) = -1E10 ! all of these values should be read by
	CONNR(1) = -1E10 ! s/r sph_process_read
	PERPVE(1) = -1E10
	PERPVN(1) = -1E10
	ENDRAD = -1E10
	PROBE_PLUS = REC_NUM(1,10)
	PROBE_NEG  = REC_NUM(2,10)
	PEGRAT(1)  = REC_NUM(3,10)
	PEGRAT(2)  = REC_NUM(4,10)
	! optional 5th arguement
	SHELL_ADD = 0.
        IF (REC_NUM(5,10).GT.-1E10) SHELL_ADD = REC_NUM(5,10)
      ENDIF

      IF (REC_FOUND(11)) THEN
        TRIOUT = .TRUE.
        SOSOUT = .TRUE.
      ELSE
        TRIOUT = .FALSE.
      ENDIF
      ! end of unpacking arguments

      ! find last character in each filename
      CALL CHREND( FOUTPUT, END_FOUTPUT)
      CALL CHREND( FINPUT, END_FINPUT)

! open the input file as readonly
      IF (.NOT.OPENRO( SIN, FINPUT, NOUT)) THEN
        WRITE( NOUT, '(A,A,A)')
     &' Error cannot open input file: ''', FINPUT(1:END_FINPUT), ''''
        LERR = .TRUE. ! have failed
        GOTO 55555
      ENDIF

! open the output file as new
! use s/r newop - this keeps old version removes tilda's spaces etc. etc.
! arguments output stream, error indicator,
! reduce_output_variable (0 for full), filename, filestream, binary indicator
      IF (FOUTPUT(1:4).NE.'none') THEN
        LBIN = .FALSE.
        IF (.NOT.SOSOUT) LBIN = .TRUE. ! qpt files are binary
        CALL NEWOP( NOUT, LERR, 0,
     &                  FOUTPUT, SOUT, LBIN)
        IF (LERR) THEN
          WRITE( NOUT, '(A,A,A)')
     &' Error cannot open output file: ''', FOUTPUT(1:END_FOUTPUT), ''''
          LERR = .TRUE. ! have failed
          GOTO 55555
        ENDIF
      ELSE
        ! no output file - only to be used for -peg option
        SOUT = -1
	WRITE( NOUT, '(A)')
     &'WARNING ''none'' specified as output file - so have not opened',
     &'        one.  This only makes sense with -peg option'
      ENDIF

      WRITE( NOUT, '(/ A,A,A/ A,A,A)')
     &'Have opened ', FINPUT(1:END_FINPUT),   ' for input ',
     &'        and ', FOUTPUT(1:END_FOUTPUT), ' for output'
      IF (.NOT.SOSOUT) THEN ! qpt or sos? ans:qpt
	WRITE( NOUT, '(A)')
     &'qpt output option used '
      ELSE
        IF (LPEG) THEN
	  WRITE( NOUT, '(A)')
     &'sph type output option used for PEG - next program to run ',
     &'            to process this is THIS PROGRAM AGAIN ',
     &'            with -sos option but no -peg. '
        ELSE
	WRITE( NOUT, '(A)')
     &'sos type output option used - next program to run '//
     &                                'is ''sos_triangle'' '
	ENDIF
      ENDIF

!(cinter)C use s/r lastf to find latest file of
!(cinter)C type in the directory.  N.b. only works on unix machines
!(cinter)      CALL LASTF( FNAME, '.sph')
!(cinter)!(cinter)      IF (FNAME(1:4).EQ.'none') FNAME = 'input'
!(cinter)
!(cinter)C get input filename
!(cinter)      LABORT = .TRUE.
!(cinter)C (input stream, output, oldfile?, file_stream, file_type, name,
!(cinter)C  allow abort?, default extension)
!(cinter)C N.B. as file_type includes 'BINARY' then will open as binary
!(cinter)      CALL INTERF( NIN, NOUT, .TRUE., SIN,
!(cinter)     &  'input pdb format', FNAME, LABORT, '.sph')
!(cinter)      IF (LABORT) GOTO 55555
!(cinter)
!(cinter)C new option to write ascii output for input to guy coates' solid_surf
!(cinter)      OUTSTR =
!(cinter)     &'What format for output file Qpt (quanta)'//
!(cinter)     &                 ' or Sos (solid_surf)? <Q>:'
!(cinter)      CALL PROMPT( NOUT, OUTSTR)
!(cinter)      READ( NIN, '(A) ', ERR=55555, END=55555) STRING
!(cinter)      CALL VTCLEAR( NOUT)
!(cinter)
!(cinter)C if the string is not blank try to read value
!(cinter)      IF ((STRING(1:1).EQ.'S').OR.(STRING(1:1).EQ.'s')) THEN
!(cinter)C sos output
!(cinter)        SOSOUT = .TRUE.
!(cinter)C get output filename
!(cinter)        LABORT = .TRUE.
!(cinter)        CALL INTERF( NIN, NOUT, .FALSE., SOUT,
!(cinter)     &  'output sos', FNAME, LABORT, '.sos')
!(cinter)        IF (LABORT) GOTO 55555
!(cinter)
!(cinter)      ELSE
!(cinter)C quanta output
!(cinter)        SOSOUT = .FALSE.
!(cinter)C get output filename
!(cinter)        LABORT = .TRUE.
!(cinter)        CALL INTERF( NIN, NOUT, .FALSE., SOUT,
!(cinter)     &  'output binary hydra/quanta plot', FNAME, LABORT, '.qpt')
!(cinter)        IF (LABORT) GOTO 55555
!(cinter)      ENDIF
!(cinter)
!(cinter)C next question only for qpt output
!(cinter)      IF (SOSOUT) THEN
!(cinter)	LCEN = .FALSE.
!(cinter)      ELSE
!(cinter)C does the user want the centre lines drawn?
!(cinter)        CALL PROMPT( NOUT,
!(cinter)     & 'Do you want the centre lines drawn in output file? (y/n) <y>:')
!(cinter)        READ( NIN, '(A1)', ERR= 55555, END= 55555) STRING(1:1)
!(cinter)        IF (STRING(1:1).EQ.'N'.OR.STRING(1:1).EQ.'n') THEN
!(cinter)	  LCEN = .FALSE.
!(cinter)        ELSE
!(cinter)  	  LCEN = .TRUE.
!(cinter)        ENDIF
!(cinter)      ENDIF
!(cinter)
!(cinter)C overide radii?
!(cinter)      CALL VTCLEAR( NOUT)
!(cinter)      WRITE( NOUT, '(A)')
!(cinter)     &' It is possible to enter a number to which all the sphere',
!(cinter)     &'   centre radii will be set regardless of value in file.'
!(cinter)      CALL PROMPT( NOUT,
!(cinter)     & 'Enter value <leave radii alone>:')
!(cinter)      READ( NIN, '(A)', ERR= 55555, END= 55555) STRING
!(cinter)C if the string is not blank try to read value
!(cinter)      IF (STRING(1:5).NE.'     ') THEN
!(cinter)	READ( STRING, '(BN,F10.0)') ROVER
!(cinter)      ELSE
!(cinter)	ROVER = 0.
!(cinter)      ENDIF
!(cinter)
!(cinter)C Ignore small radii or Big?
!(cinter)      CALL VTCLEAR( NOUT)
!(cinter)      WRITE( NOUT, '(A)')
!(cinter)     &' Do you want to ignore small radius records on read?'
!(cinter)      CALL PROMPT( NOUT,
!(cinter)     & 'Enter lower limit to be used <use all records>:')
!(cinter)      READ( NIN, '(A)', ERR= 55555, END= 55555) STRING
!(cinter)C if the string is not blank try to read value
!(cinter)      IF (STRING(1:5).NE.'     ') THEN
!(cinter)	READ( STRING, '(BN,F10.0)') RLOWER
!(cinter)      ELSE
!(cinter)	RLOWER = -1D06
!(cinter)      ENDIF
!(cinter)
!(cinter)C next question only for qpt output
!(cinter)      IF (SOSOUT) THEN
!(cinter)	LGRID = .FALSE.
!(cinter)      ELSE
!(cinter)
!(cinter)C dot or grid surface?
!(cinter)        CALL VTCLEAR( NOUT)
!(cinter)        WRITE( NOUT, '(A)')
!(cinter)     &' This program can either do a dot surface (which is fast) or',
!(cinter)     &'    a curving grid surface (which is must slower).'
!(cinter)        CALL PROMPT( NOUT,
!(cinter)     & '   Do you want a dot (D) or grid (G) surface? <dot>:')
!(cinter)        READ( NIN, '(A) ', ERR=55555, END=55555) STRING
!(cinter)        CALL VTCLEAR( NOUT)
!(cinter)
!(cinter)C if the string is not blank try to read value
!(cinter)        IF ((STRING(1:1).EQ.'G').OR.(STRING(1:1).EQ.'g')) THEN
!(cinter)
!(cinter)C July '94 - allow more uniform dot surface by
!(cinter)C value for dotd2
!(cinter)          WRITE( NOUT, '(A)')
!(cinter)     &' The density of the grid surface is controlled by DMULT',
!(cinter)     &' A value of 2.0 will produce a rather rough surface, 1.3 a',
!(cinter)     &' rather dense surface - 1.8 is a reasonable compromise.',
!(cinter)     &' N.b. procedure takes much longer than dot surface.'
!(cinter)          CALL PROMPT( NOUT,
!(cinter)     & 'What value for DMULT? <1.8>:')
!(cinter)          READ( NIN, '(A) ', ERR=55555, END=55555) STRING
!(cinter)C if the string is not blank try to read value
!(cinter)          IF (STRING(1:5).NE.'     ') THEN
!(cinter)            READ( STRING, '(BN,F10.0)' ) DMULT
!(cinter)          ELSE
!(cinter)            DMULT = 1.8
!(cinter)          ENDIF
!(cinter)C doing distance search - use high value for dot density
!(cinter)C i042 shows that 25 seems to give reasonable results
!(cinter)	  DOTDEN = 25
!(cinter)          LGRID = .TRUE.
!(cinter)        ELSE
!(cinter)
!(cinter)C normal quick dot surface
!(cinter)          LGRID = .FALSE.
!(cinter)        ENDIF
!(cinter)C end of if for qpt only
!(cinter)      ENDIF
!(cinter)
!(cinter)C Doing dot surface?
!(cinter)      IF (.NOT.LGRID) THEN
!(cinter)C prompt value for dotden
!(cinter)        CALL VTCLEAR( NOUT)
!(cinter)        WRITE( NOUT, '(A)')
!(cinter)     &' The number of dots on the surface is controlled by DOTDEN',
!(cinter)     &'   The higher DOTDEN the more dots: 5 produces few dots, 20 alot'
!(cinter)        CALL PROMPT( NOUT,
!(cinter)     & 'What value for dotden? <10>:')
!(cinter)        READ( NIN, '(A)', ERR= 55555, END= 55555) STRING
!(cinter)C if the string is not blank try to read value
!(cinter)        IF (STRING(1:5).NE.'     ') THEN
!(cinter)	  READ( STRING, '(BN,I10)') DOTDEN
!(cinter)        ELSE
!(cinter)	  DOTDEN = 10
!(cinter)        ENDIF
!(cinter)      ENDIF
!(cinter)
!(cinter)C does the user want to implement colour to illustrate the radius size?
!(cinter)      CALL PROMPT( NOUT,
!(cinter)     &'Do you want to colour surface according to pore radius? <n>:')
!(cinter)      READ( NIN, '(A1)', ERR= 55555, END= 55555) STRING(1:1)
!(cinter)      IF ((STRING(1:1) .EQ.'Y').OR.(STRING(1:1) .EQ.'y')) THEN
!(cinter)	NPASS=3
!(cinter)	CALL PROMPT( NOUT,
!(cinter)     &  'What upper radius for low radius colour (red) <1.15>:')
!(cinter)	READ( NIN, '(A)', ERR= 55555, END= 55555) STRING
!(cinter)C if the string is not blank try to read value
!(cinter)	IF (STRING(1:5).NE.'     ')THEN
!(cinter)	  READ( STRING, ' (BN,F10.0)') RCUT(1)
!(cinter)	ELSE
!(cinter)	  RCUT(1) = 1.15
!(cinter)	ENDIF
!(cinter)	CALL PROMPT( NOUT,
!(cinter)     &  'What upper radius for mid radius colour (green) <2.30>:')
!(cinter)	READ( NIN, '(A)', ERR= 55555, END= 55555) STRING
!(cinter)C if the string is not blank try to read value
!(cinter)	IF (STRING(1:5).NE.'     ')THEN
!(cinter)	  READ( STRING, ' (BN,F10.0)') RCUT(2)
!(cinter)	ELSE
!(cinter)	  RCUT(2) = 2.3
!(cinter)	ENDIF
!(cinter)	CALL PROMPT( NOUT,
!(cinter)     &  'What upper radius for high radius colour (blue) <999>:')
!(cinter)	READ( NIN, '(A)', ERR= 55555, END= 55555) STRING
!(cinter)C if the string is not blank try to read value
!(cinter)	IF (STRING(1:5).NE.'     ')THEN
!(cinter)	  READ( STRING, ' (BN,F10.0)') RCUT(3)
!(cinter)	ELSE
!(cinter)	  RCUT(3) = 999.0
!(cinter)	ENDIF
!(cinter)      ELSE
!(cinter)C do not colour according to radius - make only one pass
!(cinter)C outputing all records
!(cinter)	RCUT(1) = 999.0
!(cinter)	NPASS=1
!(cinter)      ENDIF
!(cinter)C rcut zero must be negative
!(cinter)      RCUT(0) =-1.0
!(cinter)
!(cinter)      CALL VTCLEAR( NOUT)

C have opened input and output files
C and got initial conditions start work
      CALL SPH_PROCESS_READ( NOUT, LERR, SIN, ROVER, RLOWER,
     &				   SPMAX, SPNO, SPXYZ, SPRAD, SPLAST,
     &				   SPSEC, SPCONN, SPEFFR, LCAPS,
     & 				   SAMPLE, CVECT, PERPVE, PERPVN,
     &				   CONNR, ENDRAD )
      IF (LERR) GOTO 55555

C draw centre line?
! but not if doing sos type output
      IF (LCEN.AND.(.NOT.SOSOUT).AND.(.NOT.LPEG)) THEN
C change to colour 7 (as in hole)
C change 18/10/95 centre line number 4 (yellow) alt 15
        WRITE( NOUT, '(A)')
     &' Outputing centre line to quanta colour 4 (default yellow)'
        WRITE(SOUT) 1.0, 4.0, -55.0, 15.0
C moveto first point
C 10/7/96 change so that do capsule midpoints - regardless of
C whether we have capsule or not (does not matter for spheres
C as second centre is the same as the first).
	WRITE(SOUT) 2.0,
     &   (REAL(0.5*(SPXYZ(XCOUNT,1)+SPSEC(XCOUNT,1))), XCOUNT= 1, 3)
C go thru rest of points
	DO 30 SCOUNT = 2, SPNO
Cignore all connolly type records
          IF (SPCONN(SCOUNT)) GOTO 30
C if the previous point is an end move
! 4/4/04 move if either previous or this one is an end!
	  IF (SPLAST(SCOUNT-1).OR.SPLAST(SCOUNT)) THEN
            WRITE(SOUT) 2.0, (REAL(0.5*(SPXYZ(XCOUNT,SCOUNT) +
     &                                  SPSEC(XCOUNT,SCOUNT))),
     &                                  XCOUNT= 1, 3)
	  ELSE
C previous not an end - draw
            WRITE(SOUT) 3.0, (REAL(0.5*(SPXYZ(XCOUNT,SCOUNT) +
     &                                  SPSEC(XCOUNT,SCOUNT))),
     &                                  XCOUNT= 1, 3)
	  ENDIF
30      CONTINUE
      ENDIF
C end of drawing centre lines

C 10 July 1996 split of drawing part into seperate s/r's for normal
C (uniform and capsule options) except for centre line which has just been
C done.
      IF (LCAPS) THEN
        CALL SPHQPC( 5, NOUT, SOUT, LERR,
     &               DOTDEN, PTMAX, PTNO, PTXYZ,
     &               SPMAX, SPNO, SPXYZ, SPRAD, SPLAST, SPSEC,
     &               LGRID, NPASS, RCUT, DMULT,
     &               VERMAX, VERNO, VERXYZ, LINMAX, LINNO, LINXYZ,
     &               SOSOUT)

      ELSEIF (LPEG) THEN
        CALL SPHPEG( NOUT, SOUT, LERR,
     &               DOTDEN, PTMAX, PTNO, PTXYZ,
     &               SPMAX, SPNO, SPXYZ, SPRAD, SPEFFR, SPLAST,
     &		     SP_PEG_ACC,
     &               SOSOUT,
     & 		     SAMPLE, CVECT, PERPVE, PERPVN,
     &		     CONNR, ENDRAD, PROBE_PLUS, PROBE_NEG, PEGRAT,
     &               SP_TDO, SP_ENC, SP_CIRCRAD, SP_PEG_FLAG,
     &		     SP_PEG_RAD, SHELL_ADD)

      ELSEIF (TRIOUT) THEN
        ! direct output of triangles attempt may 2002
	CALL SPHTRI( NOUT, SOUT, LERR,
     &               DOTDEN,
     &               SPMAX, SPNO, SPXYZ, SPRAD, SPEFFR, SPLAST,
     &               NPASS, RCUT, DMULT)

      ELSE
        CALL SPHQPU( NOUT, SOUT, LERR,
     &               DOTDEN, PTMAX, PTNO, PTXYZ,
     &               SPMAX, SPNO, SPXYZ, SPRAD, SPEFFR, SPLAST,
     &               LGRID, NPASS, RCUT, DMULT,
     &               VERMAX, VERNO, VERXYZ, LINMAX, LINNO, LINXYZ,
     &               SOSOUT)
      ENDIF
      CLOSE( SOUT)

55555 CONTINUE
!      STOP 'FORTRAN STOP - sphqpt normal completion.'
      IF (LERR) THEN
        CALL EXIT(1)
      ELSE
        CALL EXIT(0)
      ENDIF
      END