	PROGRAM TDSXYVIS
C
C	PLOTS TDS X AND Y AND FREQUENCY SPECTRUM DIFFERENCE
C
	include		'wind_examples:wind_tm_routine_def.for'
	include		'wind_examples:wind_return_code_def.for'
	integer*4	ok
	integer*4	i,j,k,n,itemp
	integer*4	get_stream_name
	integer*4	wait_for_events			! an entry point
	integer*4	err_count
	integer*4	ichpa(6),ipacal(6,4)
	character*80	stream
	character*4	event,CDFEVENT
	character*4	pa(6,4),parx(9)
	parameter	size=2048
	integer*4	return_size
	integer*4	tds_channel,ifilf,ifils,ifil,ifsps,issps,isps
	integer*4	temp_waves,iend,n2,sunclock
	character*32	s
	integer*4	s_scet(2)
	real*8		scet,scettds,scetfill,bscet
	real*8		XKM,YKM,ZKM
	real*4		RE
	integer*4	major, minor
	character*80	file
	character*32	item
	integer*4	ios,ms,doy,msday,dds
	integer*4	NREM,NHRMN,IHRMN,yyyy,mon,dd,hh,mm,ss,IFASTSLOW
	real 		FILTER,ffilter,sfilter,fsps,ssps,sps
	REAL 		S1,S2,PP(2050),BX,BY,BZ
	REAL 		XDATA(2050),YDATA(2050),XSPECT(1025),YSPECT(1025)
	REAL 		XPHASE(1025),YPHASE(1025),DPHASE(1025)
!
	common /nrblk/ nrem,NHRMN,IFASTSLOW
	common /headblk/ major,minor,s_scet
	COMMON /BBLOCK/ BSCET,BX,BY,BZ,BAZ
	COMMON /XFER/ SPHASE(1025)
C
	CHARACTER*12 PTITLE(20)
	INTEGER*4 TDSCH,hkch,fillch,ch
	COMPLEX CGAIN,FCOEF,FCOEFT,CCORR
	COMMON /PLTBLK/ IZCNT,IPROCESS,ZCROSS(2048),ZINT(2048),
     1   NDATA(2048),DATA(2050),SPECT(1025)
	COMMON /PARTBLK/ X4DATA(2050,4),XRE,YRE,ZRE,SUNCLOCK,SPINRATE
	COMMON /HEADBL/ PTITLE,EVENT,NUMEVENT,FILE
	COMMON /GAINBLK/ PHASE,CGAIN                   ! PHASE IS IN RADIANS
	COMMON /FITBLK/ NPT,VOLTIN(2048),TM(2048)
	COMMON /TDS_STATUS/ TDS_CHANNEL,SPS,FILTER,IRX,ISPS
	COMMON /STATUS/ FFILTER(4),SFILTER(4),FSPS(4),SSPS(4)
	DATA TWOPI /6.2831853/
	DATA FFILTER /50000.,12500.,3125.,781./
	DATA SFILTER /3125.,781.,195.,49./
	DATA FSPS /120.,30.,7.5,1.875/
	DATA SSPS /7500.,1875.,468.75,117.2/
	DATA PARX /'EXAC','EYAC','EZAC','EXDC','EYDC','EZDC',
     1    ' BX ',' BY ',' BZ '/
	DATA PA /'EXAC','EXAC','EXDC',' BX ',' BY ',' BZ ',
     1           'EXDC','EYAC','EYDC','EXDC','EYDC','EZDC',
     2           '    ','EZAC','EZDC','    ','    ','    ',
     3           '    ','EZAC','EZDC','    ','    ','    '/
	DATA IPACAL /1,    1,     4,     7,     8,     9,
     1               4,    2,     5,     4,     5,     6,
     2               0,    3,     6,     0,     0,     0,
     3               0,    3,     6,     0,     0,     0/
	DATA IFASTSLOW /0/		! 0 IS FAST, 1 IS SLOW
	DATA ICHEOF /0/			! 1 IS EOF ON FILL, 2 ON TDS
C	DATA XLEN /46./
C	DATA YLEN /5.4/
C	DATA ZLEN /2.17/
	DATA XLEN,YLEN,ZLEN /41.1, 3.79, 2.17/
C	LEVEL = 0 IS JUST PRINT, 1 IS WRITE FILES, 2 IS DO PLOTS
	DATA LEVEL /2/
C
	PTITLE(1) = 'WIND-WAVES'
	PTITLE(2) = 'TIME DOMAIN'
	PTITLE(3) = 'SAMPLER'
	PTITLE(4) = 'EVENT NO.'
	PTITLE(8) = 'SAMPLE RATE'
	PTITLE(10) = 'L.P.FILTER'
C	PTITLE(12) = 'TRIGGERS'
	PTITLE(15) = 'SCET'
	PRINT*,' '
C
 1001	FORMAT(I4,1X,20I5)
 1002	FORMAT(A)
C
C	GET STARTED
C
	ok = get_stream_name(stream)
	if (.not. ok) stop 'no file supplied.'
	if (ok.eq.1) type*,'file',stream
C
 10	  write(6,*)  'type hr,min to start, e.g. 0412'
	  read(5,3,err=10) iq, NHRMN
	  type*,NHRMN
	  HH = NHRMN/100
	  MM = MOD(NHRMN,100)
	  write(6,4)
	  read(5,*,err=10,end=20)  ifastslow
	type*,'type desired process level,0=raw,1=raw volts,2=fft,fft inv'
	read(5,3) iq,iprocess
	type*,' '
	if(iprocess.eq.0) type*,'ok, plot data in tm numbers - 128'
	if(iprocess.eq.1) type*,'ok, plot in volts, unity freq. response.'
	if(iprocess.ge.2) type*,'ok, plot volts, corrected for freq. response.'
	if(iprocess.eq.3) type*,'ok, plot volts, corrected for bad TDS data'
	type*,' '
	  write(6,6)
	  write(6,7)
	  read(5,*,err=10,end=20)  iend,n2
	  type*,iend,n2
	  if(iend.eq.1) then
c		nrem = n2
		nrem = 2000
	  endif
	  if(iend.eq.2) then
		nrem = 2
		if(ifastslow.eq.1) nrem = 4
		nevent = n2
	  endif
c
c
  6	format(1x,'for a specific event,type 2, event number')
  7	format(1x,'type 1,anything, to do all events after start time')
  5	format(q,a)
  4	format(1x,'type 0 for fast TDS, 1 for slow')
  3	format(q,i10)
c
	ok = w_channel_open(tdsch,stream)
	if (.not. ok) stop 'Cannot open tds channel'
	scettds = 0.
	call w_channel_position(tdsch,scettds)
	print*,'tds file starts at scettds',scettds
	dds = scettds
	scettds = float(dds) + hh/24. + mm/1440.
	print*,'set tds channel position to',scettds
	call w_channel_position(tdsch,scettds)
	print*,'tds channel position set to',scettds

	ok = w_channel_open(fillch,stream)
	if (.not. ok) stop 'Cannot open fill channel'
	scetfill = 0.
	call w_channel_position(fillch,scetfill)
	print*,'scetfill',scetfill
	dds = scetfill
	scetfill = float(dds) + hh/24. + mm/1440.
	print*,'set channel position to',scetfill
	call w_channel_position(fillch,scetfill)
	print*,'fill channel position set to',scetfill
c
c	call w_ur8_to_ymd(scetT,yyyy,mon,dd,hh,mm,ss,ms)
	call w_ur8_to_ydoy(scetfill,yyyy,doy,msday)
	PRINT*,'RETURN FROM YDOY,SCETFILL,YYYY',SCETFILL,YYYY

	PRINT*,'GO W_EVENT',TDSCH
        IF(IFASTSLOW.EQ.0) THEN
	  ok = w_event(tdsch,'TDSF')
	ELSE
          ok = w_event(tdsch,'TDSS')
	ENDIF
	PRINT*,'RETURN FROM W_EVENT',TDSCH
	if(ok.eq.82) then
	   scettds = 10000.       	! artificially large
	else
	  item = 'EVENT_SCET'
	  ok = w_item_i4(tdsch, item, s_scet, 2, return_size)
	  print*,'initial tdsch time',s_scet
	endif
c
C	  item = 'EX_LENGTH_EFF'
C	  ok = w_item_R4(tdsch, item, XLEN, 1, return_size)
C	  item = 'EY_LENGTH_EFF'
C	  ok = w_item_R4(tdsch, item, YLEN, 1, return_size)
C	  item = 'EZ_LENGTH_EFF'
C	  ok = w_item_R4(tdsch, item, ZLEN, 1, return_size)
	  print*,'EFFECTIVE LENGTHS, X,Y,Z',XLEN,YLEN,ZLEN
C
        ok = w_event(fillch,'FILL')
	if(ok.eq.82) then
		icheof = 1
		stop 'end of file on tdsch'
	endif
	if (.not. ok) stop 'cannot get fill event'
c	item = 'EVENT_SCET_R8'
c	  ok = w_item_r8(fillch, item, scet, 2, return_size)
	item = 'EVENT_SCET'
	  ok = w_item_i4(fillch, item, s_scet, 2, return_size)
	print*,'initial fillch time',s_scet

c
	ok = w_channel_filename(tdsch,file)
c	IF(LEVEL.GE.1) write(87,*) file
	print*,file
c
	get_tm_stream = 1
c
C	GET NEXT EVENT
C
 110    continue
C
	! this is the main program loop

c        if( wind_tm_eof(fillch,major,minor)) stop 'end of file, fillch'

	if(scettds.lt.scetfill) then
	  event = 'TDSF'
	  IF(IFASTSLOW.NE.0)event = 'TDSS'
	  ch = tdsch
	else
	  event = 'FILL'
	  ch = fillch
	endif
C
	type*,'going to get next ',EVENT,' event'
c
	if(icheof.eq.1) then
	  event = 'TDSF'
	  IF(IFASTSLOW.NE.0)event = 'TDSS'
	  ch = tdsch
	elseif(icheof.eq.2) then
	  event = 'FILL'
	  ch = fillch
	else
	endif
c
	type*,'compare scettds,scetfill,evt',scettds,scetfill,event

	ok = w_event(ch,event)
	   if (.not. ok) then
	      type *, char(7), '******** missing packet in event ********'
              if( ok.eq.82) then
		 type*,'end of file on ',event
		 if(event.eq.'fill') then
			icheof = 1
		 else
			icheof = 2
		 endif
c                if( ok.eq.82) stop 'end of file on above channel '
	      endif
	   else
	      CALL TDS_PHYS(CH,IPROCESS,NDATA,DATA,SPECT)
	   end if
C
	   item = 'EVENT_NUMBER'
	   ok = wind_tm_get_item(ch, item, itemp, 1, return_size)
	   NUMEVENT = ITEMP
C
	     item = 'SUN_ANGLE'
	     ok = w_item_i4(ch, item, SUNCLOCK, 1, return_size)
		PRINT*,'SUNCLOCK',SUNCLOCK
C
	     CDFEVENT = 'CDF'
	     ok = w_event(CH,CDFEVENT)
	     item = 'WIND_MFI_SCET_R8'
	     ok = w_item_R8(ch, item, BSCET, 1, return_size)
	     item = 'WIND_MFI_BX(GSE)_R4'
	     ok = w_item_R4(ch, item, BX, 1, return_size)
	     item = 'WIND_MFI_BY(GSE)_R4'
	     ok = w_item_R4(ch, item, BY, 1, return_size)
	     item = 'WIND_MFI_BZ(GSE)_R4'
	     ok = w_item_R4(ch, item, BZ, 1, return_size)
	     IF(RETURN_SIZE.NE.0) THEN
		BAZ = ATAN2D(BY,BX)
		PRINT*,'TIME,B',BSCET,BX,BY,BZ
C		write(79,*) 'B',BX,BY,BZ,BAZ
	     ELSE
		PRINT*,'NO MFI DATA'
C		write(79,*) 'NO MFI DATA'
	     ENDIF
C
	     item = 'WIND_ORBIT_X(GSE)_R8'
	     ok = w_item_R8(ch, item, XKM, 1, return_size)
	     item = 'WIND_ORBIT_Y(GSE)_R8'
	     ok = w_item_R8(ch, item, YKM, 1, return_size)
	     item = 'WIND_ORBIT_Z(GSE)_R8'
	     ok = w_item_R8(ch, item, ZKM, 1, return_size)
	     item = 'EVENT_SCET'
	     ok = w_item_i4(ch, item, s_scet, 2, return_size)
		ss = mod(s_scet(2),100)
		mm = s_scet(2)/100
		mm = mod(mm,100)
		hh = s_scet(2)/10000
		scett = float(dds) + hh/24. + mm/1440. + ss/86400.
	     if(ch.eq.tdsch) then
	       scettds = scett
	     else
	       scetfill = scett
	     endif

	     call w_ur8_to_ymd(scetT,yyyy,mon,dd,hh,mm,ss,ms)
	     ihrmn = 100*hh+mm
	     TYPE *,'doy,date and time',doy,s_scet
c	     TYPE *,'scett,doy',scett,doy
C		write(26,*) itemp,s_scet
	   ihrmn = 100*hh+mm

	   write(s,'(i8.8,i6.6)',iostat=ios) s_scet(1), s_scet(2)
C	   s_scet = s(1:4)//'/'//s(5:6)//'/'//s(7:8)//' '//
C	1	s(9:10)//':'//s(11:12)//':'//s(13:14)

	   WRITE(PTITLE(16),1016) s(1:4),S(5:6),S(7:8)
	   WRITE(PTITLE(17),1017) DOY
	   WRITE(PTITLE(18),1018) s_scet(2)/100, MOD(s_scet(2),100)
 1016	   format(A4,'/',A2,'/',A2)
 1017	   FORMAT(' DOY ',I4)
 1018	   FORMAT(I6.4,I3.2)
	   WRITE(PTITLE(6),1019) TDS_CHANNEL
 1019	   FORMAT('CHANNEL',I2)
	   WRITE(PTITLE(5),1012) ITEMP
 1012	   FORMAT(I10)
C
	   ipa = ichpa(tds_channel)
	   WRITE(PTITLE(7),1007) PARX(IRX)
 1007	   FORMAT('P/A ',A4)
	   IF(TDS_CHANNEL.LE.2) THEN
	      WRITE(PTITLE(9),1004) .001*SPS
	   ELSE
	      WRITE(PTITLE(9),1008) SPS
	   ENDIF
	      WRITE(PTITLE(11),1008) FILTER
 1004	   FORMAT(F7.2,' kHZ')
 1008	   FORMAT(F7.0,' HZ')
 1009	   FORMAT('TDS CHANNEL',I4)

 222	FORMAT(10I6)
		IF(IPROCESS.EQ.0) THEN
	  DO IK = 1,2048
	    NDATA(IK) = NDATA(IK)-128
	    MAXDATA = MAX0(MAXDATA,IABS(NDATA(IK)))
	  ENDDO
	ELSE
	  DO IK = 1,2048
C	    DATA(IK) = TDSCAL(TDS_CHANNEL,ISPS,NDATA(IK))
	    NDATA(IK) = NDATA(IK)-128
	    MAXDATA = MAX0(MAXDATA,IABS(NDATA(IK)))
	  ENDDO
	ENDIF
	IF(TDS_CHANNEL.EQ.1) NUMEVONE = ITEMP
**********************
	IF(IFASTSLOW.EQ.0.AND.TDS_CHANNEL.GT.2) GO TO 110
C	write(87,7737) itemp,event,s_scet(2),tds_channel,
C     1	parx(irx),maxdata,
C     2	tdscal(tds_channel,isps,maxdata+128)
 7737	format(i10,2x,a4,i10,i5,2x,a4,i5,e12.3)
	IF(IEND.EQ.1.AND.TDS_CHANNEL.EQ.1.AND.MAXDATA.LE.95) GO TO 110
	IF(IEND.EQ.1.AND.TDS_CHANNEL.EQ.2.AND.MAXDATA.LE.100) GO TO 110
c	to pick out a specific event
	if(iend.eq.2.and.itemp.ne.nevent) go to 110
C*********
	type*,'event number',itemp
	TYPE*,'CHANNEL',tds_channel,'   EVENT = ',EVENT
	IF(TDS_CHANNEL.EQ.2.AND.ITEMP.NE.NUMEVONE) GO TO 110
	spr = 0.
	xsq = 0.
	ysq = 0.
	NPLOTS=NPLOTS+1
	IF(TDS_CHANNEL.EQ.1) THEN
	  DO N = 1,2050
	    XDATA(N) = DATA(N)
	    X4DATA(N,1) = DATA(N)
	  ENDDO
	  DO N = 1,1025
	    XSPECT(N) = SPECT(N)
	    XPHASE(N) = SPHASE(N)
	  ENDDO
	  GO TO 110
	ELSE
c*******
	IF(LEVEL.GE.1) THEN
	  open(unit=71,file='xydata.dat',status='old',access='append')
C	  write(71,*) file,itemp
	ENDIF
	  DO N = 1,2050
	    YDATA(N) = DATA(N)
	    X4DATA(N,2) = DATA(N)
	    xsq = xsq + xdata(n)**2
	    ysq = ysq + ydata(n)**2
	    spr = spr + xdata(n)*ydata(n)
C	    IF(LEVEL.GE.1) THEN
C	      IF(YDATA(N).NE.0.) THEN
C		WRITE(67,*) N,XDATA(N),YDATA(N),XDATA(N)/YDATA(N)
C	      ELSE
C		WRITE(67,*) N,XDATA(N),YDATA(N),YDATA(N)
C	      ENDIF
C	    ENDIF
	  ENDDO
	item = 'R_EARTH_R4'
	ok = w_item_R4(ch, item, RE, 1, return_size)
	RE = .001*RE				! CHANGE TO KM
	XRE= XKM/RE
	YRE= YKM/RE
	ZRE= ZKM/RE
	write(79,*) 'ORBIT X,Y,Z',XRE,YRE,ZRE
C	slope is vy/vx
	CALL FITSLOPE(XDATA,YDATA,2048,SLOPE,SUMSQ)
	IF(XSQ*YSQ.NE.0.) print*,'corr',spr/sqrt(xsq*ysq)
	ANGLE = ATAND(XLEN*SLOPE/YLEN) + 360.*SUNCLOCK/4096. - 45.
	ANGLE = -AMOD(ANGLE,180.)
C	IF(XSQ*YSQ.NE.0.) write(79,*)'corr',spr/sqrt(xsq*ysq)
	IF(XSQ.NE.0.) print*,'slope,sunclock,EANGLE',(XLEN/YLEN)*SLOPE,
     1	sunclock,angle
	IF(XSQ.NE.0.) WRITE(79,*) 'EVENT NO.',ITEMP
	IF(XSQ.NE.0.) WRITE(79,*) 'DATE,TIME',S_SCET
	IF(XSQ.NE.0.) WRITE(79,*) 'VOLTAGE SLOPE(VY/VX),SUNCLOCK',
     1		SLOPE,SUNCLOCK
	IF(XSQ.NE.0.) WRITE(79,*) 'ANGLE SUN TO E,GSE',ANGLE
	WRITE(79,*) 'xlen,ylen',xlen,ylen
	  DO N = 1,1025
	    YSPECT(N) = SPECT(N)
	    YPHASE(N) = SPHASE(N)
	    SPSUSE = .001*SPS
	    PP(N) = N*SPSUSE/2048.
            DPHASE(N) = AMOD(XPHASE(N)-YPHASE(N)+540.,360.) - 180.
C	    IF(LEVEL.GE.1) THEN
C	      WRITE(68,*) PP(N),XSPECT(N),YSPECT(N),XSPECT(N)-YSPECT(N)
C     1        ,DPHASE(N)
c	      write(71,*) n,xspect(n),yspect(n),dphase(n)
c	      write(72,*) n,xspect(n),yspect(n),dphase(n)
C	    ENDIF
	  ENDDO
	ENDIF
C	close(unit=71)
	IF(LEVEL.GE.1) close(unit=72)
c	if(CH.ne.TDSCH) go to 110
C*******************
C
C	FIND ZERO CROSSING
C
	IZCNT = 0
	IL = 1
	IZ = IL
	  IF(NDATA(IL).EQ.0) PRINT*,'ZERO DATA',IL,NDATA(IL),NDATA(IL+1)
	DO IL = 2,2047
	  IZ = IL
	  IF(NDATA(IL).EQ.0) PRINT*,'ZERO DATA',IL,NDATA(IL-1),
     1   NDATA(IL),NDATA(IL+1)
c
C		COUNT ONLY POS TO NEG
	  IF(NDATA(IL).GT.0.AND.NDATA(IL+1).LE.0) THEN
	        IZCNT = IZCNT+1
		IF(IPROCESS.EQ.0) THEN
		  S1 = NDATA(IL)
		  S2 = NDATA(IL+1)
		ELSE
		  S1 = DATA(IL)
		  S2 = DATA(IL+1)
		ENDIF
		ZCROSS(IZCNT) = IL + S1/(S1 - S2)
	  ENDIF
	ENDDO
	DO N = 1,IZCNT-1
	  ZINT(N) = ZCROSS(N+1) - ZCROSS(N)
	  IF(ZINT(N).EQ.0.) PRINT*,'ZINT=0 AT ',N
	  IF(ZINT(N).EQ.0.) ZINT(N) = 1.E-6
	ENDDO
	print*,'zero crossings found',izcnt
	print*,'first 5',(zcross(kk),kk=1,5)
C
 20	CONTINUE
C
 1003	FORMAT(3(I9,E11.3,I5))
C
	IF(LEVEL.GE.2) THEN
C  	  CALL PLTDSFR(-2)
	  CALL PLOTPART(3)
c	  CALL PARTSPEC(CH,1,2048,4,DATA)
c	  IF(IPROCESS.LE.1) CALL DETAIL(-2,900,1100)
C	  CALL DETAIL(-2,900,1100)
c	  CALL DETAIL(-2,400,600)
c	  CALL DETAIL(-2,1200,1400)
	ENDIF
	IF(NPLOTS.LT.NREM) GO TO 110
	close(unit=71)
	STOP
	END
	SUBROUTINE PLTDSFR(ITERM)
C
C	PLOT TDS DATA AND FREQUENCY = .5/(INTERVAL BETWEEN ZEROS)
C
	CHARACTER*12 TITLE(20)
	CHARACTER*120 STR
	CHARACTER*4 EVENT
	character*80	file
	COMMON /HEADBL/ TITLE,EVENT,NUMEVENT,FILE
	COMMON /PLTBLK/ IZCNT,IPROCESS,ZCROSS(2048),ZINT(2048),
     1   NDATA(2048),DATA(2050),SPECT(1025)
	COMMON /TDS_STATUS/ TDS_CHANNEL,SPS,FILTER,IRX,ISPS
	COMMON /STATUS/ FFILTER(4),SFILTER(4),FSPS(4),SSPS(4)
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 YY(2048),PP(2048)
C
	CALL MGOINIT
	CALL MGOSETUP(ITERM)
	CALL MGOERASE
C
C	PLOT TDS DATA
C
	XEND = 2750.
	IF(ITERM.LT.0) THEN
	  CALL MGOSETLOC(300.,1100.,XEND,2230.)
	ENDIF
C
	  CALL MGOSETEXPAND(.85)
	  IF(ITERM.GT.0) THEN
	    CALL MGOGRELOCATE(10.,0.)                      ! maxch, crt
	  ELSE
	    CALL MGOGRELOCATE(400.,50.)                      ! hardcopy
	  ENDIF
C	  CALL MGOPUTLABEL(53,STR,9)
	  CALL MGOSETEXPAND(1.)
C
	IF(IPROCESS.EQ.0) THEN
	  DO N = 1,2048
  	    PP(N) = N
	    YY(N) = NDATA(N)
	  ENDDO
	ELSE
	  YMAX = 0.
	  DO N = 1,2048
  	    PP(N) = N
	    YY(N) = DATA(N)
	    YMAX = AMAX1(YY(N),YMAX)
	    YMAX = AMAX1(-YY(N),YMAX)
	  ENDDO
	ENDIF
C
	PRINT*,'MAX VOLTS',YMAX
	IF(IPROCESS.EQ.0) THEN
		CALL MGOTICKSIZE(0.,0.,5.6,28.)
		CALL MGOSETLIM(-2.,-130.,2050.,130.)
	ELSE
		CALL MGOTICKSIZE(0.,0.,0.,0.)
		CALL MGOSETLIM(-2.,-YMAX,2050.,YMAX)
	ENDIF
c	CALL MGOGRID(0)
C	CALL MGOSETLTYPE(1)
c	CALL MGOGRID(1)
	CALL MGOSETLTYPE(0)
	CALL MGOSETEXPAND(.6)
	CALL MGOCONNECT(PP,YY,2048)
	CALL MGOSETEXPAND(.8)
	CALL MGOBOX(0,2)
	IF(IPROCESS.EQ.0) THEN
		CALL MGOYLABEL(14,'T/M NUMBER-128')
	ELSE
		CALL MGOYLABEL(14,'VOLTS or nT')
	ENDIF
	CALL MGOSETEXPAND(1.)
	TRANGE = GY2-GY1
	TINC = .08*TRANGE
	XTITLE = GX2 +.005*(GX2-GX1)
	YTITLE = GY2
	CALL MGOSETEXPAND(.8)
	AVRFREQ=0.
	IF(IZCNT.GT.1) THEN
	  AVRPER = (ZCROSS(IZCNT)-ZCROSS(1))/(IZCNT-1)
	  AVRFREQ = .001*SPS/AVRPER
	ENDIF
	TITLE(19) = 'AVR.FREQ.'
	WRITE(TITLE(20),1020) AVRFREQ
 1020	FORMAT(F8.2,' kHZ')
	DO N = 1,20
	  YTITLE = YTITLE - TINC
	  IF(N.EQ.4) YTITLE = YTITLE - TINC
	  IF(N.EQ.6) YTITLE = YTITLE - TINC
	  CALL MGOGRELOCATE(XTITLE,YTITLE)
	  CALL MGOLABEL(12,TITLE(N))
	ENDDO
	CALL MGOSETEXPAND(1.)
	CALL MGOSETEXPAND(.8)
	CALL MGOPLOTID(EVENT,'[.WIND]TDSEXEY')
	CALL MGOSETEXPAND(1.)
C
C	PLOT FREQUENCY = .5/(INTERVAL BETWEEN ZEROS)
C		OR 1./INT FOR POS TO NEG
C
	IF(ITERM.LT.0) THEN
	  CALL MGOSETLOC(300.,200.,XEND,1050.)
	ENDIF
	SPSKHZ = .001*SPS
	YMIN = .5*SPSKHZ
	YMAX = 0.
	PRINT*,'IZCNT',IZCNT
	DO N = 1,IZCNT-1
	IF(ZINT(N).EQ.0.) PRINT*,'IN PLOT, ZINT=0 AT',N
C	  YY(N) = .5*SPSKHZ/ZINT(N)
	  YY(N) = SPSKHZ/ZINT(N)
	  PP(N) = .5*(ZCROSS(N)+ZCROSS(N+1))
	  YMIN = AMIN1(YY(N),YMIN)
	  YMAX = AMAX1(YY(N),YMAX)
	ENDDO
  	YMAX = AMIN1(.5*SPSKHZ,1.1*YMAX)
	PRINT*,'YMIN,YMAX',YMIN,YMAX
	CALL MGOSETEXPAND(.8)
	CALL MGOSETLIM(-2.,YMIN,2050.,YMAX)
	CALL MGOTICKSIZE(0.,0.,0.,0.)
	CALL MGOCONNECT(PP,YY,IZCNT-1)
	CALL MGOBOX(1,2)
	CALL MGOXLABEL(10,'SAMPLE NO.')
	CALL MGOYLABEL(10,'FREQ (kHZ)')
	CALL MGOSETEXPAND(1.)
C
	IF(ITERM.LT.0) THEN
	  CALL MGOPRNTPLOT(NVEC)
	  PRINT*,' NO. VECTORS PLOTTED',NVEC
	ELSE
	  CALL MGOTCLOSE
	ENDIF
C
	RETURN
C
	END
	SUBROUTINE COMBO(ITERM)
C
C	THE FIRST (TOP) PANEL IS THE DATA IN T/M UNITS,
C	THE SECOND IS IN PHYSICAL UNITS, THE THIRD IS THE FREQ  FROM
C	ZERO CROSSINGS, AND THE FOURTH IS THE FOURIER TRANSFORM
C
	CHARACTER*12 TITLE(20)
	CHARACTER*120 STR
	CHARACTER*4 EVENT
	character*80	file
	INTEGER*4 TDS_CHANNEL,S_SCET(2)
	COMMON /HEADBL/ TITLE,EVENT,NUMEVENT,FILE
	COMMON /FIXUPBLK/ ISTART
	common /headblk/ major,minor,s_scet
	COMMON /PLTBLK/ IZCNT,IPROCESS,ZCROSS(2048),ZINT(2048),
     1   NDATA(2048),DATA(2050),SPECT(1025)
	COMMON /TDS_STATUS/ TDS_CHANNEL,SPS,FILTER,IRX,ISPS
	COMMON /STATUS/ FFILTER(4),SFILTER(4),FSPS(4),SSPS(4)
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 YY(2048),YYT(2048),PP(2048)
C
	CALL MGOINIT
	CALL MGOSETUP(ITERM)
	CALL MGOERASE
C
C	PUT LABELS ON RIGHT HAND SIDE
C
	XSTART = 350.
	XEND = 2000.
	IF(ITERM.LT.0) THEN
	  CALL MGOSETLOC(XSTART,400.,XEND,3100.)
	ENDIF
	AVRFREQ=0.
	IF(IZCNT.GT.1) THEN
	  AVRPER = (ZCROSS(IZCNT)-ZCROSS(1))/(IZCNT-1)
	  AVRFREQ = .001*SPS/AVRPER
	ENDIF
	TITLE(19) = ' AVR.FREQ.'
	WRITE(TITLE(20),1020) AVRFREQ
 1020	FORMAT(F8.2,' kHZ')
C
C	XTITLE = GX2 +.006*(GX2-GX1)
	XTITLE = GX2 +.02*(GX2-GX1)
	YTITLE = GY2
	TRANGE = GY2-GY1
	TINC = .03*TRANGE
	CALL MGOSETEXPAND(.8)
	DO N = 1,20
	  YTITLE = YTITLE - TINC
	  IF(N.EQ.4) YTITLE = YTITLE - TINC
	  IF(N.EQ.6) YTITLE = YTITLE - TINC
	  IF(N.EQ.19) YTITLE = YTITLE - TINC
	  CALL MGOGRELOCATE(XTITLE,YTITLE)
	  CALL MGOLABEL(12,TITLE(N))
	ENDDO
C
C	PLOT TDS DATA IN TELEMETRY UNITS
C
	IF(ITERM.LT.0) THEN
	  CALL MGOSETLOC(XSTART,2425.,XEND,3100.)
	ENDIF
C
	  CALL MGOSETEXPAND(.85)
	  IF(ITERM.GT.0) THEN
	    CALL MGOGRELOCATE(10.,0.)                      ! maxch, crt
	  ELSE
	    CALL MGOGRELOCATE(400.,50.)                      ! hardcopy
	  ENDIF
C	  CALL MGOPUTLABEL(53,STR,9)
	  CALL MGOSETEXPAND(1.)
C
	  DO N = 1,2048
  	    PP(N) = 1000.*(N-1)/SPS
	    YY(N) = NDATA(N)
	  ENDDO
	CALL MGOSETLIM(0.,-128.,PP(2048),128.)
	CALL MGOSETEXPAND(.8)
	CALL MGOTICKSIZE(0.,0.,0.,0.)
	CALL MGOCONNECT(PP,YY,2048)
	CALL MGOBOX(1,2)
	CALL MGOSETEXPAND(.7)
	CALL MGOXLABEL(5,'mSEC.')
	CALL MGOYLABEL(14,'T/M NUMBER-128')
	CALL MGOSETEXPAND(.8)
	CALL MGOPLOTID(EVENT,'[.WIND]TDSEXEY,COMBO')
	CALL MGOSETEXPAND(1.)
C
C	PLOT TDS DATA IN PHYSICAL UNITS
C
	IF(ITERM.LT.0) THEN
	  CALL MGOSETLOC(XSTART,1605.,XEND,2275.)
	ENDIF
	  YMAX = 0.
c	  EFFLEN = 45.				  ! X ANTENNA  18-JUL-95
c	  IF(IRX.EQ.2.OR.IRX.EQ.5) EFFLEN = 6.    ! Y ANTENNA   "
c	  IF(IRX.EQ.3.OR.IRX.EQ.6) EFFLEN = 4.    ! Z ANTENNA   "
	  EFFLEN = 41.1				  ! X ANTENNA  23-SEP-96
	  IF(IRX.EQ.2.OR.IRX.EQ.5) EFFLEN = 3.79  ! Y ANTENNA   "
	  IF(IRX.EQ.3.OR.IRX.EQ.6) EFFLEN = 2.17  ! Z ANTENNA   "
	  ACORR = 1000.
	  IF(IRX.GE.7) THEN			! SEARCH COILS
		ACORR=1.
		EFFLEN = 1.
	  ENDIF
C	CHANGE TO mV/meter
	  DO N = 1,2048
C 	    PP(N) = N
	    YY(N) = ACORR*DATA(N)/EFFLEN
	    YMAX = AMAX1(YY(N),YMAX)
	    YMAX = AMAX1(-YY(N),YMAX)
	  ENDDO
C
	PRINT*,'MAX mV/m',YMAX
	CALL MGOTICKSIZE(0.,0.,0.,0.)
	CALL MGOSETLIM(PP(1),-YMAX,PP(2048),YMAX)
C
c	CALL MGOGRID(0)
C	CALL MGOSETLTYPE(1)
c	CALL MGOGRID(1)
	CALL MGOSETLTYPE(0)
	CALL MGOSETEXPAND(.6)
	CALL MGOCONNECT(PP,YY,2048)
	CALL MGOSETEXPAND(.7)
	CALL MGOBOX(1,2)
	CALL MGOXLABEL(5,'mSEC.')
	CALL MGOYLABEL(10,'mV/m or nT')
	CALL MGOSETEXPAND(1.)
C
C	PLOT FREQUENCY FROM ZERO CROSSINGS, ALSO SMOOTH FREQUENCY
C
	IF(ITERM.LT.0) THEN
	  CALL MGOSETLOC(XSTART,1120.,XEND,1455.)
	ENDIF

C
	SPSKHZ = .001*SPS
	YMIN = .5*SPSKHZ
	YMAX = 0.
	PRINT*,'IZCNT',IZCNT
	IF(IZCNT.GT.1) THEN
	  DO N = 1,IZCNT-1
	    IF(ZINT(N).EQ.0.) PRINT*,'IN PLOT, ZINT=0 AT',N
	    YY(N) = SPSKHZ/ZINT(N)
C 	      PP(N) = 1000.*(N-1)/SPS
	    PP(N) = 500.*(ZCROSS(N)+ZCROSS(N+1))/SPS
	    YMIN = AMIN1(YY(N),YMIN)
	    YMAX = AMAX1(YY(N),YMAX)
	  ENDDO
C
C	  SMOOTH FREQUENCY
C
	  DO N = 2,IZCNT-2
	    YYT(N) = .4*YY(N) + .3*(YY(N+1)+YY(N-1))
c*******
c	   if(pp(n).lt.32.) yyt(n) = 0.
c	   if(pp(n).gt.35.) yyt(n) = 0.
	  ENDDO
	  YYT(1) = YY(1)
	  YYT(IZCNT-1) = YY(IZCNT-1)
	ENDIF
C
  	YMAX = AMIN1(.5*SPSKHZ,1.1*YMAX)
	PRINT*,'YMIN,YMAX',YMIN,YMAX
	YMIN =  .9*AVRFREQ
	YMAX = 1.1*AVRFREQ
c	ymin = 8.
c	ymax = 17.
	YMIN =  .5*AVRFREQ
	YMAX = 2.*AVRFREQ
	PRINT*,'SET TO   ',YMIN,YMAX
	CALL MGOSETEXPAND(.8)
	CALL MGOSETLIM(0.,YMIN,PP(2048),YMAX)
	CALL MGOTICKSIZE(0.,0.,0.,0.)
c	CALL MGOCONNECT(PP,YYT,IZCNT-1)
	CALL MGOCONNECT(PP,YYT,IZCNT-1)
	CALL MGOBOX(1,2)
	CALL MGOSETEXPAND(.7)
	CALL MGOXLABEL(5,'mSEC.')
	CALL MGOYLABEL(10,'FREQ (kHZ)')
	CALL MGOSETEXPAND(1.)
C
C	PLOT FOURIER SPECTRUM
C
	IF(ITERM.LT.0) THEN
	  CALL MGOSETLOC(XSTART,300.,XEND,970.)
	ENDIF
C
C
	N1 = 3
	N2 = 2048
	YMAX = -500.
	YMIN =  500.
	XMAX = 0.
	SPSUSE = SPS
	IF(TDS_CHANNEL.LE.2) SPSUSE = .001*SPS
	DO N = N1,N2,2
	  NP = (N-1)/2
	  PP(NP) = NP*SPSUSE/2048.
C	  YY(NP) = 10.*ALOG10(DATA(N)**2 + DATA(N+1)**2)
	  YY(NP) = SPECT(NP)
	  XMAX = AMAX1(XMAX,PP(NP))
	  IF(YY(NP).GT.YMAX) THEN
	    NPSV = NP
	    YMAX = YY(NP)
	  ENDIF
	  YMIN = AMIN1(YMIN,YY(NP))
	ENDDO
C
C	CALCULATE 10 DB BANDWIDTH
C
	MAXCOUNT = 0
	LOWCOUNT = 0
	DO N=NPSV,1024
	   IF(SPECT(N).GT.(YMAX-10.)) THEN
		MAXCOUNT = MAXCOUNT+LOWCOUNT+1
		LOWCOUNT = 0
	   ELSE
		LOWCOUNT = LOWCOUNT+1
	   ENDIF
	   IF(LOWCOUNT.GT.3) GO TO 410
	ENDDO
C 410	MAXCOUNT = MAXCOUNT + LOWCOUNT
 410	CONTINUE
	LOWCOUNT = 0
	DO N=NPSV-1,1,-1
	   IF(SPECT(N).GT.(YMAX-10.)) THEN
		MAXCOUNT = MAXCOUNT+LOWCOUNT+1
		LOWCOUNT = 0
	   ELSE
		LOWCOUNT = LOWCOUNT+1
	   ENDIF
	   IF(LOWCOUNT.GT.3) GO TO 420
	ENDDO
 420	PRINT*,'DB,YMAX,YMIN',YMAX,YMIN
	BW = MAXCOUNT*SPSUSE/2048.
	PRINT*,'MAXCOUNT, BANDWIDTH',MAXCOUNT,BW
	XN1 = N1-2
	XN2 = N2+2
	YRANGE = YMAX-YMIN
	YMAX = YMAX + .05*YRANGE
	YMIN = YMIN - .05*YRANGE
	YMIN = AMAX1(YMIN,YMAX-70.)
	CALL MGOSETLIM(0.,YMIN,XMAX,YMAX)
c	CALL MGOGRID(0)
C	CALL MGOSETLTYPE(1)
c	CALL MGOGRID(1)
	CALL MGOSETLTYPE(0)
	CALL MGOSETEXPAND(.6)
	CALL MGOCONNECT(PP,YY,NP)
C	CALL MGOPOINTS(60.,1,PP,YY,NP)
	CALL MGOSETEXPAND(.7)
	CALL MGOBOX(1,2)
	CALL MGOYLABEL(17,'POWER, DB V\u2/HZ')
	IF(TDS_CHANNEL.GT.2) CALL MGOXLABEL(9,'FREQ, HZ')
	IF(TDS_CHANNEL.LE.2) CALL MGOXLABEL(9,'FREQ, kHZ')
	YTITLE = GY2
	TRANGE = GY2-GY1
	TINC = .1*TRANGE
	YTITLE = YTITLE-TINC
	CALL MGOGRELOCATE(XTITLE,YTITLE)
	CALL MGOLABEL(10,'   10 dB  ')
	YTITLE = YTITLE-TINC
	CALL MGOGRELOCATE(XTITLE,YTITLE)
	CALL MGOLABEL(10,' BANDWIDTH')
	YTITLE = YTITLE-TINC
	CALL MGOGRELOCATE(XTITLE,YTITLE)
	CALL MGOLABEL(10,'  OF PEAK ')
	IF(TDS_CHANNEL.GT.2) WRITE(STR,1021) .001*BW
	IF(TDS_CHANNEL.LE.2) WRITE(STR,1022) BW
 1021	FORMAT(F7.2,' HZ')
 1022	FORMAT(F6.3,' kHZ')
	YTITLE = YTITLE - TINC
	CALL MGOGRELOCATE(XTITLE,YTITLE)
	CALL MGOLABEL(10,STR)
	CALL MGOSETEXPAND(1.)
C
C
	IF(IPROCESS.GE.3) THEN
	  YTITLE = YTITLE-2.*TINC
	  CALL MGOSETEXPAND(.5)
	  CALL MGOGRELOCATE(XTITLE,YTITLE)
	  CALL MGOLABEL(8,' BAD TDS')
	  YTITLE = YTITLE-TINC
	  CALL MGOGRELOCATE(XTITLE,YTITLE)
	  CALL MGOLABEL(9,'CORRECTED')
	  YTITLE = YTITLE-TINC
	  CALL MGOGRELOCATE(XTITLE,YTITLE)
	  WRITE(STR,1024) IPROCESS
 1024	  FORMAT(' LEVEL',I2)
	  CALL MGOLABEL(8,STR)
	  WRITE(STR,1025) ISTART
 1025	  FORMAT(I5,' PTS')
	  YTITLE = YTITLE-TINC
	  CALL MGOGRELOCATE(XTITLE,YTITLE)
	  CALL MGOLABEL(9,STR)
	  CALL MGOSETEXPAND(.8)
	ENDIF
C
	IF(ITERM.LT.0) THEN
	  CALL MGOPRNTPLOT(NVEC)
	  PRINT*,' NO. VECTORS PLOTTED',NVEC
	ELSE
	  CALL MGOTCLOSE
	ENDIF
C
	RETURN
C
	END
	SUBROUTINE DETAIL(ITERM,N1,N2)
C
C	PLOT TDS DATA AND FREQUENCY = .5/(INTERVAL BETWEEN ZEROS)
C
	CHARACTER*12 TITLE(20)
	CHARACTER*120 STR
	CHARACTER*4 EVENT
	character*80	file
	COMMON /HEADBL/ TITLE,EVENT,NUMEVENT,FILE
	COMMON /PLTBLK/ IZCNT,IPROCESS,ZCROSS(2048),ZINT(2048),
     1   NDATA(2048),DATA(2050),SPECT(1025)
	COMMON /TDS_STATUS/ TDS_CHANNEL,SPS,FILTER,IRX,ISPS
	COMMON /STATUS/ FFILTER(4),SFILTER(4),FSPS(4),SSPS(4)
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 YY(2048),PP(2048)
C
	CALL MGOINIT
	CALL MGOSETUP(ITERM)
	CALL MGOERASE
C
C	PLOT TDS DATA
C
	XEND = 2750.
	IF(ITERM.LT.0) THEN
	  CALL MGOSETLOC(300.,400.,XEND,2230.)
	ENDIF
C
	  CALL MGOSETEXPAND(.85)
	  IF(ITERM.GT.0) THEN
	    CALL MGOGRELOCATE(10.,0.)                      ! maxch, crt
	  ELSE
	    CALL MGOGRELOCATE(400.,50.)                      ! hardcopy
	  ENDIF
C	  CALL MGOPUTLABEL(53,STR,9)
c	  WRITE(STR,704) SAA()
c 704	  FORMAT('\\tSOLAR ASPECT',F6.1,' DEG.')
c	  CALL MGOPUTLABEL(55,STR,9)
	  CALL MGOSETEXPAND(1.)
C
	DO N = N1,N2
	  NP = N
	  PP(N) = N
	  YY(N) = NDATA(N)
	ENDDO
C
	CALL MGOTICKSIZE(0.,0.,5.6,28.)
	XN1 = N1-2
	XN2 = N2+2
	CALL MGOSETLIM(XN1,-130.,XN2,130.)
c	CALL MGOGRID(0)
C	CALL MGOSETLTYPE(1)
c	CALL MGOGRID(1)
	CALL MGOSETLTYPE(0)
	CALL MGOSETEXPAND(.6)
	CALL MGOCONNECT(PP,YY,NP)
	CALL MGOPOINTS(60.,1,PP,YY,NP)
	CALL MGOSETEXPAND(.8)
	  CALL MGOBOX(1,2)
	  CALL MGOYLABEL(14,'T/M NUMBER-128')
	  CALL MGOSETEXPAND(1.)
	TRANGE = GY2-GY1
	TINC = .04*TRANGE
	XTITLE = GX2 +.005*(GX2-GX1)
	YTITLE = GY2
	CALL MGOSETEXPAND(.8)
	AVRFREQ=0.
	IF(IZCNT.GT.1) THEN
	  AVRPER = (ZCROSS(IZCNT)-ZCROSS(1))/(IZCNT-1)
	  AVRFREQ = .001*SPS/AVRPER
	ENDIF
	TITLE(19) = 'AVR.FREQ.'
	WRITE(TITLE(20),1020) AVRFREQ
 1020	FORMAT(F8.2,' kHZ')
	DO N = 1,20
	  YTITLE = YTITLE - TINC
	  IF(N.EQ.4) YTITLE = YTITLE - TINC
	  IF(N.EQ.6) YTITLE = YTITLE - TINC
	  CALL MGOGRELOCATE(XTITLE,YTITLE)
	  CALL MGOLABEL(12,TITLE(N))
	ENDDO
	CALL MGOSETEXPAND(1.)
	CALL MGOSETEXPAND(.8)
	CALL MGOPLOTID(EVENT,'[.WIND]TDSEXEY')
	CALL MGOSETEXPAND(1.)
C
	IF(ITERM.LT.0) THEN
	  CALL MGOPRNTPLOT(NVEC)
	  PRINT*,' NO. VECTORS PLOTTED',NVEC
	ELSE
	  CALL MGOTCLOSE
	ENDIF
C
	RETURN
C
	END
	SUBROUTINE PARTSPEC(CH,NSTART,NVAR,NSPECT,DATA)
C
C	THIS ROUTINE DOES FOURIER ANALYSIS ON PART OF AN EVENT.
C	NSTART IS THE SAMPLE NUMBER OF THE FIRST SAMPLE, NVAR IS THE
C	NUMBER OF SAMPLES TO BE FOURIER ANALYSED.  NVAR MUST BE A POWER
C	OF TWO.  DATA IS THE DATA FROM THE EVENT, USUALLY CORRECTED FOR
C	FREQUENCY RESPONSE, ETC.
C
	COMMON /TDS_STATUS/ TDS_CHANNEL,SPS,FILTER,IRX,ISPS
	COMMON /GAINBLK/ PHASE,CGAIN                   ! PHASE IS IN RADIANS
	COMMON /HEADBL/ TITLE,EVENT,NUMEVENT,FILE
	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
	character*80	file
	CHARACTER*4 EVENT
C
	COMPLEX CGAIN,FCOEF,FCOEFT,CCORR
	character*32	item
	REAL DATA(2050),SPECT(2050),PDATA(2050)
	INTEGER CH
	CHARACTER*12 TITLE(20)
	CHARACTER*20 STR
	DIMENSION YY(2048),PP(2048)
C
	ITERM = -1
C	ITERM = 3
	CALL MGOINIT
	CALL MGOSETUP(ITERM)
	CALL MGOERASE
	IF(ITERM.LT.0) THEN
	  IF(NSPECT.EQ.1) CALL MGOSETLOC(500.,1300.,2000.,2200.)
	  IF(NSPECT.EQ.2) CALL MGOSETLOC(500.,850.,2000.,2650.)
	  IF(NSPECT.GT.2) CALL MGOSETLOC(500.,400.,2000.,3100.)
	ELSE
	  CALL MGOSETLOC(75.,150.,900.,700.)
	ENDIF
	TRANGE = GY2-GY1
	TINC = .04*TRANGE
	XTITLE = GX2 +.03*(GX2-GX1)
	YTITLE = GY2
	CALL MGOSETEXPAND(.8)
	AVRFREQ=0.
C	IF(IZCNT.GT.1) THEN
C	  AVRPER = (ZCROSS(IZCNT)-ZCROSS(1))/(IZCNT-1)
C	  AVRFREQ = .001*SPS/AVRPER
C	ENDIF
	TITLE(19) = 'AVR.FREQ.'
	WRITE(TITLE(20),1020) AVRFREQ
 1020	FORMAT(F8.2,' kHZ')
C
	DO N = 1,20
	  YTITLE = YTITLE - TINC
	  IF(N.EQ.4) YTITLE = YTITLE - TINC
	  IF(N.EQ.6) YTITLE = YTITLE - TINC
	  CALL MGOGRELOCATE(XTITLE,YTITLE)
	  CALL MGOLABEL(12,TITLE(N))
	ENDDO
	CALL MGOSETEXPAND(1.)
	CALL MGOSETEXPAND(.8)
	YTITLE = GY1 + .3*(GY2-GY1)
	CALL MGOGRELOCATE(GX1,YTITLE)
	CALL MGOSETANGLE(90.)
	CALL MGOLABEL(17,'POWER, DB V\u2/HZ')
	CALL MGOSETANGLE(0.)
C
	NHALF = NVAR/2
	HALF = NHALF
	DO NS = 1,NSPECT
	  NSTT = NSTART + (NS-1)*NVAR
	  NP = 0
	  DO N = NSTT, NSTT+NVAR-1
	    NP = NP+1
	    PDATA(NP) = DATA(N)
  	  ENDDO
	  CALL REALFT(PDATA,NHALF,1)
C
C	  CORRECT FOURIER ANALYSED SIGNAL FOR FREQUENCY RESPONSE
C
	  IF(TDS_CHANNEL.GT.2) THEN
	   item = 'SLOW_RX_FILTER'
	  ELSE
	   item = 'FAST_RX_FILTER'
	  ENDIF
	   ok = W_ITEM_i4(ch, item, ifil, 1, return_size)
C
	     DO IK = 3,NVAR,2
		FCOEF = CMPLX(PDATA(IK),PDATA(IK+1))
	        FREQ = SPS*(IK-1)/4096.
	        EJUNK = PREAMP(IRX,FREQ)
		FCOEFT = FCOEF/CGAIN
		CCORR = CGAIN
		EJUNK = TDSDET(TDS_CHANNEL,FREQ)
		FCOEFT = FCOEFT/CGAIN
		CCORR = CGAIN*CCORR
		EJUNK = TDS_FILTER(TDS_CHANNEL,IFIL+1,FREQ)
		FCOEFT = FCOEFT/CGAIN
		CCORR = CGAIN*CCORR
		FCOEF = FCOEFT
		PDATA(IK) = FCOEF
		PDATA(IK+1) = AIMAG(FCOEF)
	     ENDDO
C
C	  NOW PDATA CONTAINS FOURIER COEFFS CORRECTED FOR FREQUENCY RESPONSE
C
C	  CALCULATE SPECTRUM, IN DB WRT 1 V**2/HZ
C
	  SNORM = 20.*ALOG10(HALF)
	  IK = 1
	  ISP = 1
	  SPECT(ISP) = -SNORM
	  IF(PDATA(IK).NE.0.)SPECT(ISP) = 20.*ALOG10(ABS(PDATA(IK)))-SNORM
	  DO IK = 3,NVAR,2
	      ISP = ISP+1
	      SPECT(ISP) = 10.*ALOG10(PDATA(IK)**2 + PDATA(IK+1)**2)-SNORM
	  ENDDO
C
C
C	  PLOT FOURIER SPECTRUM
C
	  CALL MGOWINDOW(1,NSPECT,NS)
C
C
	  N1 = 3
	  N2 = NVAR
	  YMAX = -500.
	  YMIN =  500.
	  XMAX = 0.
	  SPSUSE = SPS
	  IF(TDS_CHANNEL.LE.2) SPSUSE = .001*SPS
	  DO N = N1,N2,2
	    NP = (N-1)/2
	    PP(NP) = NP*SPSUSE/NVAR
	    YY(NP) = SPECT(NP)
	    XMAX = AMAX1(XMAX,PP(NP))
	    IF(YY(NP).GT.YMAX) THEN
	      NPSV = NP
	      YMAX = YY(NP)
	    ENDIF
	    YMIN = AMIN1(YMIN,YY(NP))
	  ENDDO
C
	  XN1 = N1-2
	  XN2 = N2+2
	  YRANGE = YMAX-YMIN
	  YMAX = YMAX + .05*YRANGE
	  YMIN = YMIN - .05*YRANGE
	  YMIN = AMAX1(YMIN,YMAX-80.)
	  PRINT*,'SET YLIMITS',YMIN,YMAX
	  CALL MGOSETLIM(0.,YMIN,XMAX,YMAX)
c	  CALL MGOGRID(0)
C	  CALL MGOSETLTYPE(1)
c	  CALL MGOGRID(1)
	  CALL MGOSETLTYPE(0)
C	  CALL MGOSETEXPAND(.6)
	  CALL MGOCONNECT(PP,YY,NP)
C	  CALL MGOPOINTS(60.,1,PP,YY,NP)
	  CALL MGOSETEXPAND(.7)
	  CALL MGOBOX(1,2)
	WRITE(STR,1017)  NSTT, NSTT+NVAR-1
 1017	  FORMAT('SAMPLES',I5,' TO',I5)
	  CALL MGOYLABEL(20,STR)
	  IF(TDS_CHANNEL.GT.2) CALL MGOXLABEL(9,'FREQ, HZ')
	  IF(TDS_CHANNEL.LE.2) CALL MGOXLABEL(9,'FREQ, kHZ')
C	  YTITLE = GY2
C	  TRANGE = GY2-GY1
C	  TINC = .1*TRANGE
C	  YTITLE = YTITLE-TINC
C	  CALL MGOGRELOCATE(XTITLE,YTITLE)
C	  CALL MGOLABEL(10,'   10 dB  ')
C
	ENDDO
C
	CALL MGOPLOTID('PARTSPEC','[.WIND]TDSEXEY')
	CALL MGOSETEXPAND(1.)
C
	IF(ITERM.LT.0) THEN
	  CALL MGOPRNTPLOT(NVEC)
	  PRINT*,' NO. VECTORS PLOTTED',NVEC
	ELSE
	  CALL MGOTCLOSE
	  STOP
	ENDIF
C
	RETURN
	END
	SUBROUTINE SPPLOT(ITERM)
C
C	PLOT TDS DATA AND FREQUENCY = .5/(INTERVAL BETWEEN ZEROS)
C
	CHARACTER*12 TITLE(20)
	CHARACTER*120 STR
	CHARACTER*4 EVENT
	character*80	file
	COMMON /HEADBL/ TITLE,EVENT,NUMEVENT,FILE
	COMMON /PLTBLK/ IZCNT,IPROCESS,ZCROSS(2048),ZINT(2048),
     1   NDATA(2048),DATA(2050),SPECT(1025)
	COMMON /TDS_STATUS/ TDS_CHANNEL,SPS,FILTER,IRX,ISPS
	COMMON /STATUS/ FFILTER(4),SFILTER(4),FSPS(4),SSPS(4)
	common /headblk/ major,minor,s_scet
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 YY(2048),PP(2048)
C
	CALL MGOINIT
	CALL MGOSETUP(ITERM)
	CALL MGOERASE
C
C	PLOT TDS DATA
C
	XEND = 2750.
	IF(ITERM.LT.0) THEN
	  CALL MGOSETLOC(300.,400.,XEND,2230.)
	ENDIF
C
	  CALL MGOSETEXPAND(.85)
	  IF(ITERM.GT.0) THEN
	    CALL MGOGRELOCATE(10.,0.)                      ! maxch, crt
	  ELSE
	    CALL MGOGRELOCATE(400.,50.)                      ! hardcopy
	  ENDIF
C
	  CALL MGOSETEXPAND(1.)
C
	N1 = 3
	N2 = 2048
	YMAX = -500.
	YMIN =  500.
	XMAX = 0.
	SPSUSE = SPS
	IF(TDS_CHANNEL.LE.2) SPSUSE = .001*SPS
	DO N = N1,N2,2
	  NP = (N-1)/2
	  PP(NP) = NP*SPSUSE/2048.
	  YY(NP) = 10.*ALOG10(DATA(N)**2 + DATA(N+1)**2)
	  XMAX = AMAX1(XMAX,PP(NP))
	  YMAX = AMAX1(YMAX,YY(NP))
	  YMIN = AMIN1(YMIN,YY(NP))
	ENDDO
C
	PRINT*,'YMAX,YMIN',YMAX,YMIN
C	CALL MGOTICKSIZE(10.,10.,5.6,28.)
	XN1 = N1-2
	XN2 = N2+2
	YRANGE = YMAX-YMIN
	YMAX = YMAX + .05*YRANGE
	YMIN = YMIN - .05*YRANGE
	CALL MGOSETLIM(0.,YMIN,XMAX,YMAX)
c	CALL MGOGRID(0)
C	CALL MGOSETLTYPE(1)
c	CALL MGOGRID(1)
	CALL MGOSETLTYPE(0)
	CALL MGOSETEXPAND(.6)
	CALL MGOCONNECT(PP,YY,NP)
	CALL MGOPOINTS(60.,1,PP,YY,NP)
	CALL MGOSETEXPAND(.8)
	CALL MGOBOX(1,2)
	CALL MGOYLABEL(14,'POWER, DB')
	IF(TDS_CHANNEL.GT.2) CALL MGOXLABEL(9,'FREQ, HZ')
	IF(TDS_CHANNEL.LE.2) CALL MGOXLABEL(9,'FREQ, kHZ')
	CALL MGOSETEXPAND(1.)
	TRANGE = GY2-GY1
	TINC = .04*TRANGE
	XTITLE = GX2 +.005*(GX2-GX1)
	YTITLE = GY2
	CALL MGOSETEXPAND(.8)
	AVRFREQ=0.
	IF(IZCNT.GT.1) THEN
	  AVRPER = (ZCROSS(IZCNT)-ZCROSS(1))/(IZCNT-1)
	  AVRFREQ = .001*SPS/AVRPER
	ENDIF
	TITLE(19) = 'AVR.FREQ.'
	WRITE(TITLE(20),1020) AVRFREQ
 1020	FORMAT(F8.2,' kHZ')
	DO N = 1,20
	  YTITLE = YTITLE - TINC
	  IF(N.EQ.4) YTITLE = YTITLE - TINC
	  IF(N.EQ.6) YTITLE = YTITLE - TINC
	  CALL MGOGRELOCATE(XTITLE,YTITLE)
	  CALL MGOLABEL(12,TITLE(N))
	ENDDO
	CALL MGOSETEXPAND(1.)
	CALL MGOSETEXPAND(.8)
	CALL MGOPLOTID(EVENT,'[.WIND]TDSEXEY,SPPLOT')
	CALL MGOSETEXPAND(1.)
C
	IF(ITERM.LT.0) THEN
	  CALL MGOPRNTPLOT(NVEC)
	  PRINT*,' NO. VECTORS PLOTTED',NVEC
	ELSE
	  CALL MGOTCLOSE
	ENDIF
C
	RETURN
C
	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
	CHARACTER*80	YYYYMMDD
	common /nrblk/ nrem,NHRMN,IFASTSLOW
	integer*4	iq,NREM,NHRMN,IFASTSLOW

10	  write(6,6)
	  write(6,7)
	  read(5,5,err=10,end=20) iq, stream
	print*,'in get_, initial stream=  ',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 TIME of an offline file
	   YYYYMMDD = STREAM(1:8)
	   PRINT*,YYYYMMDD
	   WRITE(STREAM,30) YYYYMMDD
 30	   FORMAT('wi_lz_wav_',A8,'_v*.dat')
	   PRINT*,'STREAM IN GET',STREAM
	end if

	get_stream_name = 1

 20	return
c
  5	format(q,a)
  6	format(1x,'Enter TM stream type [O=offline (default), R=realtime ]: ',$)
  7	format(1x,'or type desired time as YYYYMMDD, e.g. 19961113  ',$)
c
	end
	SUBROUTINE FITSLOPE(X,Y,N,SLOPE,SUMSQ)
C
	DIMENSION X(1),Y(1),WT(2048)
C
	SUMSQ = 0.
	SXX = 0.
	SXY = 0.
	SYY = 0.
	DO J = 1,N
	  WT(J) = .06 + SQRT(ABS(X(J)*Y(J)))
	  IF(WT(J).NE.0.) THEN
	    SXX =SXX + X(J)**2/WT(J)
	    SXY =SXY + X(J)*Y(J)/WT(J)
	    SYY =SYY + Y(J)**2/WT(J)
	  ENDIF
	ENDDO
C	SLOPE IS Y/X
	IF(SXX.NE.0.) SLOPE = SXY/SXX
	SUMSQ = SXX*SLOPE**2 - 2.*SLOPE*SXY + SYY
	RETURN
	END
	SUBROUTINE PLOTPART(ITERM)
C
C	PLOTS ONE COMPONENT AGAINST ANOTHER FOR A FRACTION OF AN
C		EVENT TO LOOK FOR POLARIZATION CHANGES
C
	CHARACTER*12 title(20)
	CHARACTER*120 STR
	CHARACTER*4 EVENT
	CHARACTER*8 LABEL(4)
	character*80	file
	INTEGER*4 TDS_CHANNEL,S_SCET(2),MAJOR,MINOR,NSYS
	COMMON /HEADBL/ TITLE,EVENT,NUMEVENT,FILE
	COMMON /FIXUPBLK/ ISTART
	COMMON /BBLOCK/ BSCET,BX,BY,BZ,BAZ
	common /headblk/ major,minor,s_scet,nsys
	COMMON /PLTBLK/ IZCNT,IPROCESS,ZCROSS(2048),ZINT(2048),
     1   NDATA(2048),DATA(2050),SPECT(1025)
	COMMON /TDS_STATUS/ TDS_CHANNEL,SPS,FILTER,IRX,ISPS
	COMMON /STATUS/ FFILTER(4),SFILTER(4),FSPS(4),SSPS(4)
	COMMON /PARTBLK/ XDATA(2050,4),XRE,YRE,ZRE,SUNCLOCK,SPINRATE
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
	INTEGER*4 SUNCLOCK
	CHARACTER*1 DISPOSE
	REAL*8 BSCET
	REAL SLOPE(20),SLOPERR(20)
	DIMENSION YY(2048),XX(2048),XD(2048),YD(2048),AMPMAX(20)
	DATA TWOPI /6.2831853/
	DATA LABEL /'VX V.','VY V.','EZ mV/m','B nT'/
C
		N1 = 1
		N2 = 2
C
	  CALL MGOINIT
	  CALL MGOSETUP(ITERM)
	  CALL MGOERASE
C
C	  PUT LABELS ON RIGHT HAND SIDE
C
	  IF(ITERM.LT.0) THEN
	    CALL MGOSETLOC(500.,450.,2000.,3050.)
	  ELSE
	    CALL MGOSETLOC(100.,80.,800.,750.)
  	  ENDIF
C
c	  XTITLE = GX2 +.05*(GX2-GX1)
	  XTITLE = GX2 +.1*(GX2-GX1)              ! 3 dec 1996
	  YTITLE = GY2
	  TRANGE = GY2-GY1
	  TINC = .03*TRANGE
	  CALL MGOSETEXPAND(.6)
	  TITLE(6) = ' '
	  TITLE(7) = ' '
	  DO N = 4,18
	    YTITLE = YTITLE - TINC
	    IF(N.EQ.4) YTITLE = YTITLE - TINC
	    IF(N.EQ.6) YTITLE = YTITLE - TINC
	    IF(N.EQ.19) YTITLE = YTITLE - TINC
	    CALL MGOGRELOCATE(XTITLE,YTITLE)
	    CALL MGOLABEL(12,TITLE(N))
	  ENDDO
C
C	  PLOT TDS DATA
	  YMAX = 0.
	  EFFLENX = 41.1				! X ANTENNA  23-SEP-96
	  EFFLENY = 3.79  				! Y ANTENNA   "
	  EFFLENZ = 2.17  				! Z ANTENNA   "
	  ACORR = 1000.
	  IF(IRX.GE.7) THEN			! SEARCH COILS
		ACORR=1.
		EFFLEN = 1.
	  ENDIF
C
	YMAX = 0.
	XMAX = 0.
C	CHANGE TO mV/meter, NOT DONE HERE
	  DO N = 1,2048
C	    XD(N) = ACORR*XDATA(N,N1)/EFFLENX
C	    YD(N) = ACORR*XDATA(N,N2)/EFFLENY
	    XD(N) = XDATA(N,N1)
	    YD(N) = XDATA(N,N2)
	    YMAX = AMAX1(YD(N),YMAX)
	    YMAX = AMAX1(-YD(N),YMAX)
	    XMAX = AMAX1(XD(N),XMAX)
	    XMAX = AMAX1(-XD(N),XMAX)
	  ENDDO
	  XMAXS = XMAX
	  YMAXS = YMAX
C
	  CALL MGOSETEXPAND(.85)
	  IF(ITERM.GT.0) THEN
	    CALL MGOGRELOCATE(10.,0.)                      ! maxch, crt
	  ELSE
	    CALL MGOGRELOCATE(400.,50.)                      ! hardcopy
	  ENDIF
C	  CALL MGOPUTLABEL(53,STR,9)
	  CALL MGOSETEXPAND(1.)
C
	  NXW = 2
	  NYW = 2
	  NW = NXW*NYW
	  DO IW = 1,NW
	    CALL MGOWINDOW(NXW,NYW,IW)
	    NPTST = (IW-1)*2048/NW + 1
	    NPTND = (IW)*2048/NW
	    NPT = 0
	    XMAX = 0.
	    YMAX = 0.
	    NPTMAX = NPTST
    	    DO N = NPTST,NPTND
	      NPT = NPT+1
	      XX(NPT) = XD(N)
	      YY(NPT) = YD(N)
	      IF(ABS(XX(NPT)).GT.XMAX) NPTMAX = NPT
	      XMAX = AMAX1(XMAX,ABS(XX(NPT)))
	      YMAX = AMAX1(YMAX,ABS(YY(NPT)))
	    ENDDO
	    AMPMAX(IW) = SQRT(XMAX**2+YMAX**2)
C	    XMAX = 1.1*AMAX1(XMAX,YMAX)
C	    YMAX = XMAX
C
	    CALL FITSLOPE(XX,YY,NPT,SLOPE(IW),SLOPERR(IW))
C
	    CALL MGOSETLIM(-XMAX,-YMAX,XMAX,YMAX)
	    CALL MGOSETEXPAND(.7)
C	    CALL MGOTICKSIZE(0.,0.,0.,0.)
	    CALL MGOCONNECT(XX,YY,NPT)
C	    PUT ON ARROW
	    SIZE = .01*SQRT(XMAX**2 + YMAX**2)
	    DX = XX(NPTMAX+1) - XX(NPTMAX)
	    DY = YY(NPTMAX+1) - YY(NPTMAX)
c	    CALL ARROW(XX(NPTMAX),YY(NPTMAX),DX,DY,SIZE)
C	if(n2.eq.2) then
c	  print*,nptmax-1,xx(nptmax-1),yy(nptmax-1)
C	  print*,nptmax,xx(nptmax),yy(nptmax)
c	  print*,nptmax+1,xx(nptmax+1),yy(nptmax+1)
C	ENDIF
	    CALL MGOSETEXPAND(.6)
	    CALL MGOBOX(1,2)
	    CALL MGOSETEXPAND(.6)
	    CALL MGOXLABEL(7,LABEL(N1))
	    CALL MGOYLABEL(7,LABEL(N2))
	    CALL MGOSETEXPAND(.8)
	    CALL MGOSETEXPAND(1.)
C
C
C		SPSKHZ = .001*SPS
C
	  ENDDO
C
	  IF(IPROCESS.GE.3) THEN
	    YTITLE = YTITLE-2.*TINC
	    CALL MGOSETEXPAND(.5)
	    CALL MGOGRELOCATE(XTITLE,YTITLE)
	    CALL MGOLABEL(8,' BAD TDS')
	    YTITLE = YTITLE-TINC
	    CALL MGOGRELOCATE(XTITLE,YTITLE)
	    CALL MGOLABEL(9,'CORRECTED')
	    YTITLE = YTITLE-TINC
	    CALL MGOGRELOCATE(XTITLE,YTITLE)
	    WRITE(STR,1024) IPROCESS
 1024	    FORMAT(' LEVEL',I2)
	    CALL MGOLABEL(8,STR)
	    WRITE(STR,1025) ISTART
 1025	    FORMAT(I5,' PTS')
	    YTITLE = YTITLE-TINC
	    CALL MGOGRELOCATE(XTITLE,YTITLE)
	    CALL MGOLABEL(9,STR)
	    CALL MGOSETEXPAND(.8)
	  ENDIF
	END_ANGLE =  -360.*SUNCLOCK/4096. + 45.   ! ANGLE SUN TO +EX AT END
	DANG = SPINRATE*360./SPS/TWOPI
	PK_ANGLE = END_ANGLE + 1024.*DANG	  ! ANGLE SUN TO +EX AT CENTER
C
	  CALL MGOSETEXPAND(.6)
 	  CALL MGOPLOTID(' ','[.WIND]TDSEXEY,PLOTPART')
	  CALL MGOSETEXPAND(.8)
C
	IF(ITERM.LT.0) THEN
	  CALL MGOPRNTPLOT(NVEC)
	  PRINT*,' NO. VECTORS PLOTTED',NVEC
	ELSE
	  READ(5,1023) DISPOSE
 1023	  FORMAT(A1)
	  IF(DISPOSE.EQ.'W'.OR.DISPOSE.EQ.'w') THEN
		BAZSC = BAZ - PK_ANGLE
		IF(BAZSC.GT.180.) BAZSC = BAZSC - 360.
		IF(BAZSC.LT.-180.) BAZSC = BAZSC + 360.
		write(71,1010) file(31:38),NUMEVENT,SLOPE(2),SLOPERR(2),
     1		AMPMAX(2),BAZSC,PK_ANGLE
		write(71,1010) file(31:38),NUMEVENT,SLOPE(3),SLOPERR(3),
     1		AMPMAX(3),BAZSC,PK_ANGLE
	  ENDIF
	  CALL MGOTCLOSE
C	  PRINT*,'DISPOSE ',DISPOSE
	ENDIF
C
 1010	FORMAT(1X,A8,I10,E12.3,E12.3,E12.3,2F8.2)
C
	RETURN
C
	END
	SUBROUTINE ARROW(X,Y,DX,DY,SIZE)
C
C	makes an arrowhead, near x,y in user coords, size as fraction
c	of graph size, direction dx,dy  from  x,y
C	MONGO MUST BE OPENED AND WORKING
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
C	CALCULATE DXP,DYP PERPENDICULAR TO DX,DY
C
	print*,'arrow',x,y,dx,dy,size
	XNORM = SQRT(DX**2 + DY**2)
	DXL = DX*SIZE/XNORM
	DYL = DY*SIZE/XNORM
	DXP = .5*DYL
	DYP = -.5*DXL
	CALL MGORELOCATE(X+DX,Y+DY)
	CALL MGODRAW(X+DXP,Y+DYP)
	CALL MGORELOCATE(X+DX,Y+DY)
	CALL MGODRAW(X-DXP,Y-DYP)
	DXP = .5*DXP
	DYP = .5*DYP
	CALL MGORELOCATE(X+DX,Y+DY)
	CALL MGODRAW(X+DXP,Y+DYP)
	CALL MGORELOCATE(X+DX,Y+DY)
	CALL MGODRAW(X-DXP,Y-DYP)
C
	RETURN
	END


      subroutine eqshel(aadh,aadhh,aadhv,aamatr,aaphi,abar,abdh,
     $ abdhh,abdhv,abdot,abdoth,abdotv,acflg,acflgo,act,actlg,
     $ adadhh,adadhv,adbdhh,adbdhv,adbdth,adbdtv,adh,adhh,adhv,
     $ afcnst,affp,affs,alpha,al10,amtb,aphi,apx,avcnst,azero,
     $ a3bar,a3bars,bacfmx,bbig,bdh,bdhh,bdhv,bdot,bdoth,bdotv,
     $ beta,betamx,betao,bgamx,bneg,bpx,cbsr,cco2,cdac,cegexs,
     $ cesr,cess,cdrs,cdrsd,cdrsx,cdrtw,cdrw,cjbasp,cnufac,conc,
     $ conclg,cpgexs,cscale,csigma,csts,dadhh,dadhv,dbdhh,dbdhv,
     $ dbdth,dbdtv,deltim,delvco,delvec,delxi,dlogxw,dlxmin,
     $ drer0,drir0,dzvc0,d1zvc1,eact,egers,egexjc,egexjf,egexs,
     $ eh,ehfac,elecsr,eps100,farad,fje,fjeo,fkrc,fo2,fo2lg,
     $ fsort,fugac,fugalg,fxi,fxio,gmmatr,hact,iact,iapxt,ibpxt,
     $ ibswx,ielam,ier,iern1,iern2,ifcphi1,ifcphi2,ifnnn,ifn2n,
     $ ifpsi1,ifpsi2,ifrn1,ifrn2,ifzeta,igas,igstak,iindx0,iindx1,
     $ ilcphi1,ilcphi2,ilnnn,iln2n,ilpsi1,ilpsi2,ilrn1,ilrn2,
     $ ilzeta,imech,imrn1,imrn2,insgf,iodb,iopg,iopt,ipch,
     $ ipivot,ipndx1,ipcv,istack,iter,itermx,ixbasp,ixrn1,ixrn2,
     $ izmax,jcode,jcsort,jflag,jgsort,jgstak,jjsort,jpflag,
     $ jpress,jptffl,jreac,jsflag,jsitex,jsol,jssort,jstack,
     $ jtemp,kbt,kction,kdim,kelect,khydr,khydx,km10,km1,kmt,
     $ kmt0,ko2gaq,kpsat,kpsst,krdxsp,kwater,kx1,kx10,kxt,kxt0,
     $ loph,losp,lsort,modr,modr0,moph,morr,morr0,mosp,mrgers,
     $ mrgexs,mtb,mtbaq,mtb0,mte,mteaq,mwtrc,narn1,narn2,narxt,
     $ nat,nbasp,nbaspd,nbaspx,nbt,nbtd,nbw,nchlor,ncmpr,ncorr,
     $ nct,ndac,ndact,ndrs,ndrsd,ndrsx,ndrsr,ndrsrd,ndrsrx,nelect,
     $ nern1,nern2,ness,nessr,net,nfrn1,nfrn2,ngrn1,ngrn2,ngt,
     $ nhydr,nhydx,nlrn1,nlrn2,nlt,nmrn1,nmrn2,nmt,nord,noutpt,
     $ no2gaq,npchk,nphasx,npslmx,npt,nrct,nrdxsp,nrk,nrndex,nsk,
     $ nsslmx,nst,nsts,nstsr,ntpr,ntrymx,ntprt,nttyo,nxridx,nxrn1,
     $ nxrn2,nxt,nweope,nwndpc,omega,omeglg,prcinf,press,pressb,
     $ pressd,ptk,qbassw,qbseqc,qbye,qcnpre,qcntmp,qhawep,qmod,
     $ qoptmz,qpit75,qredox,qriinf,qscon,qshoot,qstart,qtrch,qtvchk,
     $ qxknph,q6mode,rcnstv,rconst,rkb,rhsvec,rirec0,rk,rreacn,
     $ rreac1,rrelr0,rrelr1,rtcnst,rxbar,screwd,sidrph,sidrsp,
     $ sigmam,sigmmo,smp100,tdays,tempc,tempcb,tempcd,tempcu,
     $ tempc0,tempk,timemx,time0,time1,tiplol,tiplot,tiprnl,tiprnt,
     $ tistsv,tolbt,toldl,tolsat,tolsst,tolxst,trkb,ttk,ubacmx,
     $ ubgamx,udac,ufixf,ugermo,ulbeta,uldel,uphase,ureac,uspec,
     $ uzvec0,uzvec1,vreac,weight,wfac,wodr,worr,xbar,xbarlg,
     $ xbarw,xbarwc,xbrwlc,xbrwlg,xgers,xirct,xirct0,xistsv,xi0,
     $ xi1,zchar,zchcu6,zchsq2,zklogu,zvclg0,zvclg1,zvec0,zvec1)
c
c     This subroutine provides a shell around EQ6/eqcalc.f that allows
c     fine adjustments to the value of reaction progress in order to
c     step over fine singularities, such as may exist in the middle of
c     a major jump in the oxygen fugacity.
c
c     This subroutine is called by:
c
c       EQ6/path.f
c
c-----------------------------------------------------------------------
c
c     Principal input:
c
c
c     Principal output:
c
c
c-----------------------------------------------------------------------
c
c       qbye comes in .true. if EQ6/path.f just changed the phase
c         assemblage by deleting one or more minerals. This
c         instructs this subroutine to print the index (iindx1)
c         structure of the system of equations as it does on the
c         starting call and whenever this subroutine itself adds or
c         deletes a phase.
c
c       iter is the number of Newton-Raphson iterations that
c         EQLIB/newton.f performed.
c
c       ier is an error parameter which is returned as 0 if the
c         calculations in this subroutine converged successfully and
c         there were no violations of possible open system constraints.
c
c       ier    = error flag:
c
c                  Values returned from EQ6/eqphas.f:
c                    =    0  Okay
c                    =   10  Go back and take a smaller step size to
c                              avoid exceeding the supersaturation
c                              tolerance (tolsst). This is done only
c                              when an appropriate set of conditions
c                              is satisified. It isn't necessary for
c                              EQ6/path.f to analyze the situation
c                              when this value is returned to it by
c                              EQ6/eqshel.f.
c                    =   20  Hit the maximum number of tries to find
c                              the correct phase assemblage
c                    =   30  Caught in a region of computational
c                              instability about the phase boundary for
c                              an appearing phase. Iteration fails when
c                              the phase is added to the phase
c                              assemblage.
c                    =   40  Caught in a region of computational
c                              instability about the phase boundary for
c                              a disappearing phase. The system is
c                              too supersaturated with respect to a
c                              phase if that phase is deleted from the
c                              phase assemblage.
c                    =   50  Caught in a region of computational
c                              instability associated with solvent
c                              water. The amount of water in the
c                              system is probably very low.
c                    =   60  Caught in a region of computational
c                              instability associated with the
c                              master redox variable. This is probably
c                              associated with a redox jump.
c                    =   90  Caught in a region of computational
c                              instability associated with the
c                              aqueous activity coefficient model.
c                    =  100  Detected out-of-range values for variables
c                              associated with the basis species before
c                              starting iteration.
c                    =  110  Detected out-of-range values for variables
c                              associated with the basis species after
c                              an iteration crash.
c                    =  150  Calculation failed, no diagnostics were
c                              generated.
c
c                  Values returned by the present subroutine:
c                    =    0  Okay
c                    =   10  Go back and take a smaller step size to
c                              avoid exceeding the supersaturation
c                              tolerance (tolsst)
c                    =  170  Too much of a phase was destroyed under
c                              the flow-through open system model;
c                              go back and first move part of the
c                              mass of protected phases in the ES to
c                              the PRS
c                    =  180  One of a number of problems occurred which
c                              may be resolvable, at least partially,
c                              by going back and cutting the step size
c                    =  190  Need to slide over a region of
c                              computational instability, but sliding
c                              is inhibited; go back, but terminate
c                              work on the current problem
c
c-----------------------------------------------------------------------
c
c     Modules.
c
c     The module mod6pt contains data required to evaluate Pitzer's
c     equations.
c
      use mod6pt
c
c     The module mod6xf contains most of the standard-state
c     thermodynamic data.
c
      use mod6xf
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
      include 'eqlib/eqlpar.h'
      include 'eqlib/eqldv.h'
      include 'eqlib/eqlge.h'
      include 'eqlib/eql1s.h'
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer noutpt,nttyo
c
      integer iact(imchmx,2,nrctmx),imech(2,nrctmx),ixbasp(nbtmax),
     $ ndac(ndctmx,imchmx,2,nrctmx),ndact(imchmx,2,nrctmx),
     $ nrk(2,nrctmx),nsk(nrctmx)
c
      integer jcode(nrctmx),jreac(nrctmx),nrndex(nrctmx),nxridx(nrctmx)
c
      integer iapxt(nxtmax),ibpxt(nxtmax),ibswx(nbtmax),igstak(ngtmax),
     $ iindx0(kmax),iindx1(kmax),ipivot(kmax),ipndx1(kmax),
     $ insgf(natmax),iodb(nodbmx),iopg(nopgmx),iopt(noptmx),
     $ istack(nstmax),jcsort(nstmax),jflag(nstmax),jgsort(ngtmax),
     $ jgstak(ngtmax),jjsort(nstmax),jpflag(nptmax),jsflag(nstmax),
     $ jsitex(nstmax),jsol(nxtmax),jssort(nstmax),jstack(nstmax),
     $ kction(nbtmax)
c
      integer narxt(ntprmx),nbasp(nbtmax),nbaspd(nbtmax),nbaspx(nbtmax),
     $ ncmpr(2,nptmax),ness(nessmx),nessr(2,nstmax),ndrs(ndrsmx),
     $ ndrsd(ndrsmx),ndrsx(ndrsmx),ndrsr(2,nstmax),ndrsrd(2,nstmax),
     $ ndrsrx(2,nstmax),npchk(nptmax),nphasx(nstmax),nsts(nstsmx),
     $ nstsr(2,nstmax)
c
      integer iern1,iern2,ifrn1,ifrn2,ilrn1,ilrn2,imrn1,imrn2,
     $ ixrn1,ixrn2
c
      integer ifcphi1,ifcphi2,ifnnn,ifn2n,ifpsi1,ifpsi2,ifzeta,
     $ ilcphi1,ilcphi2,ilnnn,iln2n,ilpsi1,ilpsi2,ilzeta
c
      integer nat,nbt,nct,net,ngt,nlt,nmt,npt,nst,nxt
c
      integer narn1,narn2,nern1,nern2,nfrn1,nfrn2,ngrn1,ngrn2,
     $ nlrn1,nlrn2,nmrn1,nmrn2,nxrn1,nxrn2
c
      integer ielam,ier,igas,ipch,ipcv,iter,itermx,izmax,jpress,jptffl,
     $ jtemp,kbt,kdim,kelect,khydr,khydx,km1,km10,kmt,kmt0,ko2gaq,
     $ kpsat,kpsst,krdxsp,kwater,kx1,kx10,kxt,kxt0,nbtd,nbw,nchlor,
     $ ncorr,nelect,nhydr,nhydx,nord,no2gaq,npslmx,nrct,nrdxsp,nsslmx,
     $ ntpr,ntprt,ntrymx,nweope,nwndpc
c
      logical qxknph(nptmax)
c
      logical qbassw,qbseqc,qbye,qcnpre,qcntmp,qhawep,qmod,qoptmz,
     $ qpit75,qredox,qriinf,qshoot,qscon,qstart,qtrch,qtvchk,q6mode
c
      character*48 uspec(nstmax),uzvec0(kmax),uzvec1(kmax)
      character*48 ubacmx,ubgamx
      character*24 ugermo(nertmx),ureac(nrctmx)
      character*24 udac(ndctmx,imchmx,2,nrctmx)
      character*24 uphase(nptmax)
      character*8 ulbeta(kmax),uldel(kmax)
      character*8 ufixf
c
      real*8 aadh(narxmx,ntprmx),aadhh(narxmx,ntprmx),
     $ aadhv(narxmx,ntprmx),aaphi(narxmx,ntprmx),
     $ abdh(narxmx,ntprmx),abdhh(narxmx,ntprmx),
     $ abdhv(narxmx,ntprmx),abdot(narxmx,ntprmx),
     $ abdoth(narxmx,ntprmx),abdotv(narxmx,ntprmx)
c
      real*8 dadhh(ipchmx),dadhv(ipcvmx),dbdhh(ipchmx),dbdhv(ipcvmx),
     $ dbdth(ipchmx),dbdtv(ipcvmx)
c
      real*8 adadhh(narxmx,ntprmx,ipchmx),
     $ adadhv(narxmx,ntprmx,ipcvmx),adbdhh(narxmx,ntprmx,ipchmx),
     $ adbdhv(narxmx,ntprmx,ipcvmx),adbdth(narxmx,ntprmx,ipchmx),
     $ adbdtv(narxmx,ntprmx,ipcvmx)
c
       real*8 cdac(ndctmx,imchmx,2,nrctmx),csigma(imchmx,2,nrctmx),
     $ eact(imchmx,2,nrctmx),fkrc(nrctmx),hact(imchmx,2,nrctmx),
     $ rkb(imchmx,2,nrctmx),trkb(imchmx,2,nrctmx)
c
      real*8 cbsr(nbt1mx,nsrtmx),cesr(nctmax,nsrtmx),
     $ egers(ietmax,jetmax,nertmx),elecsr(nsrtmx),modr(nrctmx),
     $ mrgers(ietmax,jetmax,nertmx),morr(nrctmx),mwtrc(nrctmx),
     $ rreacn(nrctmx),rreac1(nrctmx),rrelr1(nrctmx),
     $ rxbar(iktmax,nxrtmx),vreac(nrctmx),wodr(nrctmx),
     $ worr(nrctmx),xgers(ietmax,jetmax,nertmx)
c
      real*8 aamatr(kmax,kmax),acflg(nstmax),acflgo(nstmax),
     $ act(nstmax),actlg(nstmax),affp(nptmax),affs(nstmax),
     $ alpha(kmax),amtb(nbtmax),apx(iapxmx,nxtmax),azero(natmax),
     $ a3bars(natmax),beta(kmax),betao(kmax),bpx(ibpxmx,nxtmax),
     $ cco2(5),cegexs(ietmax,jetmax,netmax),cess(nessmx),
     $ cdrs(ndrsmx),cdrsd(ndrsmx),cdrsx(ndrsmx),cdrtw(nstmax),
     $ cdrw(nstmax),cjbasp(nbtmax),cnufac(nstmax),conc(nstmax),
     $ conclg(nstmax),cpgexs(ietmax,jetmax,netmax),cscale(nstmax),
     $ csts(nstsmx),drer0(nrd1mx,nrctmx),delvco(kmax),delvec(kmax),
     $ dlogxw(nbtmax),drir0(nrd1mx),dzvc0(nrd1mx,kmax),d1zvc1(kmax),
     $ egexjc(jetmax,netmax),egexjf(jetmax,netmax),
     $ egexs(ietmax,jetmax,netmax)
c
      real*8 fsort(ngtmax),fugac(ngtmax),fugalg(ngtmax),
     $ gmmatr(kmax,kmax),loph(nptmax),losp(nstmax),lsort(nstmax),
     $ modr0(nrctmx),moph(nptmax),morr0(nrctmx),mosp(nstmax),
     $ mrgexs(ietmax,jetmax,netmax),mtb(nbtmax),mtbaq(nbtmax),
     $ mtb0(nbtmax),mte(nctmax),mteaq(nctmax),ptk(nttkmx),
     $ rhsvec(kmax),rk(imchmx,2,nrctmx),rrelr0(nrctmx),sidrph(nptmax),
     $ sidrsp(nstmax),tempcu(ntprmx),ttk(nttkmx),weight(nstmax),
     $ wfac(iktmax,nxtmax),xbar(nstmax),xbarlg(nstmax),xirct(nrctmx),
     $ xirct0(nrctmx),zchar(nstmax),zchcu6(nstmax),zchsq2(nstmax),
     $ zvclg0(kmax),zvclg1(kmax),zvec0(kmax),zvec1(kmax)
c
      real*8 adh,adhh,adhv,aphi,bdh,bdhh,bdhv,bdot,bdoth,bdotv
c
      real*8 abar,afcnst,al10,avcnst,a3bar,bacfmx,bbig,betamx,bgamx,
     $ bneg,deltim,delxi,dlxmin,eh,ehfac,eps100,farad,fje,fjeo,fo2,
     $ fo2lg,fxi,fxio,omega,omeglg,prcinf,press,pressb,pressd,rcnstv,
     $ rconst,rirec0,rtcnst,screwd,sigmam,sigmmo,smp100,tdays,tempc,
     $ tempcb,tempcd,tempk,tempc0,timemx,time0,time1,tiplol,tiplot,
     $ tiprnl,tiprnt,tistsv,tolbt,toldl,tolsat,tolsst,tolxst,xbarw,
     $ xbarwc,xbrwlc,xbrwlg,xistsv,xi0,xi1,zklogu
c
c-----------------------------------------------------------------------
c
c     Local variable declarations with global dimensioning.
c
c     Variables for restoring the entering configuration, including
c     the entering phase assemblage.
c
      integer isv_kmax,isv_nbtmax,isv_nstmax
c
      SAVE isv_kmax,isv_nbtmax,isv_nstmax
c
      integer, dimension(:), allocatable :: iindxs,ipndxs,nbasps
c
      SAVE iindxs,ipndxs,nbasps
c
      real(8), dimension(:), allocatable :: acflgs,zvclgs
c
      SAVE acflgs,zvclgs
c
c     The following do not need to be SAVEd.
c
      integer kdims,km1s,kmts,kx1s,kxts
c
      real(8) xbarws,xbrwls
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer jlen,j2,k,kcol,krow,n,nb,nords,np,nphasl,nplast,np1,
     $ nrdxsl,ns,ns2,ntpr0
c
      integer ilnobl
c
      logical qbswok,qslmod,qsspgb,qztayl
c
      character*56 uspn56
c
      real*8 dlmoph,dltimd,lold,lxx,mold,mxx0
c
      real*8 texp,tlg
c
c-----------------------------------------------------------------------
c
c     Allocate or reallocate local work arrays as needed.
c
      if (.not.ALLOCATED(iindxs)) then
c
c       Local work arrays are not allocated. Zero the saved
c       array size variables. Note that only one array is tested
c       to see if it is allocated. It is assumed that all local
c       work arrays are either allocated or not.
c
        isv_kmax = 0
        isv_nbtmax = 0
        isv_nstmax = 0
      else
c
c       Local work arrays are allocated. Check to see if any of the
c       array size variables have changed. If so, deallocate
c       the corresponding local work arrays and zero the corresponding
c       saved size variables.
c
        if (kmax .ne. isv_kmax) then
          DEALLOCATE(iindxs,ipndxs)
          DEALLOCATE(zvclgs)
          isv_kmax = 0
        endif
c
        if (nbtmax .ne. isv_nbtmax) then
          DEALLOCATE(nbasps)
          isv_nbtmax = 0
        endif
c
        if (nstmax .ne. isv_nstmax) then
          DEALLOCATE(acflgs)
          isv_nstmax = 0
        endif
      endif
c
c     At this point, the saved array size values are zero if the
c     corresponding arrays need to be allocated.
c
      if (isv_kmax .eq. 0) then
        ALLOCATE(iindxs(kmax),ipndxs(kmax))
        ALLOCATE(zvclgs(kmax))
        isv_kmax = kmax
      endif
c
      if (isv_nbtmax .eq. 0) then
        ALLOCATE(nbasps(nbtmax))
        isv_nbtmax = nbtmax
      endif
c
      if (isv_nstmax .eq. 0) then
        ALLOCATE(acflgs(nstmax))
        isv_nstmax = nstmax
      endif
c
c     Zero the contents of the local work arrays.
c
      do k = 1,kmax
        iindxs(k) = 0
        ipndxs(k) = 0
      enddo
c
      do k = 1,kmax
        zvclgs(k) = -99999.
      enddo
c
      do n = 1,nbtmax
        nbasps(n) = 0
      enddo
c
      do n = 1,nstmax
        acflgs(n) = 0.
      enddo
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Initialize some parameters.
c
      qslmod = .false.
      qmod = .false.
      qbseqc = .false.
c
      ier = 0
      nrdxsl = 0
      nphasl = 0
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Save the "kernel" description for the current equilibrium system.
c     This will be used to recover if the equilibrium calculation
c     overseen by EQ6/eqphas.f fails for any reason. This kernel
c     contains the minimum of information required to calculate the
c     fully expanded description using EQLIB/ncmpex.f. Note that
c     EQ6/eqphas.f (which the present subroutine calls) and EQ6/path.f
c     (which calls the present subroutine) have their own distinct
c     backup kernels.
c
      km1s = km1
      kmts = kmt
      kx1s = kx1
      kxts = kxt
      kdims = kdim
c
      call copyia(nbasp,nbasps,nbt)
      call copyia(iindx1,iindxs,kdim)
      call copyia(ipndx1,ipndxs,kdim)
c
      call copyaa(zvclg1,zvclgs,kdim)
      call copyaa(acflg,acflgs,nst)
c
      xbarws = xbarwc
      xbrwls = xbrwlc
c
c     Save the order of the finite differences.
c
      nords = nord
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
  100 continue
c
c     This is a return point if the step size is changed within
c     the present subroutine. There are two cases:
c
c        1. Advance the step size through a region of critical
c           redox instability (redox jump) from the last nonsingular
c           point of reaction progress. Move the simulation over
c           the region of singularity by using only predictor functions
c           expanded from that last good point.
c
c        2. Advance the step size across a region of singularity
c           that is associated with the presence or absence of a phase.
c           There are two cases. first, the calculations may fail to
c           converge upon adding a newly supersaturated phase because
c           the number of moles of the phase that would be produced is
c           so small that the Jacobian matrix becomes effectively
c           singular. Second, when a phase is disappearing, its number
c           of moles may become so small that the above singlularity
c           occurs. This is a normal mode for dropping a phase.
c           Sometimes, the affinity of the phase exceeds the
c           supersaturation tolerance when the system is solved for
c           the case of the phase not present. In each case, the step
c           size must be advanced across the region of apparent
c           singularity.
c
      if (ncorr .le. 0) then
        write (noutpt,1000) xi1,delxi,nord
 1000   format(/' Stepping to Xi= ',1pe11.4,', delxi= ',1pe11.4,
     $  ', nord= ',i1)
      endif
c
      if (iopt(2) .gt. 0) then
        if (xi1 .gt. xistsv) then
          if (.not.qshoot) then
            call timeca(deltim,delxi,drir0,iodb,nodbmx,nord,noutpt,
     $      nrd1mx,nttyo,prcinf,qriinf,rirec0,time0,time1)
c
            if (delxi .le. dlxmin) then
c
c             Make sure that the calculated time does not exceed any
c             any specified limits such as the maximum time just because
c             delxi is at the minimum value.
c
              call tivchk(deltim,delxi,qtvchk,time1,time0,timemx,
     $        tiplol,tiplot,tiprnl,tiprnt,tolxst)
            endif
          endif
        else
          time1 = tistsv
          deltim = 0.
        endif
c
        tdays = time1/86400.
        dltimd = deltim/86400.
c
        write (noutpt,1010) ncorr,tdays,dltimd
 1010   format(3x,'ncorr= ',i2,', time= ',1pe11.4,' d, deltim= ',
     $  e11.4,' d')
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
      if (nord .gt. 0) then
c
c       Make a Taylor's series expansion of the dz/d(xi) vector.
c       This information is used to track how the reacting system
c       is changing.
c
        call d1ztay(delxi,dzvc0,d1zvc1,kdim,kmax,nord,nrd1mx)
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
      if (nrct .ge. 1) then
c
c       Increment the irreversible reactions (those associated with
c       the "reactants"); update the ES mass balance totals accordingly.
c
        call reacts(cbsr,csts,delxi,drer0,iern1,ietmax,iktmax,
     $  iodb,jcode,jetmax,jgext,jreac,modr,modr0,morr,morr0,mrgers,
     $  mtb,mtb0,nbaspd,nbt,nbtmax,nbt1mx,ncmpr,nern1,nern2,nertmx,
     $  netmax,ngext,nodbmx,nord,noutpt,nptmax,nrct,nrctmx,nrd1mx,
     $  nrndex,nsrtmx,nstmax,nsts,nstsmx,nstsr,nttyo,nxridx,nxrtmx,
     $  rrelr0,rxbar,ureac,xirct,xirct0)
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Set a flag for a go back followed by a step size reduction when
c     the equilibrium calculation indicates a supersaturation that
c     exceeds the tolerance value used in locating the phase boundary
c     for a newly appearing phase.
c
      qsspgb = iopt(3).le.1 .and. .not.qslmod .and.(.not.qscon)
     $ .and. delxi.gt.dlxmin .and. .not.qstart
c
c     Make the equilibrium calculation. Basis switching may occur.
c     Also, the phase assemblage may be changed.
c
      call eqphas(aamatr,abar,acflg,acflgo,act,actlg,
     $ adh,adhh,adhv,afcnst,affp,affs,alpha,al10,amtb,aphi,
     $ apx,avcnst,azero,a3bar,a3bars,bacfmx,bbig,bdh,bdhh,bdhv,
     $ bdot,bdoth,bdotv,beta,betamx,betao,bgamx,bneg,bpx,cco2,
     $ cegexs,cess,cdrs,cdrsd,cdrsx,cdrtw,cdrw,cjbasp,cnufac,
     $ conc,conclg,cpgexs,cscale,csts,delvco,delvec,d1zvc1,dlogxw,
     $ egexjc,egexjf,egexs,eh,ehfac,eps100,farad,fje,fjeo,fo2,
     $ fo2lg,fsort,fugac,fugalg,fxi,fxio,gmmatr,iapxt,ibpxt,ibswx,
     $ ielam,ier,iern1,iern2,ifcphi1,ifcphi2,ifnnn,ifn2n,ifpsi1,
     $ ifpsi2,ifrn1,ifrn2,ifzeta,igas,igstak,iindx0,iindx1,ilcphi1,
     $ ilcphi2,ilnnn,iln2n,ilpsi1,ilpsi2,ilrn1,ilrn2,ilzeta,imrn1,
     $ imrn2,insgf,iodb,iopg,iopt,ipch,ipivot,ipndx1,ipcv,istack,
     $ iter,itermx,ixbasp,ixrn1,ixrn2,izmax,jcsort,jflag,jgsort,
     $ jgstak,jjsort,jpflag,jsflag,jsitex,jsol,jssort,jstack,kbt,
     $ kction,kdim,kelect,khydr,khydx,km1,km10,kmt,kmt0,ko2gaq,
     $ kpsat,kpsst,krdxsp,kwater,kx1,kx10,kxt0,kxt,loph,losp,lsort,
     $ moph,mosp,mrgexs,mtb,mtbaq,narn1,narn2,narxt,nat,nbasp,nbaspd,
     $ nbaspx,nbt,nbtd,nbw,nchlor,ncmpr,nct,ndrs,ndrsd,ndrsx,ndrsr,
     $ ndrsrd,ndrsrx,nelect,nern1,nern2,ness,nessr,net,nfrn1,nfrn2,
     $ ngrn1,ngrn2,ngt,nhydr,nhydx,nlrn1,nlrn2,nlt,nmrn1,nmrn2,
     $ nmt,nord,no2gaq,noutpt,npchk,nphasx,npt,nrdxsp,nst,nsts,
     $ nstsr,ntpr,ntrymx,nttyo,nxrn1,nxrn2,nxt,omega,omeglg,prcinf,
     $ press,qbassw,qbseqc,qbye,qcnpre,qcntmp,qhawep,qmod,qoptmz,
     $ qpit75,qredox,qsspgb,qstart,qxknph,q6mode,rcnstv,rconst,
     $ rhsvec,rtcnst,screwd,sidrph,sidrsp,sigmam,sigmmo,smp100,tempc,
     $ tempk,tolbt,toldl,tolsat,tolsst,ubacmx,ubgamx,ulbeta,uldel,
     $ uphase,uspec,uzvec1,weight,wfac,xbar,xbarlg,xbarw,xbarwc,
     $ xbrwlc,xbrwlg,zchar,zchcu6,zchsq2,zvclg1,zvec1)
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
      if (ier .eq. 8) then
c
c       Go back and reduce the step size to avoid exceeding the
c       dimensioned limit on the iindx1 array (this also corresponds to
c       the dimensions of the Jacobian matrix). EQ6/path.f will go back
c       and cut the step size, if this is possible.
c
        ier = 180
        go to 999
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
      if (ier .eq. 10) then
c
c       Go back and reduce the step size to avoid exceeding the
c       supersaturation tolerance (tolsst). This is only done under
c       an appropriate set of conditions, so no further analysis
c       is required. EQ6/path.f will go back and cut the step size.
c
        go to 999
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
      if (ier .eq. 20) then
c
c       EQ6/eqphas.f hit the maximum number of tries to find the correct
c       phase without succeeding. Go back and let EQ6/path.f deal with
c       the situation. It may be able to resolve the problem by reducing
c       the step size.
c
        ier = 180
        go to 999
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
      if (ier.eq.30 .or. ier.eq.40) then
c
c       The calculation appears to be in a region of critical
c       instability in the ES phase assemblage (can't solve to within
c       specified tolerances with a certain phase or phases in or out
c       of the assemblage). Try to slide over it.
c
        if (nphasl .le. 0) then
c
c         Am not currently engaged in such a slide. Need to start
c         the process.
c
          if (npslmx .le. 0) then
c
c           This kind of sliding is inhibited.
c
            write (noutpt,1100)
            write (nttyo,1100)
 1100       format(/' * Warning - (EQ6/eqshel) Need to slide Xi',
     $      ' forward to get over a region of',/7x,'critical',
     $      ' instability in the ES phase assemblage. However, the',
     $      ' maximum',/7x,'number of steps for this process (npslmx)',
     $      ' is zero. Sliding of this kind',/7x,'is therefore',
     $      ' inhibited.')
            ier = 190
            go to 999
          else
c
c           Set up to start sliding.
c
            write (noutpt,1110)
 1110       format(/' Setting up to slide Xi forward to get over a',
     $      ' region of critical'/3x,'instability in the ES phase',
     $      ' assemblage.')
            qslmod = .true.
          endif
        endif
c
        if (nphasl .ge. npslmx) then
c
c         Check for the maximum number of tries sliding forward.
c
          write (noutpt,1120)
          write (nttyo,1120)
 1120     format(/' * Warning - (EQ6/eqshel) Have done the maximum',
     $    ' number of tries to',/7x,'slide over a region of critical',
     $    ' instability in the ES phase assemblage.')
          ier = 190
          go to 999
        endif
c
c       Slide Xi forward one increment. The increment gets progressively
c       larger with the number of tries.
c
        nphasl = nphasl + 1
        delxi = delxi + 3.**(nphasl - 1)*dlxmin
        write (noutpt,1130)
 1130   format(/' Trying to slide over a region of critical',
     $  ' instability',/7x,'in the ES phase assemblage:')
        write (noutpt,1140) nphasl,delxi
 1140   format(/3x,'Try ',i2,': delxi= ',1pe12.5,/)
        go to 300
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
      if (ier .eq. 50) then
c
c       The calculation appears to be in a region of critical redox
c       instability. Try to slide over it.
c
        if (nrdxsl .le. 0) then
c
c         Am not currently engaged in such a slide. Need to start
c         the process.
c
          if (nsslmx .le. 0) then
c
c           This kind of sliding is inhibited.
c
            write (noutpt,1200)
            write (nttyo,1200)
 1200       format(/' * Warning - (EQ6/eqshel) Need to slide Xi',
     $      ' forward to get over a region of',/7x,'critical redox',
     $      ' instability. However, the maximum number of steps',
     $      /7x,'for this process (nsslmx) is zero. Sliding of this',
     $      ' kind is',/7x,'therefore inhibited.')
            ier = 190
            go to 999
          else
c
c           Set up to start sliding.
c
            write (noutpt,1210)
 1210       format(/' Setting up to slide Xi forward to get over a',
     $      ' region of critical'/3x,'redox instability.')
            qslmod = .true.
          endif
        endif
c
        if (nrdxsl .ge. nsslmx) then
c
c         Check for the maximum number of tries sliding forward.
c
          write (noutpt,1220)
          write (nttyo,1220)
 1220     format(/' * Warning - (EQ6/eqshel) Have done the maximum',
     $    ' number of tries',/7x,'to slide over a region of critical',
     $    ' redox instability.')
          ier = 190
          go to 999
        endif
c
c       Slide Xi forward one increment. The increment gets progressively
c       larger with the number of tries.
c
        nrdxsl = nrdxsl + 1
        delxi = delxi + 3.**(nrdxsl - 1)*dlxmin
        write (noutpt,1230)
 1230   format(/' Trying to slide over a region of critical redox',
     $  ' instability:')
        write (noutpt,1240) nrdxsl,delxi
 1240   format(/3x,'Try ',i2,': delxi= ',1pe12.5,/)
        go to 300
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
      if (ier.eq.60 .or. ier.eq.70) then
c
c       The calculation appears to be in a region of critical
c       instability associated with solvent water. Go back and let
c       EQ6/path.f deal with the situation. It may be able to resolve
c       the problem by reducing the step size.
c
        ier = 180
        go to 999
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
      if (ier .eq. 80) then
c
c       EQ6/eqphas.f detected critical instability associated with the
c       aqueous activity coefficient model. Go back and let EQ6/path.f
c       deal with the situation. It may be able to at least partially
c       resolve the problem by reducing the step size. However, it is
c       likely that the reaction path is causing the activity
c       coefficient model to be extrapolated outside its range of
c       validity.
c
        ier = 180
        go to 999
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
      if (ier .eq. 100) then
c
c       The calculation was about to start with out-of-range values
c       for the iteration variables associated with the aqueous basis
c       species. Go back and let EQ6/path.f deal with the situation.
c       It may be able to resolve the problem by reducing the step size.
c       Alternatively, there may be some kind of programming error.
c
        ier = 180
        go to 999
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
      if (ier .eq. 110) then
c
c       The iteration ended with out-of-range values for the iteration
c       variables associated with the aqueous basis species. Go back and
c       let EQ6/path.f deal with the situation. It may be able to
c       resolve the problem by reducing the step size. Alternatively,
c       there may be some kind of programming error.
c
        ier = 180
        go to 999
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
      if (ier .eq. 150) then
c
c       The iteration ended without any useful diagnostics being
c       produced. Go back and let EQ6/path.f deal with the situation.
c       It may be able to resolve the problem by reducing the step size.
c       Alternatively, there may be some kind of programming error.
c
        ier = 180
        go to 999
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
      if (ier .eq. 0) then
        if (iopt(1) .eq. 2) then
c
c         Check to see that no significant numbers of moles of solids
c         were destroyed unexpectedly if computing a fluid-centered
c         flow-through open system model.
c
          do kcol = km1s,kmts
            if ( uzvec0(kcol)(1:5) .ne. ufixf(1:5) ) then
              if (zvclg0(kcol) .le. zklogu) then
                ns = iindxs(kcol)
                lxx = losp(ns)
                dlmoph = zvec0(kcol) - texp(lxx)
                if (dlmoph .gt. 0.) then
                  if (tlg(dlmoph) .gt. zklogu) then
                    ier = 170
                    mxx0 = zvec0(kcol)
c
c                   Calling sequence substitutions:
c                     uspec(ns) for unam48
c
                    call fmspnm(jlen,uspec(ns),uspn56)
                    write (noutpt,1300) uspn56(1:jlen),mxx0,mosp(ns),
     $              dlmoph
 1300               format(' Some of ',a,' was unexpectedly destroyed.',
     $              /5x,'Previous number of moles was ',1pe12.5,
     $              /5x,'Current number of moles is   ',e12.5,
     $              /5x,'Amount destroyed was ',e12.5,/21x,
     $              /3x,"That's too much. Will go back and first",
     $              ' transfer some of the current',/3x,'amount to the',
     $              ' physically removed system (PRS).')
                  endif
                endif
              endif
            endif
          enddo
c
          nplast = 0
c
          do kcol = kx1s,kxts
            ns = iindxs(kcol)
            np = ipndxs(kcol)
            if (np .ne. nplast) then
              nplast = np
              mold = 0.
c
              do krow = kcol,kxts
                np1 = ipndxs(krow)
                if (np1 .ne. np) go to 200
                mxx0 = zvec0(krow)
                mold = mold + mxx0
              enddo
  200         continue
c
              lold = tlg(mold)
              if (lold .gt. zklogu) then
                dlmoph = mold - moph(np)
                if (dlmoph .gt. 0.) then
                  if (tlg(dlmoph) .gt. zklogu) then
                    ier = 170
                    j2 = ilnobl(uphase(np))
                    write (noutpt,1300) uphase(np)(1:j2),mold,moph(np),
     $              dlmoph
                  endif
                endif
              endif
            endif
          enddo
          go to 999
        endif
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     The calculation finished with no problems.
c
      go to 999
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
  300 continue
c
c     Restore the kernel for the equilibrium sytem from the backup.
c     Undo any basis switches that may have been made by EQ6/optmzr.f.
c
c     Note: some aspects of the backup kernel are not needed here.
c     For example, the zvclg1 array will be recomputed further below
c     by the call to EQ6/ztaylr.f, overwriting the values restored from
c     the zvclgs array. However, a full restoration is done here for the
c     sake of completeness.
c
      if (qbseqc) then
        do kcol = 1,kbt
          nb = iindx1(kcol)
          ns = nbasp(nb)
          ns2 = nbasps(nb)
          if (ns2 .ne. ns) then
            call switch(adhfs,adhfsx,advfs,advfsx,axhfs,axhfsx,
     $      axlks,axlksx,axvfs,axvfsx,cdrs,cdrsx,eps100,ipch,ipchmx,
     $      ipcv,ipcvmx,jflag,jsflag,narn1,narxmx,nbasp,nbaspd,nbaspx,
     $      nb,nbt,nbtmax,nbw,ndrs,ndrsmx,ndrsx,ndrsr,ndrsrx,noutpt,
     $      ns2,nst,nstmax,ntprmx,nttyo,qbassw,qbswok,uspec)
          endif
        enddo
        qbseqc = .false.
        nord = nords
      endif
c
      km1 = km1s
      kmt = kmts
      kx1 = kx1s
      kxt = kxts
      kdim = kdims
c
      call copyia(nbasps,nbasp,nbt)
      call copyia(iindxs,iindx1,kdim)
      call copyia(ipndxs,ipndx1,kdim)
c
      call copyaa(zvclgs,zvclg1,kdim)
      call copyaa(acflgs,acflg,nst)
c
      xbarwc = xbarws
      xbrwlc = xbrwls
c
c     Reset the ixbasp and cjbasp arrays. The former is a flag
c     array, each member of which denotes whether the
c     thermodynamic activity of the corresponding basis species
c     is defined in terms of molality (= 0) or mole fraction (= 1).
c     The cjbasp array contains any site stoichiometric factors
c     associated with the operational basis species.
c
      call gibasp(cgexj,cjbasp,iern1,ixbasp,jern1,jern2,
     $ jetmax,jgext,narn1,narn2,nbasp,nbt,nbtmax,nern1,nern2,
     $ netmax,nphasx,nstmax)
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Slightly increase the value of reaction progress to try to slide
c     over a region of critical instability.
c
      xi1 = xi0 + delxi
c
c     Make a Taylor's series expansion of the z vector, applying
c     change limits. This provides a protected set of values for
c     the AE solver; i.e., a set not containing any values that
c     will cause the solver to fail in an unrecoverable fashion.
c
      qztayl = .true.
      call ztaylr(delxi,dzvc0,kdim,kmax,km1,kxt,nord,nrd1mx,
     $ qztayl,zklogu,zvclg0,zvclg1,zvec0,zvec1)
c
c     Save the new z vector expansion.
c
      call copyaa(zvclg1,zvclgs,kdim)
c
      if (.not.qcntmp .or. .not.qcnpre) then
c
c       Recompute the temperature and pressure. Then recompute the
c       thermodynamic and kinetic quantities which depend these
c       variables.
c
        ntpr0 = ntpr
        call tpadv(aadh,aadhh,aadhv,aaphi,abdh,abdhh,abdhv,
     $  abdoth,abdot,abdotv,adadhh,adadhv,adbdhh,adbdhv,adbdth,adbdtv,
     $  adh,adhfe,adhh,adhv,adhfs,adhfsd,advfe,advfs,advfsd,afcnst,
     $  al10,amu,aslm,aphi,aprehw,apresg,apresh,apx,avcnst,axhfe,axhfs,
     $  axhfsd,axlke,axlks,axlksd,axvfe,axvfs,axvfsd,bdh,bdhh,bdhv,
     $  bdot,bdoth,bdotv,dadhh,dadhv,dbdhh,dbdhv,dbdth,dbdtv,dhfe,dhfs,
     $  dhfsd,dvfe,dvfs,dvfsd,eact,ehfac,farad,hact,iact,iapxmx,iktmax,
     $  imchmx,imech,iopg,iopt,ipbtmx,ipch,ipchmx,ipcv,ipcvmx,ixrn1,
     $  ixrn2,jpfcmx,jpress,jptffl,jsol,jtemp,narxmx,narxt,narxth,nbasp,
     $  nbaspd,nbt,nbtd,nbtmax,ncmpr,ndrsr,ndrsrd,nmut,nmutmx,nopgmx,
     $  noptmx,noutpt,nptkmx,nptmax,nrct,nrctmx,nrk,nslt,nsltmx,nst,
     $  nstmax,ntpr,ntprmx,ntprt,nttkmx,nttyo,nweope,nwndpc,nxt,nxtmax,
     $  pmu,presg,presh,press,pressb,pressd,pslamn,ptk,rcnstv,rconst,rk,
     $  rkb,rtcnst,tempc,tempcb,tempcd,tempcu,tempk,time1,trkb,ttk,
     $  uphase,uspec,wfac,xhfe,xhfs,xhfsd,xi1,xlke,xlks,xlksd,xvfe,
     $  xvfs,xvfsd)
c
        qtrch = ntpr .ne. ntpr0
      endif
      go to 100
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
  999 continue
      end