	subroutine makefile(ch)
c
C	MAKEFILE 6, A PROGRAM TO SEARCH FOR LION ROARS IN TDSS.
C
C	at night, queue=waves1_pjk, it took 3hr31min to do 267 days
C		so (last day lt 15 RE is 7637) 38 hrs to do 2897 days,
C		1 event type
C
C	NOW SET UP TO DO MAGNETOSPHERE, RETURN IF TOO FAR AWAY, "SEARCH RRE"
C	WHOLE MISSION DONE IN MAGNETOSPHERE SEARCH, 3 B'S, TDSS AND FILL
C		OUTPUT LIST PUT IN [.WIND.PAPERS]WHISTLERSEARCH.DAT
C	CHANGED TO DO 3 E'S, TO CHANGE BACK AGAIN, LOOK FOR C3B not done yet
C		FFTMIN changed to 50 Hz, REQUIRE R21 GT .05
C	output format to for090 changed 8 May 2007, to correspond to TDSVIS
C	temporarily modified to make a histogram of low freq fourier power
C		modification commented out
C	In Nov, 2000, I found that including freq 2 = .9 Hz, gave
C		enormous powers, quite wrong
c
C	THIS WRITES OUTPUT DATA TO FOR069, FOR090, AND FOR037
C		NONE OF THESE IS ACCESS=APPEND
C		FOR090 IS THE PRINCIPAL OUTPUT RECORD
C		FOR037 IS A SUPPLEMENTAL OUTPUT RECORD, WITH DATA ON
C			THE REASON FOR CHOOSING THIS EVENT, ETC.
C		FOR079.DAT IS A RECORD OF EVENTS AND TEMPORARY DATA
C
C	THIS ROUTINE HAS A SPECIAL VERSION OF TDS_PHYS WHICH FINDS
C	AND REMOVES THE BZGLITCH, BY INTERPOLATING A STRAIGHT LINE
C	BETWEEN GOOD POINTS.  WT IS SET TO 0. IN MAIN PROGRAM ALSO.
C	THEN THE EVENT IS TESTED FOR SIGNAL ABOVE BACKGROUND (ISP = 1 IF SO)
C		(BX AND BY ONLY)   THE CRITERION IS 4 SUCCESSIVE SIGNALS
C		MORE THAN 2 STD'S ABOVE BACKGROUND.
C	AND IS TESTED FOR SMALL THIRD EIGENVALUE (IEV = 1 IF SMALL)
C
C	IF EITHER OF THESE CRITERIA IS SATISFIED, THEN
C		PEAK IN SPECTRUM (RELATIVE TO BACKGROUND) IS FOUND
C		AND FREQ NO., AND FREQ ARE WRITTEN TO FOR090.DAT
C		AND BANDWIDTH OF SPECTRUM IS FOUND
C
C	NMINF AND NMAXF ARE THE LIMIT FREQUENCY NUMBERS GIVEING
C		THE BANDWIDTH OF A PEAK
C	MINFREQ AND MAXFREQ ARE
C
C	CHECK OF DATA FLOW:  TDS_PHYS TAKES IN THE RAW (DIGITAL)
C	DATA AS NDATA(2048,4) AND CONVERTS IT TO PHYSICAL UNITS,
C	DATA(2050,4) AND TO VDATA(2050,4) WHICH IS THE SAME WITH
C	THE BZ glitch REMOVED.  XFGSE THEN DESPINS VDATA AND PUTS
C	IT INTO GDATA(2050,4).  THIS IS USED FOR INITIAL CALCULATION
C	OF THE EIGENVALUES OF THE MINIMUM VARIANCE MATRIX. THEN
C	XFORMVM TRANSFORMS GDATA TO THE MINIMUM VARIANCE SYSTEM,
C	WITH FIELDS XFDATA(2050,4)
C
	COMMON /VARMATX/ EVAL(3),EVECT(3,3)
	COMMON /PARTBLK/ XDATA(2050,4),XFDATA(2050,4),XGSE(2050,4),
     1		XRE,YRE,ZRE,SUNCLOCK,SPINRATE,SPSS
	COMMON /TDS_STATUS/ TDS_CHANNEL,IFIL,FILTER,IRX,ISPS,SPS
	COMMON /FRLIMITS/ FREQMIN,FREQMAX
	COMMON /BZGL/ IGL,NGL1,NGL2
	COMMON /EXTRA/ NBXBY,NDATA,DBSPEC,AVRB,STDB
	COMMON /HISTBLK/ HIST(14,4,100),FHIST(14),NHISTST,HISTINT
	INTEGER*4 FHIST
	REAL SFILTER(4),SPSSV(4)
	INTEGER*4 RCVR(4),ISPSSV(4),CHSV(4),IFILSV(4)
	integer*4 ch,ok,okt,OK1,OK2,SCETI4(2),NDATA(2048,4),NDATAT(2048)
	INTEGER*4 W_CHANNEL_CLOSE,W_EVENT,RET_SIZE,W_MESSAGES_OFF
	INTEGER*4 W_ITEM_I4,W_ITEM_R4,W_ITEM_R8,ITERM
	INTEGER*4 TDS_CHANNEL,ISRC,SUNCLOCK,ERTDAY
	INTEGER*4 ISOURCE(10),NO_EVT(4),ERT(2),YYYY,DD,hh,mm
	CHARACTER*120 JUNK
	REAL*8 SCET8,SCET8KP,SCETEND,DISTANCE,RXGSE,RYGSE,RZGSE,ERAD,BTIME
	REAL DBSPEC(1025,4),VDATA(2050,4),OBSFREQ(5),OBSBW(5),OBSPWR(5)
	REAL GDATA(2050,4)
	REAL DECIS(1025,2),RELSIG(1025,2)
	REAL AVRB(1025,4),STDB(1025,4)
C
C	REAL SPECTAVR(1025,4),SPECTSTD(1025,4),COUNTS(1025,4)
	REAL PWRAVR(4),PWRSTD(4),COUNTP(4)
C
	REAL ZCROSS(1024),Z1INT(1024),Z2INT(1024)
	REAL FREQ(1025),WT(2050)
	character*32 ITEM
	character*4 event
	DATA FHIST /1,2,3,4,5,10,20,30,60,100,200,300,600,1000/
	DATA SCET8 /0./
	DATA ERAD /6378.D00/
	DATA TWOPI /6.2831853/
	DATA P3TOT,P4TOT,P5TOT,P6TOT /4*0./
C	data event /'TDSS'/
	data event /'FILL'/
C	DATA SPECTAVR /4100*0./
C	DATA SPECTSTD /4100*0./
C	DATA COUNTS /4100*1.E-8/
	DATA FREQ /1025*937.5/		! TEMPORARY, SO IT DOESNT YELL
	DATA COUNTP /4*1.E-8/
	DATA PWRAVR /4*0./
	DATA PWRSTD /4*0./
	DATA INREAD /0/
	DATA IHEADER /0/
	DATA FREQSP /0./
	DATA IPROCESS /4/
	DATA IHIST /0/
	DATA RRESV /100./
	DATA NERROR /0/
C
	IFOUND = 0
C
	IF(INREAD.EQ.0) THEN
c	  OPEN(UNIT=49,FILE='FACX:[KELLOGG]FOR044.DAT;5',STATUS='OLD',
c     1		 READONLY)
	  OPEN(UNIT=49,FILE='[KELLOGG.WIND]BBACK2.DAT',STATUS='OLD',
     1		 READONLY)
	  READ(49,2233) JUNK
	  DO NTT = 1,4
	    DO NS = 1,1025
	      READ(49,*) FREQT,NNT,COUNTT,AVRT,STDT
	      STDB(NS,NNT) = STDT
	      AVRB(NS,NNT) = AVRT
	    ENDDO
c	    PRINT*,'2ND  READIN',AVRB(2,N),STDB(2,N)
C	    PRINT*,'LAST READIN',FREQT,NNT,COUNTT,AVRT,STDT
	    READ(49,2233) JUNK
	    PRINT*,JUNK
	  ENDDO
 2233	  FORMAT(A)
	  PRINT*,'NOISE DATA READ IN'
	  INREAD = 1
	  CLOSE(UNIT=49)
	ENDIF
C
C	WRITE HEADING ON SUMMARY FILES
C
	IF(IHEADER.EQ.0) THEN
	  WRITE(90,1091)
	  WRITE(90,1090)
	  WRITE(90,1091)
 1090	  FORMAT(5X,'DATE,TIME'6X'EVT NO.',' ERT','   GLT  '4X'PWR'
     1	  ,6X'RMS' 4X,'R21'3X'R31'3X'COSKB'3X'RRE','FREQSP ',
     2    '  BW  ','FREQRV ',' REV',3X,'fp',2X,'fce',4X,'beta',
     3	  'SPS')
	  WRITE(37,1091) 			! BLANK LINE
	  WRITE(37,2037)
 2037	  FORMAT('  EVT NO.',1X,'EVENT',3x,' DATE,TIME',4X,'P E ',4X,
     1     'CRITERIA',5X, 'f#',5X,'f Hz',7X,'BW',8X,'PWR',4X,'REVS',1X,
     2	    ' X RE',2X,'Y RE',2X,'Z RE')
	  WRITE(37,1091)
 1091	  FORMAT(' ')
	  IHEADER = 1
C
C		tail end for narrow printer at Vaughn
C
	  WRITE(91,1091)
	  WRITE(91,2090)
	  WRITE(91,1091)
 2090	  FORMAT('   EVT NO.',2X'RRE',' FREQSP ','  BW  ','FREQRV ',
     2    '  REV',3X,'fp',2X,'fce',3X,'beta',' SPS')
	  WRITE(38,1091) 			! BLANK LINE
	  WRITE(38,2038)
	  WRITE(38,1091)
 2038	  FORMAT('   EVT NO.',5X,'PKPWR',3X,'REVS',2X,
     2	    'X RE',2X,'Y RE',2X,'Z RE')
	ENDIF
C
C	if(ch.le.9) go to 100
C		WRITE(44,*) SCET8,SCETI4
C		DO N = 1,4
C		  DO NS = 1,1025
C		     SPECTAVR(NS,N) = SPECTAVR(NS,N)/COUNTS(NS,N)
C		     SPECTSTD(NS,N) = SPECTSTD(NS,N)/COUNTS(NS,N)
C		     SPECTSTD(NS,N) = SPECTSTD(NS,N) - SPECTAVR(NS,N)**2
C		     SPECTSTD(NS,N) = SQRT(AMAX1(SPECTSTD(NS,N),0.))
C		     WRITE(44,*) FREQ(NS),N,COUNTS(NS,N),SPECTAVR(NS,N)
C    1			,SPECTSTD(NS,N)
C		  ENDDO
C		  PWRAVR(N) = PWRAVR(N)/COUNTP(N)
C		  PWRSTD(N) = PWRSTD(N)/COUNTP(N)
C		  PWRSTD(N) = PWRSTD(N) - PWRAVR(N)**2
C		  PWRSTD(N) = SQRT(AMAX1(PWRSTD(N),0.))
C		  WRITE(44,*) N,COUNTP(N),PWRAVR(N),PWRSTD(N)
C	        ENDDO
C	print*, 'stop in statistics'
C	stop
C	END OF STATISTICS
c
	IDOEDOB = 1
C	IDOEDOB = 0 IS DO 3 E'S, OTHERWISE DO 3 B'S 	 ! not finished yet
C
 100	ok = w_event(ch,event)
C
C	CHECK FOR END OF RECORD
C
	if (ok.ne.1) then
	  if(ok.eq.82) then
	    ok = w_channel_close(ch)
	    return
	  endif
	  write(6,*) 'cannot open ',event, ', ok=', ok
	  PRINT*,'FIND EVENT ERROR NUMBER ',NERROR+1
	endif
C
C	END OF END OF RECORD CHECK
C
C	an effort to avoid program bombing
	IF (OK.NE.1) THEN
	  NERROR = NERROR+1
	  IF (NERROR.GT.10) RETURN
	  GO TO 100
	ELSE
	  NERROR = 0
	ENDIF
C
	OKT = W_MESSAGES_OFF(ch)
C
C
	ITEM = 'CHANNEL'
	ok = W_ITEM_I4(ch, item, TDS_CHANNEL, 1, ret_size)
	ITEM = 'EVENT_NUMBER'
	ok = W_ITEM_I4(ch, item, itemp, 1, ret_size)
C
C	print*,' '
C	print*,'new event, ch,no=',tds_channel,itemp
C	write(44,*) tds_channel,itemp
C
	IF(TDS_CHANNEL.LE.2.OR.TDS_CHANNEL.EQ.0) GO TO 100
C
	ITEM = 'SOURCE'
	ok = W_ITEM_I4(ch, item, IRX, 1, ret_size)
	IF(OK.NE.1.OR.IRX.EQ.0) GO TO 100
C	print*,'check tds_channel,irx ',tds_channel,irx
	ISOURCE(TDS_CHANNEL) = IRX
	LD = 4
C	LOAD X TO LD=1,Y TO LD=2,Z TO LD=3, OTHER FIELD TO LD=4
C
	IF(IRX.GT.6.AND.IDOEDOB.NE.0) LD = IRX - 6
        IF(IRX.LE.6.AND.IDOEDOB.EQ.0) LD = IRX - 3
	RCVR(LD) = IRX
	CHSV(LD) = TDS_CHANNEL
C
	IPROS = IPROCESS
	IPRC = IPROCESS
	IF(TDS_CHANNEL.EQ.3) THEN
	  DO N = 4,6
		ISOURCE(N) = 0
	  ENDDO
	  IFOUND = 1
	ENDIF
C
	IF(TDS_CHANNEL.LE.2) THEN
	  GO TO 100
	ELSE
	  ITEM = 'DATA'
	  ok1 = W_ITEM_I4(ch, item, NDATAT, 2048, ret_size)
	  DO NN = 1,2048
	    NDATA(NN,LD) = NDATAT(NN)
	  ENDDO
c	  FREQMIN = 0.
c	  FREQMIN = 3.6				! test comparison with xyz
C	  FREQMIN = 4.5				!
c	  FREQMAX = 938.
	  freqmin = 50.
	  freqmax = 10000.
	  ITEM = 'EVENT_NUMBER'
	  ok = W_ITEM_I4(ch, item, NO_EVT(LD), 1, ret_size)
C
	  ITEM = 'RX_SPEED'
	  OK = W_ITEM_I4(CH,ITEM,ISPS,1,RETURN_SIZE)
	  ISPSSV(LD) = ISPS
C
	  ITEM = 'RX_SPEED_R4'
	  OK = W_ITEM_R4(CH,ITEM,SPS,1,RETURN_SIZE)
	  SPSSV(LD) = SPS
ct	  IF(ISPS.NE.3) THEN
ct	    PRINT*,'WRONG SAMPLE RATE, = ',SPS
ct	    GO TO 100		! WRONG SAMPLE RATE
ct	  ENDIF
C
	  ITEM = 'RX_FILTER'
	  OK = W_ITEM_I4(CH,ITEM,IFIL,1,RETURN_SIZE)
	  IFILSV(LD) = IFIL
C
	  ITEM = 'RX_FILTER_R4'
	  OK = W_ITEM_R4(CH,ITEM,FILTER,1,RETURN_SIZE)
	  SFILTER(LD) = FILTER
C
	  item = 'SUN_ANGLE'
	  ok = w_item_I4(ch, item, sunclock, 1, return_size)
C
C	  TEST FOR END OF SEQUENCE
	  IF(TDS_CHANNEL.NE.6) GO TO 100
C
C	  this first call is to determine whether there is a glitch or
C	  not, and where it is (IGL)
C
	  IF(LD.NE.3) THEN
	    PRINT*,'LD WAS NOT 3, BUT',LD
	    LD = 3
	  ENDIF
	  CALL TDS_PHYS(CH,IPROS,NDATA(1,LD),VDATA(1,LD),DBSPEC(1,LD))
C
C		SET WEIGHTS TO ELIMINATE GLITCH
C
	  DO NG = 1,2048
	      WT(NG) = 1.
	  ENDDO
	  IF(IGL.EQ.0) THEN
	    NGL1 = 0
	    NGL2 = 0
	  ELSE
	    IF(NGL1*NGL2.NE.0) THEN
	      DO NG = NGL1,NGL2
	        WT(NG) = 0.
	      ENDDO
	    ENDIF
	  ENDIF
ct	print*,'after tds_phys, igl,ngl1,ngl2= ',igl,ngl1,ngl2
C		WEIGHTS ARE SET -- CASE OF GLITCH NEAR END NOT DONE
C			BUT SO FAR IT IS ALWAYS NEAR THE CENTER
	ENDIF
c	write(79,*)'read in event no.',ld,no_evt(ld)
c	write(79,*) 'ndata,1',ndata(1,1),ndata(1,2),ndata(1,3)
c	write(79,*) 'ndata,2',ndata(2,1),ndata(2,2),ndata(2,3)
c	write(79,*) 'vdata,1 ',vdata(1,1),vdata(1,2),vdata(1,3)
c	write(79,*) 'vdata,2 ',vdata(2,1),vdata(2,2),vdata(2,3)
C
C	NOW ALL CHANNELS ARE SUPPOSED TO HAVE BEEN LOADED IN
C
C	CHECK FOR 3 B CHANNELS
C
	I3E3B = 0
	DO N = 3,6
c	  print*,'3E check',n,ISOURCE(n),no_evt(n-2)
	  IF(ISOURCE(N).GT.6.AND.IDOEDOB.NE.0) I3E3B = I3E3B + 1
          IF(ISOURCE(N).LE.6.AND.IDOEDOB.EQ.0) I3E3B = I3E3B + 1
c	  print*,'now count channels eq ',I3E3B
	ENDDO
	IF(I3E3B.LT.3) THEN
    	  PRINT*,'NOT YET 3 CHANS, I3E3B.LT.3,=',I3E3B,' get another event'
	  GO TO 100
	ENDIF
C
C	CHECK THAT ALL CHANNELS ARE FULL AND HAVE SAME EVENT
C
	DO N = 1,4
c	  print*,'checking all channels,',isource(n+2)
	  IF(ISOURCE(N+2).EQ.0) GO TO 100
c	print*,no_evt(n),no_evt(1)
	  IF(NO_EVT(N).NE.NO_EVT(1)) GO TO 100
	ENDDO
C
	DO LD = 1,4
	  IRX = LD + 6				! 7,8,9,10 for B
	  IF(IDOEDOB.EQ.0) IRX = LD + 3		! 4,5,6,7  FOR E
C	  IF(LD.EQ.4) IRX = 4
	  IF(IRX.EQ.6.OR.IRX.EQ.10) IRX = 4
	  DO ITDS = 3,6
	    IF(ISOURCE(ITDS).EQ.IRX) TDS_CHANNEL = ITDS
	  ENDDO
	  ISPS = ISPSSV(LD)
	  SPS = SPSSV(LD)
	  FILTER = SFILTER(LD)
	  IFIL = IFILSV(LD)
	  ISPS = ISPSSV(LD)
	  CALL TDS_PHYS(CH,IPROS,NDATA(1,LD),XDATA(1,LD),DBSPEC(1,LD))
	ENDDO
c	print*,'returned from TDS_Phys'
C
C	statistics
C
C	DO N = 1,4
C	  DO NS = 1,1025
C	    IF(DBSPEC(NS,N).LT.(AVRB(NS,N) + 2.*STDB(NS,N))) THEN
C	      SPECTAVR(NS,N) = SPECTAVR(NS,N) + DBSPEC(NS,N)
C	      SPECTSTD(NS,N) = SPECTSTD(NS,N) + DBSPEC(NS,N)**2
C	      COUNTS(NS,N) = COUNTS(NS,N) + 1.
C	    ELSE
C	      PRINT*,'TOO BIG',N,NS,AVRB(NS,N),DBSPEC(NS,N)
C	    ENDIF
C	  ENDDO
C	  DO NS = 1,2048
C	    PWRAVR(N) = PWRAVR(N) + VDATA(NS,N)
C	    PWRSTD(N) = PWRSTD(N) + VDATA(NS,N)**2
C	    COUNTP(N) = COUNTP(N) + 1.
C	  ENDDO
C	ENDDO
C	end of statistics
C
CDIAG	PRINT*,'******START EVENT',NO_EVT1,NO_EVT,' *****'
	PRINT*,'******START EVENT',NO_EVT,' *****'
C
C	CALCULATE FREQUENCIES FOR DBSPEC
C
	ITEM = 'SLOW_RX_SPEED_R4'
	ok = W_ITEM_R4(ch, item, SPS, 1, ret_size)
	SPSS = SPS
ct	IF(ABS(SPS-1875.).GT.1.) GO TO 100
	DO N = 1,1025
	  FREQ(N) = (N-1)*SPS/2048.    ! FREQ(N) GOES WITH DBSPECT(N)
	  IF(FREQ(N).LT.FREQMAX) MAXFREQ = N
	ENDDO
	FUNDFR = FREQ(2)
C***   REMOVE LATER
ct	ITEM = 'EVENT_SCET_R8'
ct	ok = W_ITEM_R8(ch, item, SCET8, 1, ret_size)
	ITEM = 'EVENT_SCET'
	ok = W_ITEM_I4(ch, item, SCETI4, 2, ret_size)
C
	ITEM = 'WIND_ORBIT_R_R8'
	ok = W_ITEM_R8(ch, item, DISTANCE, 2, ret_size)
	edist = distance/6378.d00
c	if(edist.lt.100.) THEN
c	  PRINT*,'WIND IS WITHIN 100 RE'
c	  go to 100
c	ENDIF
	if(edist.gt.100.) THEN
	  PRINT*,'WIND IS BEYOND 100 RE, SKIP THIS DAY'
          ok = w_channel_close(ch)
	  RETURN
C	  go to 100
	ENDIF
C
c********** histogram of low freq powers
C
C	IHIST = 1
	IHIST = 0
	IF(IHIST.NE.1) GO TO 175
C
	histint = 1.
	nhistst = -90
	do irx = 1,4
	  do ifri = 1,14
	    ifr = fhist(ifri)
	    nhist = dbspec(ifr+1,irx)
C		range is -10 to 90 dB  ! maybe changed
	    nhist = nhist - nhistst + 1
	    nhist = max0(nhist,1)
	    nhist = min0(nhist,100)
	    hist(ifri,irx,nhist) = hist(ifri,irx,nhist) + 1.
          enddo
	enddo
c	write(69,69) no_evt(1),edist,sps,(dbspec(i,1),i=1,3),
c     1	 (dbspec(i,2),i=1,3),(dbspec(i,3),i=1,3),(dbspec(i,4),i=1,3)
c 69	format(i10,f6.1,f6.0,12f6.1)
 175	CONTINUE
ct	IF(1) GO TO 100
C
c********** end histogram
C
C	SELECTION CRITERIA
C
	ITEM = 'WIND_ORBIT_X(GSE)_R8'
	ok = W_ITEM_R8(ch, item, RXGSE, 1, ret_size)
	XRE = RXGSE/ERAD
	ITEM = 'WIND_ORBIT_Y(GSE)_R8'
	ok = W_ITEM_R8(ch, item, RYGSE, 1, ret_size)
	YRE = RYGSE/ERAD
	ITEM = 'WIND_ORBIT_Z(GSE)_R8'
	ok = W_ITEM_R8(ch, item, RZGSE, 1, ret_size)
	ZRE = RZGSE/ERAD
	RRE = SQRT(XRE**2 + YRE**2 + ZRE**2)
	IF(RRE.LT.10..AND.RRESV.GT.10.) WRITE(49,*) ' IN',SCET8
	IF(RRE.GT.10..AND.RRESV.LT.10.) WRITE(49,*) 'OUT',SCET8
	RRESV = RRE
	print*,'got to selection,xre,rre=',xre,rre
        if(xre.gt.0..and.rre.gt.25.) then
	    print*,'too far out, X,R =',XRE,RRE
	    ok = w_channel_close(ch)
	    return
	endif
	IF(RRE.GT.11.) GO TO 100
C

C	THE TEST FOR SIGNIFICANT SIGNAL POWER. For B, REQUIRE THAT 4
C	SUCCESSIVE SIGNALS BE 2. STDDEV'S ABOVE NOISE
C		CHANGED TO 1.65 STDDEV'S
C
C  	print*,'noise4',avrb(1,2),stdb(1,2),avrb(2,2),stdb(2,2)
C	print*,'noise ',avrb(3,2),stdb(3,2),avrb(4,2),stdb(4,2)
C
C	CALCULATE RMS FOR E, USING ONLY X AND Y, AS Z HAS GLITCHES
	IF(IDOEDOB.EQ.0) THEN
	  PX = 0.
	  PY = 0.
	  PZ = 0.
	  DO N = 1,2048
	    PX = PX + (XDATA(N,1)/41.1)**2
	    PY = PY + (XDATA(N,2)/3.79)**2
	    PZ = PZ + (XDATA(N,3)/2.17)**2
	  ENDDO
	  print*,'pxyz',px,py,pz
	  PX = SQRT((PX+PY)/2048.)
	ENDIF
	ISP = 0
C	NDCS = 1
C	IF(DBSPEC(2,1).GT.(AVRB(2,1)+2.5*STDB(2,1))) GO TO 200
C	IF(DBSPEC(2,2).GT.(AVRB(2,2)+2.5*STDB(2,2))) GO TO 200
C	NDCS = 2
C	IF(DBSPEC(3,1).GT.(AVRB(3,1)+2.5*STDB(3,1))) GO TO 200
C	IF(DBSPEC(3,2).GT.(AVRB(3,2)+2.5*STDB(3,2))) GO TO 200
	NTEST = 0
C	AT 1875 SPS, N=2 IS .9 HZ, N=3 IS 1.83 HZ, N=4 IS 3.66 HZ
	PRINT*,MAXFREQ, STDB(MAXFREQ,1)
C
	IF(IDOEDOB.NE.0) THEN
C	  test B data
	  PKLIM = 1.65
	  DO N = 5,MAXFREQ
	    DECIS(N,1) = (DBSPEC(N,1)-AVRB(N,1))/STDB(N,1)       ! BX
	    IF(DECIS(N,1).GT.PKLIM) THEN
  		NTEST = NTEST+1
		NDCS = N
		print*,'Dtest1',ntest,n,dbspec(n,1),avrb(n,1),decis(n,1)
		IF(NTEST.GT.3) GO TO 200
	    ELSE
		NTEST = 0
	    ENDIF
	  ENDDO
	ELSE
	  IF(PX.GT..005) GO TO 200
	ENDIF
C
        IF(IDOEDOB.NE.0) THEN
	  NTEST = 0
	  DO N = 5,MAXFREQ
	    DECIS(N,2) = (DBSPEC(N,2)-AVRB(N,2))/STDB(N,2)       ! BY
	    IF(DECIS(N,2).GT.PKLIM) THEN
  		NTEST = NTEST+1
		NDCS = N
C		print*,'Dtest2',ntest,n,dbspec(n,2),avrb(n,2),decis(n,2)
		IF(NTEST.GT.3) GO TO 200
	    ELSE
		NTEST = 0
	    ENDIF
	  ENDDO
	ENDIF
C
	GO TO 250
C
 200	ISP = 1			! THERE IS A SIGNIFICANT SIGNAL
 250	CONTINUE
C
C	CALCULATE VARIANCE MATRIX, EIGENVALUES, AND EIGENVECTORS IN GSE SYS,
C		AND TEST EIGENVALUE RATIO
C
C	TRANSFORM DATA TO GSE SYSTEM
C
	ITEM = 'SUN_ANGLE'
	ok = W_ITEM_I4(ch, item, SUNCLOCK, 1, ret_size)
	ITEM = 'WIND_SPIN_RATE_R4'
	ok = W_ITEM_R4(ch, item, SPINRATE, 1, ret_size)

C	print*,'spinrate,sunclock,sps',spinrate,sunclock,sps
	EANGLE =  -360.*(SUNCLOCK-14.)/4096. - 45. ! ANGLE SUN TO +EX AT END
	IF(EANGLE.LT.-180.) EANGLE = EANGLE + 360.
	IF(EANGLE.GT.180.)  EANGLE = EANGLE - 360.
	DANG = SPINRATE*360./SPS/TWOPI
	THANT = EANGLE + 3072.*DANG  ! ANGLE SUN TO +EX AT START 16nov99
C
C	EANGLE =  -360.*SUNCLOCK/4096. - 45.       ! ANGLE SUN TO +EX AT END
C	DANG = SPINRATE*360./SPS/TWOPI		  ! CHANGE PER SAMPLE
C	THANT = EANGLE + 2048.*DANG + 360.	  ! ANGLE SUN TO +EX AT MIDDLE??
C
	CALL XFGSE(XDATA,GDATA,2048,EANGLE,DANG)
c
c	write(79,*)'after xfgse',no_evt(1)
c	write(79,*) 'vdata,1 ',vdata(1,1),vdata(1,2),vdata(1,3)
c	write(79,*) 'vdata,2 ',vdata(2,1),vdata(2,2),vdata(2,3)
c	write(79,*) 'gdata,1 ',gdata(1,1),gdata(1,2),gdata(1,3)
c	write(79,*) 'gdata,2 ',gdata(2,1),gdata(2,2),gdata(2,3)
c
	IEV = 0
	CALL VMATRIXEB(GDATA,IDOEDOB,WT,2048)
	EVLIM = .2
C***
C	ETRACE = EVAL(1)+EVAL(2)+EVAL(3)
C	IF(ETRACE.NE.0.) WRITE(55,*) ETRACE,ALOG10(ETRACE)
C****
	IF((EVAL(3)/EVAL(1)).LT.EVLIM) IEV = 1
	IF(IEV.EQ.0.AND.ISP.EQ.0) GO TO 100
C
	PRINT*,'******START EVENT ANALYSIS',NO_EVT(1),SCETI4, ' *****'
C
C	DETERMINE PEAK SIGNAL, I.E. SIGNAL WHICH IS THE LARGEST NUMBER
C		OF STANDARD DEVIATIONS ABOVE BACKGROUND
C
c	print*,'in tds,nfdata,vdata',nfdata(2),vdata(2)
C	do ii = 1,2048
C	write(45,*) ii, (vdata(ii,lld),lld=1,4)
C	enddo
C
C	AT 1875 SPS, NLOW=3 IS 1.83 HZ, NLOW=4 IS 2.74 HZ
C
C	NLOW = MAX0(NDCS-12,3)
	NLOW = 5
	RMAX1 = 0.
	RMAX2 = 0.
	DO NS = NLOW,MAXFREQ-1
	  RELSIG(NS,1) = (DBSPEC(NS,1)-AVRB(NS,1))/STDB(NS,1)
	  IF(RELSIG(NS,1).GT.RMAX1) THEN
  		NFR1 = NS
		RMAX1 = RELSIG(NS,1)
C		print*,'pk test X',ns,dbspec(ns,1),avrb(ns,1),rmax1
	  ENDIF
	  RELSIG(NS,2) = (DBSPEC(NS,2)-AVRB(NS,2))/STDB(NS,2)
	  IF(RELSIG(NS,2).GT.RMAX2) THEN
  		NFR2 = NS
		RMAX2 = RELSIG(NS,2)
C		print*,'pk test Y',ns,dbspec(ns,2),avrb(ns,2),rmax2
	  ENDIF
	ENDDO
C
	PRINT*,'PEAK FREQS, X,Y', NFR1,FREQ(NFR1),NFR2,FREQ(NFR2)
C
C	NOW GO BACKWARD AND FORWARD FROM THE PEAK UNTIL THE SIGNAL FALLS
C	BELOW BACKGROUND + ONE STANDARD DEVIATION
C	CHANGE, 22 MAY 2002, TO BE EITHER THAT OR 20 DB BELOW PEAK, TO
C	ALLOW FOR LEAKAGE
C
c	print*,'start back and for,maxfreq=',maxfreq
c	print*,'max1,2,nfr1,2',rmax1,rmax2,nfr1,nfr2
	NBXBY = 1
	IF(RMAX2.GT.RMAX1) NBXBY=2
	NFMAX = NFR1
	IF(RMAX2.GT.RMAX1) NFMAX = NFR2
	NMINF = 5
	NMAXF = MAXFREQ
	RELLIM1 = AMAX1(1.,RMAX1-20./STDB(NFR1,1))
	RELLIM2 = AMAX1(1.,RMAX2-20./STDB(NFR2,2))
	IF(RMAX1.GT.RMAX2) THEN
	  DO NS = NFR1,MAXFREQ
c	    print*,'relsig1',ns,freq(ns),nminf,nmaxf,relsig(ns,1)
	    IF(RELSIG(NS,1).LT.RELLIM1) THEN
		NMAXF = NS
		GO TO 210
	    ENDIF
	  ENDDO
	ELSE
c	    print*,'relsig',ns,freq(ns),nminf,nmaxf,relsig(ns,1)
c	    print*,'relsig,nfr2,maxfreq',nfr2,maxfreq
	  NFR2 = MAX0(NFR2,5)
	  DO NS = NFR2,MAXFREQ
c	    print*,'relsig2',ns,freq(ns),nminf,nmaxf,relsig(ns,1)
C	    IF(RELSIG(NS,2).LT.1.) THEN
	    IF(RELSIG(NS,2).LT.RELLIM2) THEN
		NMAXF = NS
		GO TO 210
	    ENDIF
	  ENDDO
	ENDIF
C
 210	CONTINUE
	IF(RMAX1.GT.RMAX2) THEN
	  DO NS = NFR1,5,-1
C	    IF(RELSIG(NS,1).LT.1.) THEN
	    IF(RELSIG(NS,1).LT.RELLIM1) THEN
		NMINF = NS
		GO TO 220
	    ENDIF
c	    print*,'relsig1',ns,freq(ns),nminf,nmaxf,relsig(ns,1)
	  ENDDO
	ELSE
	  DO NS = NFR2,5,-1
c	    print*,'relsig2',ns,freq(ns),nminf,nmaxf,relsig(ns,1)
C	    IF(RELSIG(NS,2).LT.1.) THEN
	    IF(RELSIG(NS,2).LT.RELLIM2) THEN
		NMINF = NS
		GO TO 220
	    ENDIF
	  ENDDO
	ENDIF
 220	CONTINUE
C	print*,'rellim1,2',rellim1,rellim2
C
	PRINT*, 'PEAK EDGES',NMINF,NMAXF,FREQ(NMINF),FREQ(NMAXF)
c	print*,'minf,peakfs,maxf',nminf,nfr1,nfr2,nmaxf
c	print*,'now calculate power from',nminf,' to',nmaxf
C
	NMINF = MAX0(NMINF,5)
	DO N = 1,4
	  OBSFREQ(N) = 0.
	  OBSBW(N) = 0.
	  OBSPWR(N) = 0.
	  SCOUNT = 1.E-12
	  DO NS = NMINF,NMAXF
	    IF(DBSPEC(NS,N).GT.(AVRB(NS,N) + 1.65*STDB(NS,N))) THEN
	      SIGPWR = 10.**(.1*DBSPEC(NS,N)) - 10.**(.1*AVRB(NS,N))
	if(sigpwr.gt.1.) print*,'obs',n,ns,dbspec(ns,n),avrb(ns,n)
	      OBSFREQ(N) = OBSFREQ(N) + FREQ(NS)*SIGPWR
	      OBSBW(N) = OBSBW(N) + (FREQ(NS)**2)*SIGPWR
	      SCOUNT = SCOUNT + SIGPWR
c	print 9876,n,ns,freq(ns),sigpwr,dbspec(ns,n),avrb(ns,n),stdb(ns,n),
c     1		dbspec(ns,n)-avrb(ns,n)-1.8*stdb(ns,n)
c 9876	format(i4,i6,f8.1,e12.3,f8.2,f8.2,f8.2,f8.2)
	    ENDIF
	  ENDDO
	  OBSFREQ(N) = OBSFREQ(N)/SCOUNT
	  OBSBW(N) = OBSBW(N)/SCOUNT - OBSFREQ(N)**2
	  OBSBW(N) = SQRT(AMAX1(OBSBW(N),0.))
C	  OBSPWR(N) = SCOUNT*FUNDFR
	  OBSPWR(N) = SCOUNT
	ENDDO
	OBSPWR(5) = OBSPWR(1)+OBSPWR(2)
	OBSFREQ(5) = (OBSPWR(1)*OBSFREQ(1)+OBSPWR(2)*OBSFREQ(2))
     1		/OBSPWR(5)
     	OBSBW(5) = (OBSPWR(1)*OBSBW(1)+OBSPWR(2)*OBSBW(2))/OBSPWR(5)
	BW = OBSBW(5)
	FREQSP = OBSFREQ(5)
c	do i = 1,5
c	  print*, 'pwr',NO_EVT(1),OBSFREQ(i),OBSBW(i),OBSPWR(i)
c	enddo
C	WRITE(36,*) SCET8,NO_EVT(1),OBSFREQ(5),OBSBW(5),OBSPWR(5)
c************
c	IWRT = 0
c	IF(IWRT.EQ.1.AND.NO_EVT(1).EQ.6151657) THEN
c	  do n = 1,2048
c	    write(64,*) n,xdata(n,1),xdata(n,2),xdata(n,3),wt(n)
c	  enddo
c	  stop
c	ENDIF
c************
C
C	PRODUCE FILTERED DATA
C		NOT USED AT PRESENT
C
C	CALL XFGSE(XDATA,GDATA,2048,EANGLE,DANG)
c
c	write(79,*)'after filtered data',ld,no_evt(ld)
c	write(79,*) 'ndata,1',ndata(1,1),ndata(1,2),ndata(1,3)
c	write(79,*) 'ndata,2',ndata(2,1),ndata(2,2),ndata(2,3)
c	write(79,*) 'vdata,1 ',vdata(1,1),vdata(1,2),vdata(1,3)
c	write(79,*) 'vdata,2 ',vdata(2,1),vdata(2,2),vdata(2,3)
C
C	ITEMS BELONGING TO TDS EVENT
C
	ITEM = 'SOURCE'
	ok = W_ITEM_I4(ch, item, ISRC, 1, ret_size)
	ITEM = 'EVENT_NUMBER'
	ok = W_ITEM_I4(ch, item, NO_EVT, 1, ret_size)
	ITEM = 'EVENT_SCET'
	ok = W_ITEM_I4(ch, item, SCETI4, 2, ret_size)
	ITEM = 'EVENT_SCET_R8'
	ok = W_ITEM_R8(ch, item, SCET8, 1, ret_size)
C	dds = scet
	ITEM = 'SLOW_RX_SPEED_R4'
	ok = W_ITEM_R4(ch, item, SPS, 1, ret_size)
   	SPSS = SPS
	ITEM = 'SUN_ANGLE'
	ok = W_ITEM_I4(ch, item, SUNCLOCK, 1, ret_size)
	ITEM = 'EVENT_TM_SCET_I4'
	ok = W_ITEM_I4(ch, item, ERT, 2, ret_size)
	ERTDAY = MOD(ERT(1),100)
C
	EANGLE =  -360.*SUNCLOCK/4096. - 45.       ! ANGLE SUN TO +EX AT END
	DANG = SPINRATE*360./SPS/TWOPI		  ! CHANGE PER SAMPLE
	THANT = EANGLE + 2048.*DANG + 360.	  ! ANGLE SUN TO +EX AT MIDDLE
C
C	TRANSFORM TO VARIANCE MATRIX EIGENSYSTEM
C
	N1 = 1
	N2 = 2048
	IF(IGL.NE.0) THEN
C	  N1 = MAX0(IGL-57,1)
C	  N2 = MIN0(IGL+24,2048)
	  N1 = NGL1
	  N2 = NGL2
	ENDIF
	  PRINT*,'IGL,N1,N2',IGL,N1,N2
	NSYS = 0
	CALL XFORMVM(NSYS,GDATA,XFDATA,WT)
c
c	write(79,*)'after xformvm'
c	write(79,*) 'gdata,1',gdata(1,1),gdata(1,2),gdata(1,3)
c	write(79,*) 'gdata,2',gdata(2,1),gdata(2,2),gdata(2,3)
c	write(79,*) 'xfdata,1 ',xfdata(1,1),xfdata(1,2),xfdata(1,3)
c	write(79,*) 'xfdata,2 ',xfdata(2,1),xfdata(2,2),xfdata(2,3)
C
C	print*,' gdata1', gdata(1,1), gdata(2,1), gdata(3,1)
C	print*,'xfdata1',xfdata(1,1),xfdata(2,1),xfdata(3,1)
C	print*,'xfdata2',xfdata(1,2),xfdata(2,2),xfdata(3,2)
C
C	WTCOUNT = 0.
C	DO N = 1,1024
C	  WTCOUNT = WTCOUNT + WT(N)
C	ENDDO
C	AXMAJOR = EVAL(1)/WTCOUNT
C	AXMINOR = EVAL(2)/WTCOUNT
C
	ITEM = 'EVENT_EOE_R8'
	ok = W_ITEM_R8(ch, item, SCETEND, 1, ret_size)
C
C	ITEMS BELONGING TO CDF DATA
C
	ITEM = 'WIND_MFI_BX(GSE)_R4'
	ok = W_ITEM_R4(ch, item, BX, 1, ret_size)
	ITEM = 'WIND_MFI_BY(GSE)_R4'
	ok = W_ITEM_R4(ch, item, BY, 1, ret_size)
c
	ITEM = 'WIND_MFI_SCET_R8'
	ok = W_ITEM_R8(ch, item, BTIME, 1, ret_size)
c
	ITEM = 'WIND_MFI_BZ(GSE)_R4'
	ok = W_ITEM_R4(ch, item, BZ, 1, ret_size)
	ITEM = 'WIND_MFI_BPHI(GSE)_R4'
	ok = W_ITEM_R4(ch, item, AZMAG, 1, ret_size)
	ITEM = 'WIND_MFI_BMAG_R4'
	ok = W_ITEM_R4(ch, item, BMAG, 1, ret_size)
	print*,'Mag Field X,Y,Z,M',BX,BY,BZ,BMAG
c		bad mag data
C	IF(BMAG.GT.350.) GO TO 100
	IF(BMAG.GT.1.E6) GO TO 100
c
	ITEM = 'EVENT_SCET_R8'
	ok = W_ITEM_R8(ch, item, SCET8KP, 1, ret_size)
	call w_ur8_to_ymd(scet8kp,yyyy,mon,dd,hh,mm,ss,ms)
C
	ITEM = 'WIND_3DP_E_TEMP_R4'
	ok = W_ITEM_R4(ch, item, TEMPE, 1, ret_size)
	ITEM = 'WIND_3DP_ION_TEMP_R4'
	ok = W_ITEM_R4(ch, item, TEMPI, 1, ret_size)
	ITEM = 'WIND_3DP_ION_DENSITY_R4'
	ok = W_ITEM_R4(ch, item, DENS, 1, ret_size)
	ITEM = 'WIND_3DP_ION_VX(GSE)_R4'
	ok = W_ITEM_R4(ch, item, VX, 1, ret_size)
	ITEM = 'WIND_3DP_ION_VY(GSE)_R4'
	ok = W_ITEM_R4(ch, item, VY, 1, ret_size)
	ITEM = 'WIND_3DP_ION_VZ(GSE)_R4'
	ok = W_ITEM_R4(ch, item, VZ, 1, ret_size)
C
	ITEM = 'WIND_SPIN_RATE_R4'
	ok = W_ITEM_R4(ch, item, SPINRATE, 1, ret_size)
	COSKB = (BX*EVECT(1,3)+BY*EVECT(2,3)+BZ*EVECT(3,3))/BMAG
C
C	RESET CHANNEL POSITION TO TDS EVENT
C
	call w_channel_position(ch,scetend)
C
C	CALCULATE NUMBER OF TURNS THE VECTOR MAKES IN THE VM SYSTEM
C
	REVS1 = 0.
	REVS2 = 0.
	IF(N2-N1.LT.90) THEN		      ! GLITCH IN MIDDLE
	    CALL COUNT_REV(XFDATA(1,1),XFDATA(1,2),1,N1,REVS1)
	    CALL COUNT_REV(XFDATA(1,1),XFDATA(1,2),N2,2048,REVS2)
	    COUNT = N1 + 2048-N2
	    REVS = REVS1 + REVS2
	ELSE				      ! GLITCH AT ENDS
	    CALL COUNT_REV(XFDATA(1,1),XFDATA(1,2),N1,N2,REVS)
	    COUNT = N2-N1+1
	ENDIF
	PRINT*,'COUNT,REVS1,REVS2,REVS',COUNT,REVS1,REVS2,REVS
	IF(COSKB.LT.0.) REVS = -REVS
	FREQR = ABS(REVS)*FUNDFR
C
C
	NFR12 = NFR1
	IF(NBXBY.EQ.2) NFR12 = NFR2
	N = MAX0(NFR12,3)
	WRITE(37,1037),NO_EVT(1),EVENT(1:1),SCETI4,ISP,IEV,
     1	DECIS(N-2,NBXBY),DECIS(N-1,NBXBY),DECIS(N,NBXBY),NFR12,
     2	OBSFREQ(5),OBSBW(5),OBSPWR(5),revs,XRE,YRE,ZRE
 1037	FORMAT(I10,A2,I10,I9,2I2,3F5.1,I5,3E11.3,F6.1,3F6.1)
 1038	FORMAT(I10,E11.3,F6.1,3F6.1)
C
C	TAIL END FOR PRINTER AT VAUGHN
C
	WRITE(38,1038),NO_EVT(1),OBSPWR(5),revs,XRE,YRE,ZRE
C
C	IF(NO_EVT(1).EQ.5895462.OR.NO_EVT(1).EQ.5978883) THEN
C	IF(NO_EVT(1).EQ.6581993.OR.NO_EVT(1).EQ.6738573) THEN
c	IF(NO_EVT(1).EQ.6031461) THEN
C	IF(NO_EVT(1).EQ.5847961) THEN
C	IF(NO_EVT(1).EQ.5432117) THEN
C	IF(NO_EVT(1).EQ.6149994) THEN
C	IF(NO_EVT(1).EQ.6151657) THEN
C	IF(NO_EVT(1).EQ.6159643) THEN
C	IF(NO_EVT(1).EQ.6151306) THEN
c	IF(NO_EVT(1).EQ.6158946) THEN
C	IF(SCETI4(2).EQ.143605) THEN
	IF(NO_EVT(1).EQ.11545057) THEN
	  ITERM = 3
	  ITERM = -2
	  CALL SUMMPLOT(ITERM,CH,1,2048)
	  STOP
	ENDIF
C
C	IF(1) GO TO 100
C
	IF(IDOEDOB.NE.0) THEN
	  PX = (EVAL(1)+EVAL(2))/2048.          ! MEAN SQUARE OF FIELD (TRANSVERS)
	  PX = SQRT(PX)
	ENDIF
	R21 = EVAL(2)/EVAL(1)
	R31 = EVAL(3)/EVAL(1)
	IF(R21.LT..05.AND.IDOEDOB.NE.0) GO TO 100  	! GLITCHES?
C	if(px.gt.10.**-2.5) write(77,*) no_evt(1),px
C	if(px.gt.10.**-1.25) write(77,*) 'n,px',no_evt(1),px
C
	DENS = AMAX1(DENS,0.)
	FP = 9.*SQRT(DENS)			  ! PLASMA FREQ IN KHZ
	FCE = .028*BMAG				  ! e CYCLO FREQ IN KHZ
	BETA = .402*DENS*(TEMPE+TEMPI)/BMAG**2
C
C	AVRPER = 1.E-6
C	IF(ZCNT2.NE.0.) AVRPER = 2048./SPS/ZCNT2
C	FREQKHZ = .001/AVRPER
C
C	PLASMA PARAMETERS, ETC.

C	   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)
C
c	print date, time, event no., freq, Px, Py, Vy/Vx, angles of
c		antenna,B, phiB, mag B or fce, fp
c
C	at present 1011 is 116 characters, now 127
C
C	  WRITE(90,1011) sceti4,ERTDAY,EVENT(1:1),NO_EVT(1),IGL,
	  WRITE(90,1011) sceti4,NO_EVT(1),ERTDAY,EVENT(1:1),IGL,
     1	   OBSPWR(5),PX,R21,R31,COSKB,RRE,FREQSP,BW,FREQR,REVS,
     1	   FP,FCE,BETA,ISPS
 1011   format(I10,I7,I10,I3,A2,I5,2E10.3,F6.3,F6.3,F7.3,f5.1,F6.1,F6.1,
     1    F6.1,F7.1,F6.1,F6.3,F7.3,I2)
C
C		tail end for narrow printer at Vaughn
C
	  WRITE(91,2011) NO_EVT(1),RRE,FREQSP,BW,FREQR,REVS,
     1	   FP,FCE,BETA,ISPS
 2011   format(I10,f5.1,F7.1,f6.1,F6.1,F7.1,F6.1,F6.3,F7.3,I2)
C
	IF(OK.NE.82) GO TO 100
c		   WRITE(46,*) SCETI4
C		STATISTICS
C		DO N = 1,4
C		  DO NS = 1,1025
C		     SPECTAVR(NS,N) = SPECTAVR(NS,N)/COUNTS(NS,N)
C		     SPECTSTD(NS,N) = SPECTSTD(NS,N)/COUNTS(NS,N)
C		     SPECTSTD(NS,N) = SPECTSTD(NS,N) - SPECTAVR(NS,N)**2
C		     SPECTSTD(NS,N) = SQRT(AMAX1(SPECTSTD(NS,N),0.))
C		     WRITE(46,*) FREQ(NS),N,SPECTAVR(NS,N),SPECTSTD(NS,N)
C		  ENDDO
C		  PWRAVR(N) = PWRAVR(N)/COUNTP(N)
C		  PWRSTD(N) = PWRSTD(N)/COUNTP(N)
C		  PWRSTD(N) = PWRSTD(N) - PWRAVR(N)**2
C		  PWRSTD(N) = SQRT(AMAX1(PWRSTD(N),0.))
C		  WRITE(46,*) N,PWRAVR(N),PWRSTD(N)
C	        ENDDO
C	END OF STATISTICS
	return
	end
	SUBROUTINE XFORMVM(NSYS,XINP,XFDATA,WT)
C
C	THIS TRANSFORMS THE ELECTRIC FIELD, XINP,INTO THE VARIANCE MATRIX
C	EIGENSYSTEM, 1 = LARGEST EIGENVALUE.  XFDATA ARE THE TRANS-
C	FORMED FIELDS
C
	INTEGER*4 MAJOR,MINOR,S_SCET(2),NSYS
C	COMMON /PARTBLK/ XDATA(2050,4),XFDATA(2050,4),XGSE(2050,4),
C     1		XRE,YRE,ZRE,SUNCLOCK,SPINRATE,SPSS
C	common /headblk/ major,minor,s_scet,nsys
	COMMON /VARMATX/ EVAL(3),EVECT(3,3)
	INTEGER*4 SUNCLOCK
	REAL XINP(2050,4), XTEMP(2050,4),XFDATA(2050,4),WT(2050)
C
C	EVECT(I,J) IS THE Ith COMPONENT OF THE Jth EIGENVECTOR
C
C	VMATRIX CALCULATES THE VARIANCE MATRIX OF XGSE, AND RETURNS
C	EIGENVALUES IN COMMON /VARMATX/EVAL, AND EIGENVECTORS IN EVECT
C
C	MAKE A COPY OF THE INPUT MATRIX TO WORK ON
C
	DO J = 1,4
 	  DO N = 1,2048
		XTEMP(N,J) = XINP(N,J)
	  ENDDO
	ENDDO
C
	CALL VMATRIXEB(XTEMP,IDOEDOB,WT,2048)
C
C	IF(N2-N1.LT.90) THEN
C	    CALL VMATRIX(XTEMP,N1,N2)
C	ELSE
C	    CALL VMATRIX(XTEMP,N1,N2)
C	ENDIF
C
C	WRITE(79,*) ' '
C	WRITE(79,*) 'XFORMVM CALLED--PUT FIELD DATA INTO VAR MX SYSTEM, NSYS=2'
C
C	NOW EVECT ARE EIGENVECTORS IN THE XINP SYSTEM
C	XFDATA(N,1) CORRESPONDS TO LARGEST EIGENVALUE,N=COMPONENT
C
	DO N = 1,2048
	  XFDATA(N,1) = XTEMP(N,1)*EVECT(1,1) + XTEMP(N,2)*EVECT(2,1) +
     1		XTEMP(N,3)*EVECT(3,1)
	  XFDATA(N,2) = XTEMP(N,1)*EVECT(1,2) + XTEMP(N,2)*EVECT(2,2) +
     1		XTEMP(N,3)*EVECT(3,2)
	  XFDATA(N,3) = XTEMP(N,1)*EVECT(1,3) + XTEMP(N,2)*EVECT(2,3) +
     1		XTEMP(N,3)*EVECT(3,3)
	ENDDO
C
C	CHECK TRANSFORMATION.  IN XTEMP, COMPONENT IS 2ND INDEX, IN
C	EVECT THE FIRST INDEX IS COMPONENT.  T1,T2,T3 ARE THE
C	COMPONENTS IN THE EIGENVECTOR SYSTEM, N IS EIGENVECTOR NO.
C
C	DO N = 1,3
C	  T1 = EVECT(1,N)*EVECT(1,1) + EVECT(2,N)*EVECT(2,1) +
C     1		EVECT(3,N)*EVECT(3,1)
C	  T2 = EVECT(1,N)*EVECT(1,2) + EVECT(2,N)*EVECT(2,2) +
C     1		EVECT(3,N)*EVECT(3,2)
C	  T3 = EVECT(1,N)*EVECT(1,3) + EVECT(2,N)*EVECT(2,3) +
C     1		EVECT(3,N)*EVECT(3,3)
C	  PRINT*,'CHECK',N,T1,T2,T3
C	ENDDO
C
C	DO N = 1,3
C	  T1 = EVECT(1,N)*EVECT(1,1) + EVECT(2,N)*EVECT(2,1) +
C     1		EVECT(3,N)*EVECT(3,1)
C	  T2 = EVECT(1,N)*EVECT(1,2) + EVECT(2,N)*EVECT(2,2) +
C     1		EVECT(3,N)*EVECT(3,2)
C	  T3 = EVECT(1,N)*EVECT(1,3) + EVECT(2,N)*EVECT(2,3) +
C     1		EVECT(3,N)*EVECT(3,3)
C	  PRINT*,'CHECK',N,T1,T2,T3
C	ENDDO
C
C	WRITE(79,*) 'IN SYSTEM,',NSYS,' EIGENVALUES:'
C	WRITE(79,*)  EVAL
C	WRITE(79,*) 'EIGENVECTORS IN COLUMNS BELOW EIGENVALUES'
C	WRITE(79,*)(EVECT(1,I),I=1,3)
C	WRITE(79,*)(EVECT(2,I),I=1,3)
C	WRITE(79,*)(EVECT(3,I),I=1,3)
C
	NSYS = 2
C
	RETURN
	END
	SUBROUTINE XFGSE(XDATA,XGSE,NMEAS,EANGLE,DANG)
C
C	THIS TRANSFORMS THE FIELD INTO THE GSE SYSTEM
C	THE INPUT IS THE FIELD IN THE SPACECRAFT ANTENNA
C	SYSTEM IN XDATA, THE OUTPUT, IN XGSE, IS THE FIELD IN
C	THE GSE SYSTEM.  NOTE THAT THE S/C IS UPSIDE DOWN, SO THAT IF
C	+EX POINTS AT THE SUN (ANG=0) THEN +EY POINTS IN THE - Y (GSE)
C	DIRECTION
C
	INTEGER*4 MAJOR,MINOR,S_SCET(2),NSYS
	INTEGER*4 SUNCLOCK
C	COMMON /PARTBLK/ XDATA(2050,4),XFDATA(2050,4),XGSE(2050,4),
C     1		XRE,YRE,ZRE,SUNCLOCK,SPINRATE,SPSS
	common /headblk/ major,minor,s_scet,nsys
	COMMON /VARMATX/ EVAL(3),EVECT(3,3)
	REAL XDATA(2050,4),XGSE(2050,4)
	DATA TWOPI /6.2831853/
C
C	  THE FIELDS ARE IN THE ANTENNA SYSTEM
C	  TRANSFORM THEM TO THE GSE SYSTEM, EX, EY, EZ, BY ROTATING
C	  X AND Y, and INVERTING  Z gse is parallel to Z ant already,
C	   but opposite
C
	NSYS = 3
C	WRITE(79,*) ' '
C	WRITE(79,*) 'XFGSE CALLED--FIELD DATA PUT INTO GSE SYSTEM, NSYS=3'
C
C	ANGLE =  -360.*SUNCLOCK/4096. - 45.       ! ANGLE SUN TO +EX AT END
C	DANG = SPINRATE*360./SPSS/TWOPI		  ! CHANGE PER SAMPLE
C	ANGLE = EANGLE + NMEAS*DANG		  ! ANGLE SUN TO +EX AT START
	ANGLE = EANGLE + (NMEAS+1024)*DANG	  ! ANGLE SUN TO +EX AT START
	DO N = 1,NMEAS
		ANGLE = ANGLE - DANG
	        SINANG = SIND(ANGLE)
	        COSANG = COSD(ANGLE)
		XGSE(N,1) = XDATA(N,1)*COSANG + XDATA(N,2)*SINANG
		XGSE(N,2) =-XDATA(N,2)*COSANG + XDATA(N,1)*SINANG
		XGSE(N,3) = -XDATA(N,3)
	ENDDO
c	write(79,*) 'angles in xfgse',eangle,dang
c	write(79,*) 'before,1',xdata(1,1),xdata(1,2),xdata(1,3)
c	write(79,*) 'before,2',xdata(2,1),xdata(2,2),xdata(2,3)
c	write(79,*) 'after,1 ',xgse(1,1),xgse(1,2),xgse(1,3)
c	write(79,*) 'after,2 ',xgse(2,1),xgse(2,2),xgse(2,3)
C
C	NOW XGSE ARE IN THE GSE SYSTEM
C
	RETURN
	END
      SUBROUTINE SORTN(IXS,NS)
C
      REAL IXS(1),IXT
      INTEGER INDX(1),INDT
C
C     ORDER X COORDS IN DECREASING ORDER
C
      DO 11 N = 1,NS-1
      N1 = N + 1
      DO 12 M = N1,NS
      IF((IXS(M)-IXS(N)).LT.0.) GO TO 12
C     EXCHANGE
      IXT = IXS(N)
      IXS(N) = IXS(M)
      IXS(M) = IXT
c      INDT = INDX(N)
c      INDX(N) = INDX(M)
c      INDX(M) = INDT
   12 CONTINUE
   11 CONTINUE
      RETURN
      END
	SUBROUTINE COUNT_REV(FX,FY,N1,N2,REVS)
C
C	COUNTS NUMBER OF REVOLUTIONS OF THE VECTOR FX,FY
C	WHICH HAS NPT SAMPLES
C
	REAL FX(1),FY(1)
C
C	PRINT*,'COUNT_REV CALLED,N1,N2',N1,N2
C	PRINT*,'FIRST SAMPLES',FX(1),FY(1)
C	PRINT*,'LAST SAMPLES',FX(1024),FY(1024)
	ANGTOT = 0.
	ANGLESV = ATAN2D(FY(N1),FX(N1))
	YSAVE = FY(N1)
	DO N = N1+1,N2
	  ANG = ANGLESV
	  IF(FY(N).NE.0..OR.FX(N).NE.0.) ANG = ATAN2D(FY(N),FX(N))
	  ANGTOT = ANGTOT + ANG - ANGLESV
	  SFY = YSAVE*FY(N)
	  IF(FX(N).LT.0..AND.SFY.LT.0.) THEN
	    IF(YSAVE.GT.0.) THEN
	      ANGTOT = ANGTOT + 360.
	    ELSE
	      ANGTOT = ANGTOT - 360.
	    ENDIF
	  ENDIF
C
C	print*,'cnt',fx(n),fy(n),ang,anglesv,angtot
C
	  ANGLESV = ANG
	  YSAVE = FY(N)
	ENDDO
	REVS = ANGTOT/360.
C
	RETURN
	END
	SUBROUTINE TDS_PHYS(CH,IPRC,NDATA,VDATA,SPECT)
C
C	FIXBADTDS was added about 1400 on 8 Oct 1995
C	It was much changed on 31 Jan 1997
C	ON 22 JAN 1997, an error, dividing by gain instead of conjg(gain),
C	was corrected
C	In July 1998, and error of bandwidth, was corrected
C	FIXBADTDS6 was written in the fall of 1997, and works fairl well
C		now
C	THIS IS A SPECIAL VERSION WITH COMMANDABLE FILTERING, FOR TDSS
C		MAGNETIC DATA
C
	integer*4	ok,ch
	integer*4	i,j,k,n,iprc
	integer*4	w_item_i4
	character*4	pa(6,4)
	integer*4	return_size,SUNCLOCK
	integer*4	tds_channel,ifilf,ifils,ifil,ifsps,issps,isps
	character*32	item
	real 		ffilter(4),sfilter(4),fsps(4),ssps(4),sps
	REAL 		DATA(2050),VDATA(1),SPECT(1025),WDATA(2050)
	REAL		ZCROSS(2048),ZINT(2048)
	REAL		ANG(2048),ANGTBL(380)
        INTEGER*4       NDATA(2048),NFDATA(2048),NBGDATA(380)
!
C
	COMPLEX PREAMP,TDSDET,TDS_FILTER
	COMPLEX FCOEF,FCOEFT,CCORR
	COMMON /TDS_STATUS/ TDS_CHANNEL,IFIL,FILTER,IRX,ISPS,SPS
	COMMON /PUB/ HDATA(4100)
	COMMON /XFER/ SPHASE(1025)
	COMMON /BZGL/ IGL,NGL1,NGL2
	COMMON /FRLIMITS/ FREQMIN,TOPFREQ
	COMMON /WINBLK/ IWINDO,WINDOW(2048)
	DATA IBGDATA /0/
	DATA TWOPI /6.2831853/
c	DATA FFILTER /50000.,12500.,3125.,781./
c	DATA SFILTER /3125.,781.,195.,49./
c	DATA FSPS /120.,30.,7.5,1.875/
c	DATA SSPS /7500.,1875.,468.75,117.2/
c	DATA PA /'EXAC','EXAC','EXDC',' BX ',' BY ',' BZ ',
c     1           'EXDC','EYAC','EYDC','EXDC','EYDC','EZDC',
c     2           '    ','EZAC','EZDC','    ','    ','    ',
c     3           '    ','EZAC','EZDC','    ','    ','    '/
C
c	item = 'CHANNEL'
c	ok = W_ITEM_i4(ch, item, tds_channel, 1, return_size)
	item = 'EVENT_NUMBER'
	ok = W_ITEM_i4(ch, item, itemp, 1, return_size)
C
C	IWINDO.EQ.1 DOES SPECTRUM FROM WINDOWED DATA, IF NOT 1, NOT
C
	IWINDO = 1
c	IWINDO = 0
C
	FUNDFR = SPS/2048.
C
C	ITEM = 'DATA'
C	OK = W_ITEM_I4(CH,ITEM,NDATA,2048,RETURN_SIZE)
C
	  DO N = 1,2048
		NFDATA(N) = NDATA(N)
	  ENDDO
c	ENDIF
C
	CALL FWINDW(1)
	DO IK = 1,2048
	    DATA(IK) = TDSCAL(TDS_CHANNEL,ISPS,NFDATA(IK))
	    VDATA(IK) = DATA(IK)
	ENDDO
C
	IF(IRX.EQ.9.AND.NGL1.NE.0) THEN
	  CALL BZGLITCH(CH,NGL1,IGL,NGL2,VDATA)
	  DO IK = 1,2048
	    WDATA(IK) = VDATA(IK)
	    DATA(IK) = VDATA(IK)
	  ENDDO
	ENDIF
C
C	DETREND DATA, (SUBTRACT STRAIGHT LINE)
C
	STRT = DATA(1)
	CCFF = (DATA(2048)-STRT)/2047.
C	DO IK = 1,2048
C	  DATA(IK) = DATA(IK) - STRT - (IK-1)*CCFF
C	  WDATA(IK) = DATA(IK)
C	ENDDO
C	print*,'detrend,strt,ccff,1st,lst',strt,ccff,data(2048)
C
C	  RETURN IF UNCORRECTED VOLTS IS REQUESTED
C
	IF(IPRC.LT.2) RETURN
C
	CALL FIXBADTDS(IFXB,NFDATA,DATA,TDS_CHANNEL,SPS,ISPS)
C
	DO IK = 1,2048
	    WDATA(IK) = DATA(IK)*WINDOW(IK)
	ENDDO
C
C		REALFT IS FROM NUMERICAL RECIPES, CAMBRIDGE U PRESS
C
C	CORRECT FOURIER ANALYSED SIGNAL FOR FREQUENCY RESPONSE AT ALL
C		FREQUENCIES (IPRC = 4)
C
c	if(irx.eq.9) then
c	  do n = 1,2048
c	    write(77,*) n,data(n)
c	  enddo
c	endif
C
	  CALL REALFT(DATA,1024,1)
	  CALL REALFT(WDATA,1024,1)
C
	     FREQMAX = .5*SPS
	     PAMAX = CABS(PREAMP(IRX,FREQMAX))
	     IF(IRX.GT.6) PAMAX = CABS(PREAMP(IRX,2000.))      !SEARCH COIL
	     IF(TDS_CHANNEL.LE.2) THEN
		IF(IRX.EQ.1) PAMAX = 2.4  		       ! EXAC
		IF(TDS_CHANNEL.EQ.2.AND.IRX.EQ.2) PAMAX = 6.6  ! EYAC
		IF(TDS_CHANNEL.EQ.2.AND.IRX.GT.2) PAMAX = 7.   ! EZAC
	     ENDIF
	     DO IK = 3,2049,2
		FCOEF = CMPLX(DATA(IK),DATA(IK+1))
		FCOEFT = CMPLX(WDATA(IK),WDATA(IK+1))
	        FREQ = SPS*(IK-1)/4096.
	        CCORR = PREAMP(IRX,FREQ)*TDSDET(TDS_CHANNEL,FREQ)
		CCORR = CCORR*TDS_FILTER(TDS_CHANNEL,IFIL+1,FREQ)
		FCOEF = FCOEF/CONJG(CCORR)
		FCOEFT = FCOEFT/CONJG(CCORR)
		DATA(IK) = FCOEF
		DATA(IK+1) = AIMAG(FCOEF)
		WDATA(IK) = FCOEFT
		WDATA(IK+1) = AIMAG(FCOEFT)
	     ENDDO
C
C	NOW DATA CONTAINS FOURIER COEFFS CORRECTED FOR FREQUENCY RESPONSE
C
 100	CONTINUE
C
C	TRANSFER TO PUB FOR MORE DETAIL IN WAVEFORM
C
	DO N = 1,2048
	  HDATA(N) = DATA(N)
	  HDATA(N+2048) = 0.
	ENDDO
C
C	CALCULATE SPECTRUM, IN DB WRT 1 V**2/HZ
C
	SNORM = 20.*ALOG10(1024.) + 10.*ALOG10(FUNDFR)
	IK = 1
	ISP = 1
	SPECT(ISP) = -SNORM
	IF(DATA(IK).NE.0.)SPECT(ISP) = 20.*ALOG10(ABS(DATA(IK)))-SNORM
	IF(IWINDO.NE.1) THEN
	  DO IK = 3,2048,2
	    ISP = ISP+1
	    TPWR = DATA(IK)**2 + DATA(IK+1)**2
	    SPECT(ISP) = -50.
	    IF(TPWR.NE.0.) THEN
	      SPECT(ISP) = 10.*ALOG10(TPWR)-SNORM
	      SPHASE(ISP) = 57.296*ATAN2(DATA(IK+1),DATA(IK))
	    ENDIF
	  ENDDO
	ELSE
	  DO IK = 3,2048,2
	    ISP = ISP+1
	    TPWR = WDATA(IK)**2 + WDATA(IK+1)**2
	    SPECT(ISP) = -50.
	    IF(TPWR.NE.0.) THEN
	      SPECT(ISP) = 10.*ALOG10(TPWR)-SNORM
	      SPHASE(ISP) = 57.296*ATAN2(WDATA(IK+1),WDATA(IK))
	    ENDIF
	  ENDDO
	ENDIF
C
C		CHANNELS 1 AND 2 HAVE TDSDET AT 322 HZ, AND POOR
C		PREAMP RESPONSE BELOW 120. HZ, SO CUT OFF AT 150 HZ.
C
C		SEARCH COILS SEEM TO BE ENTIRELY NOISE BELOW 3.2 HZ
C
C	print*,'freqmin,max ',freqmin,topfreq
	     DO IK = 3,2048,2
	        FREQ = SPS*(IK-1)/4096.
		IF(FREQ.LT.FREQMIN.OR.FREQ.GT.TOPFREQ) THEN
		  DATA(IK) = 0.
		  DATA(IK+1) = 0.
		ENDIF
	     ENDDO
C
	     CALL REALFT(DATA,1024,-1)
	     DO IK = 1,2048
	       DATA(IK) = DATA(IK)/1024.
	       VDATA(IK) = DATA(IK)
	     ENDDO
c	if(irx.eq.9) then
c	  do n = 1,2048
c	    write(78,*) n,data(n)
c	  enddo
c	endif
C
 20	CONTINUE
C
	RETURN
	END
	SUBROUTINE SUMMPLOT(ITERM,CH,NPTST,NPTND)
C
C	LEFT HAND SECTION PLOTS MEASURED FIELDS, AND BZ RAW, RIGHT
C	PLOTS ONE COMPONENT AGAINST ANOTHER FOR A SELECTED FRACTION
C		 OF AN EVENT
C
	CHARACTER*12 title(25)
	CHARACTER*120 STR
	CHARACTER*4 EVENT
	CHARACTER*6 LABEL(5)
	CHARACTER*4 LABEL1(4)
	character*32 ITEM
	INTEGER*4 TDS_CHANNEL,S_SCET(2),MAJOR,MINOR,NSYS,DOY,ERT(2),OK
	INTEGER*4 SUNCLOCK,ITERM,CH
	REAL*8 SCET8
	COMMON /HEADBL/ TITLE,EVENT
	COMMON /FIXUPBLK/ ISTART
	common /headblk/ major,minor,s_scet,nsys
	COMMON /TDS_STATUS/ TDS_CHANNEL,IFIL,FILTER,IRX,ISPS,SPS
	COMMON /PARTBLK/ XDATA(2050,4),XFDATA(2050,4),XGSE(2050,4),
     1		XRE,YRE,ZRE,SUNCLOCK,SPINRATE,SPSS
	COMMON /EXTRA/ NBXBY,NDATA(2048,4),DBSPEC(1025,4),AVRB,STDB
	COMMON /FRLIMITS/ FREQMIN,TOPFREQ
	COMMON /WINBLK/ IWINDO,WINDOW(2048)
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),XX(2048),PP(2048)
	REAL AVRB(1025,4),STDB(1025,4)
	DATA TWOPI /6.2831853/
	DATA LABEL /'BX(nT)','BY(nT)','BZ(nT)','EX(V)','BZ raw'/
	DATA LABEL1 /'B1','B2','B3','B'/
	DATA DOY /0/
C
	  CALL MGOINIT
	  CALL MGOSETUP(ITERM)
	  CALL MGOERASE
	  NSYS = 0			! POSSIBLY TEMPORARY
C*************
C	DO N = NPTST,NPTND
C	  WRITE(67,*) N,XFDATA(N,1),XFDATA(N,2),XFDATA(N,3)
C	ENDDO
C
C	  PUT LABELS ON RIGHT HAND SIDE
C
	  TITLE(3) = EVENT
	print*,'event',event
	  TITLE(4) = 'EVENT NO.'
	  ITEM = 'EVENT_NUMBER'
	  ok = W_ITEM_I4(ch, item, NO_EVT, 1, ret_size)
	  WRITE(TITLE(5),1012) NO_EVT
 1012	  FORMAT(I10)
	  TITLE(8) = 'SAMPLE RATE'
	  WRITE(TITLE(9),1009) SPSS
 1009	  FORMAT(F8.1)
	  TITLE(10) = 'L.P.FILTER'
	  WRITE(TITLE(11),1009) FILTER
	  TITLE(12) = 'SCET'
	  ITEM = 'EVENT_SCET'
	  ok = W_ITEM_I4(ch, item, S_SCET, 2, ret_size)
	  nss = mod(s_scet(2),100)
	  mm = s_scet(2)/100
	  mm = mod(mm,100)
	  nhh = s_scet(2)/10000
	  WRITE(STR,1013) s_scet(1)
 1013	  FORMAT(I8)
c	  scett = float(dds) + nhh/24. + mm/1440. + nss/86400.
	   WRITE(TITLE(13),1016) str(1:4),str(5:6),str(7:8)
	   ITEM = 'EVENT_SCET_R8'
	   ok = W_ITEM_R8(ch, item, SCET8, 1, ret_size)
	   call w_ur8_to_ydoy(scet8,yyyy,doy,msday)
	   WRITE(TITLE(14),1014) DOY
	   WRITE(TITLE(15),1018) s_scet(2)/100, MOD(s_scet(2),100)
 1016	   format(A4,'/',A2,'/',A2)
 1014	   FORMAT(' DOY ',I4)
 1018	   FORMAT(I6.4,I3.2)
	  WRITE(title(18),*) 'RECEIVED AT'
	  ITEM = 'EVENT_TM_SCET_I4'
	  ok = w_item_I4(ch, item, ERT, 2, return_size)
	  WRITE(STR,1013) ERT(1)
	  WRITE(TITLE(19),1016) str(1:4),str(5:6),str(7:8)
	  WRITE(TITLE(20),1018) ERT(2)/100, MOD(ERT(2),100)
C 1017	  format(I10)
C
	  XTITLE = GX2 -.1*(GX2-GX1)              ! 3 dec 1996
	  YTITLE = GY2
	  CALL MGOGRELOCATE(XTITLE,YTITLE)
	  TRANGE = GY2-GY1
	  TINC = .028*TRANGE
	  CALL MGOSETEXPAND(.6)
	  TITLE(6) = 'SAMPLES'
	  WRITE(STR,1007) NPTST,NPTND
 1007	  FORMAT(I4,' TO',I5)
	  TITLE(7) = STR(1:12)
	  TITLE(16) = 'FFT BANDPASS'
	  FUNDFR = SPS/2048.
	  NHARM = FREQMIN/FUNDFR
	  AFREQMIN = (NHARM+1)*FUNDFR
	  WRITE(TITLE(17),1019) AFREQMIN,TOPFREQ
 1019	  FORMAT(F5.1,'-',F5.0)
	  WRITE(TITLE(21),1021) 'XRE',XRE
 1021	  FORMAT(A3,F7.1)
	  WRITE(TITLE(22),1021),'YRE',YRE
	  WRITE(TITLE(23),1021),'ZRE',ZRE
	  DO N = 3,23
	    YTITLE = YTITLE - TINC
	    IF(N.EQ.6) YTITLE = YTITLE - TINC
	    IF(N.EQ.12) YTITLE = YTITLE - TINC
	    IF(N.EQ.16) YTITLE = YTITLE - TINC
	    IF(N.EQ.18) YTITLE = YTITLE - TINC
	    IF(N.EQ.21) YTITLE = YTITLE - TINC
	    CALL MGOGRELOCATE(XTITLE,YTITLE)
	    CALL MGOLABEL(12,TITLE(N))
	  ENDDO
C
	  IF(ITERM.LT.0) THEN
	    CALL MGOSETLOC(500.,320.,3050.,2170.)
	  ELSE
	    CALL MGOSETLOC(50.,50.,1000.,750.)
 	  ENDIF
C
C	  PLOT TDS DATA
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
	XMAX = 0.
	YMAX = 0.
	EANGLE =  -360.*SUNCLOCK/4096. - 45.       ! ANGLE SUN TO +EX AT END
	DANG = SPINRATE*360./SPS/TWOPI		  ! CHANGE PER SAMPLE
	THANT = EANGLE + 2049.*DANG + 360.	  ! ANGLE SUN TO +EX AT MIDDLE??
c
c	PRINT*,'IN PLOTSEL, XFDATA=',(XFDATA(1,N),N=1,4)
C
C	PLOT MEASURED FIELDS ON LEFT SIDE
C
	  NXW = 3
	  NYW = 5
	  NW = 15
	  DO IW = 1,NW,3		! do 1,4,7,10,13
C
	  IF(ITERM.LT.0) THEN
	    GX1 = 300.
	    GX2 = 1400.
	    GY1 = 100. + 460.*(IW-1)/3
	    GY2 = GY1 + 340.
	  ELSE
	    GX1 = 60.
	    GX2 = 430.
	    GY1 = 50. + 150.*(IW-1)/3
	    GY2 = GY1 + 120.
C	    CALL MGOSETLOC(50.,50.,1000.,750.)
 	  ENDIF
C	    CALL MGOWINDOW(NXW,NYW,IW)
C
	    N2 = (IW+2)/3
C
	    NPT = 0
	    YMAX = -1000.
	    YMIN = 1000.
    	    DO N = NPTST,NPTND
	      NPT = NPT+1
  	      PP(NPT) = (N-1)/SPSS
	      IF(N2.GT.4) THEN
	        YY(NPT) = NDATA(N,3)
  	        PP(NPT) = THANT - N*DANG
C	      ELSEIF(IW.EQ.7) THEN
C	        YY(NPT) = XDATA(N,N2)
	      ELSE
	        YY(NPT) = XDATA(N,N2)
	      ENDIF
	      YMAX = AMAX1(YY(NPT),YMAX)
	      YMIN = AMIN1(YY(NPT),YMIN)
	    ENDDO
	    CALL MGOSETLIM(PP(1),YMIN,PP(NPT),YMAX)
	    CALL MGOSETEXPAND(.7)
C	    CALL MGOTICKSIZE(0.,0.,0.,0.)
	    CALL MGOCONNECT(PP,YY,NPT)
	    CALL MGOSETEXPAND(.6)
	    CALL MGOBOX(1,2)
	    CALL MGOSETEXPAND(.6)
	    IF(IW.EQ.1) CALL MGOXLABEL(3,'SEC')
	    IF(N2.GT.4) CALL MGOXLABEL(17,'ANGLE,SUN TO +EX')
	    CALL MGOYLABEL(6,LABEL(N2))
	    CALL MGOSETEXPAND(1.)
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
C
	  ENDDO
C
c	  IF(IPROCESS.GE.3) THEN
c	    YTITLE = YTITLE-2.*TINC
c	    CALL MGOSETEXPAND(.5)
c	    CALL MGOGRELOCATE(XTITLE,YTITLE)
c	    CALL MGOLABEL(8,' BAD TDS')
c	    YTITLE = YTITLE-TINC
c	    CALL MGOGRELOCATE(XTITLE,YTITLE)
c	    CALL MGOLABEL(9,'CORRECTED')
c	    YTITLE = YTITLE-TINC
c	    CALL MGOGRELOCATE(XTITLE,YTITLE)
c	    WRITE(STR,1024) IPROCESS
 1024	    FORMAT(' LEVEL',I2)
c	    CALL MGOLABEL(8,STR)
c	    WRITE(STR,1025) ISTART
 1025	    FORMAT(I5,' PTS')
c	    YTITLE = YTITLE-TINC
c	    CALL MGOGRELOCATE(XTITLE,YTITLE)
c	    CALL MGOLABEL(9,STR)
c	    CALL MGOSETEXPAND(.8)
c	  ENDIF
C
	  CALL MGOSETEXPAND(.6)
C
C	PLOT MINIMUM VARIANCE FIELDS ON RIGHT SIDE
C
	  IF(ITERM.LT.0) THEN
	    CALL MGOSETLOC(500.,320.,3050.,2170.)
	  ELSE
C	    CALL MGOSETLOC(50.,50.,501.,750.)
 	  ENDIF
C
	  XMAX = -1000.
	  YMAX = -1000.
    	  DO N = NPTST,NPTND
	     IF(ABS(XFDATA(N,1)).GT.XMAX) THEN
		XMAX = ABS(XFDATA(N,1))
		NXMAX = N
	     ENDIF
	     IF(ABS(XFDATA(N,2)).GT.YMAX.OR.XFDATA(N,3).GT.YMAX) THEN
	        YMAX = AMAX1(ABS(XFDATA(N,3)),ABS(XFDATA(N,2)))
		NYMAX = N
	     ENDIF
	  ENDDO
	  IF(1.364*YMAX.GT.XMAX) THEN
		NMAX = NYMAX
	  ELSE
		NMAX = NXMAX
	  ENDIF
C	PRINT*,'SUMMPLOT,XMAX,YMAX',XMAX,YMAX
C	PRINT*,'SUMMPLOT,NMAX,NXMAX,NYMAX',NMAX,NXMAX,NYMAX
C	  XMAX = 1000.*XMAX
C	  YMAX = 1000.*YMAX
	  XMAX = 1.1*AMAX1(XMAX,1.364*YMAX)
	  YMAX = XMAX/1.364
C
	  NXW = 3
	  NYW = 3
	  NW = 9			! 2 = l.left,5 = u.left,8=l.right
	  DO IW = 2,NW,3
	    IF(ITERM.LT.0) THEN
C	      CALL MGOWINDOW(NXW,NYW,IW)
	      GX1 = 1600.
	      GX2 = 2220.
	      GY1 = 100. + 780.*(IW-2)/3
	      GY2 = GY1 + 620.
	      IF(IW.EQ.8) THEN		!
	        GX1 = 2480.
	        GX2 = 3099.
	        GY1 = 100.
	        GY2 = GY1 + 620.
	      ENDIF
	    ELSE
	      GX1 = 500.
	      GX2 = 700.
	      GY1 = 50. + 260.*(IW-2)/3
	      GY2 = GY1 + 200.
	      IF(IW.EQ.8) THEN
	        GX1 = 799.
	        GX2 = 999.
	        GY1 = 50.
	        GY2 = GY1 + 200.
	      ENDIF
	    ENDIF
	    N1 = IW/2
	    N2 = N1+1
	    IF(IW.EQ.8) THEN
		N1 = 1
		N2 = 3
	    ENDIF
C
	    NPT = 0
    	    DO N = NPTST,NPTND
	      NPT = NPT+1
	      XX(NPT) = XFDATA(N,N1)
	      YY(NPT) = XFDATA(N,N2)
	    ENDDO
	    XMAX = AMAX1(XMAX,YMAX)
	    YMAX = XMAX
	    CALL MGOSETLIM(-XMAX,-YMAX,XMAX,YMAX)
	    CALL MGOSETEXPAND(.7)
C	    CALL MGOTICKSIZE(0.,0.,0.,0.)
	    CALL MGOCONNECT(XX,YY,NPT)
	    CALL MGOSETEXPAND(.6)
	    CALL MGOBOX(1,2)
	    CALL MGOSETEXPAND(.6)
	    CALL MGOXLABEL(2,LABEL1(N1))
	    CALL MGOYLABEL(2,LABEL1(N2))
	    CALL MGOSETEXPAND(.8)
	    CALL MGOSETEXPAND(1.)
C	    PUT ON ARROW
	    NPTMAX = NMAX - NPTST + 1
	    SIZE = .1*SQRT(XMAX**2 + YMAX**2)
	    IF(ITERM.GT.0) SIZE = 2.*SIZE
	    XARR = .5*(XX(NPTMAX+1) + XX(NPTMAX))
	    YARR = .5*(YY(NPTMAX+1) + YY(NPTMAX))
	    DX = XX(NPTMAX+1) - XX(NPTMAX)
	    DY = YY(NPTMAX+1) - YY(NPTMAX)
	    CALL ARROW(XARR,YARR,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
C
	  ENDDO
C
C	  CALL MGOSETEXPAND(.6)
	  NSYS = 2
C	print*,'in SUMMPLOT,nsys=',nsys
 	  IF(NSYS.EQ.0)CALL MGOPLOTID('S/C','[.WIND]MAKEFILE6,SUMMPLOT')
 	  IF(NSYS.EQ.1)CALL MGOPLOTID('SN,CL','[.WIND]MAKEFILE6,SUMMPLOT')
 	  IF(NSYS.EQ.2)CALL MGOPLOTID('VAR MX','[.WIND]MAKEFILE6,SUMMPLOT')
 	  IF(NSYS.EQ.3)CALL MGOPLOTID('GSE','[.WIND]MAKEFILE6,SUMMPLOT')
	  CALL MGOSETEXPAND(.8)
C
C	PLOT A SPECTRUM
C
	  NXW = 3
	  NYW = 3
	  IW = 3
	  YMIN = 1000.
	  YMAX = -1000.
	  IF(ITERM.LT.0) THEN
	      GX1 = 1620.
	      GX2 = 2420.
	      GY1 = 1600.
	      GY2 = 2300.
	  ELSE
	      GX1 = 500.
	      GX2 = 700.
	      GY1 = 550.
	      GY2 = GY1 + 220.
	  ENDIF
	    NPT = 0
    	    DO N = 2,1024
	      NPT = NPT+1
	      XX(NPT) = ALOG10(SPS*(N-1)/2048.)
	      YY(NPT) = DBSPEC(N,NBXBY)
	      YMAX = AMAX1(YY(NPT),YMAX)
	      YMIN = AMIN1(YY(NPT),YMIN)
	    ENDDO
C	write(66,*)'NBXBY',NBXBY
C	DO N = 35,45
C	  write(66,*) N,DBSPEC(N,NBXBY)
C	ENDDO
	    XMAX = ALOG10(SPS/2.)
	    XMIN = ALOG10(SPS/2048.)
	    CALL MGOTICKSIZE(-1.,-1.,0.,0.)
	    CALL MGOSETLIM(XMIN,YMIN,XMAX,YMAX)
	    CALL MGOSETEXPAND(.7)
	    CALL MGOCONNECT(XX,YY,NPT)
	    NPT = 0
	    IF(NBXBY.EQ.3) NBXBY = 2
    	    DO N = 2,1024
	      NPT = NPT+1
	      YY(NPT) = AVRB(N,NBXBY)
	    ENDDO
	    CALL MGOSETLTYPE(1)
	    CALL MGOCONNECT(XX,YY,NPT)
	    CALL MGOSETLTYPE(0)
	    CALL MGOSETEXPAND(.6)
	    CALL MGOBOX(1,2)
	    CALL MGOSETEXPAND(.6)
	    CALL MGOXLABEL(9,'FREQ (Hz)')
	    IF(NBXBY.EQ.1) CALL MGOYLABEL(14,'BX dB nT\u2/Hz')
	    IF(NBXBY.EQ.2) CALL MGOYLABEL(14,'BY dB nT\u2/Hz')
	    CALL MGORELOCATE(.6*XMAX,.1*YMIN+.9*YMAX)
	    IF(IWINDO.EQ.1) CALL MGOLABEL(8,'WINDOWED')
	    IF(IWINDO.NE.1) CALL MGOLABEL(12,'NOT WINDOWED')
	    CALL MGOSETEXPAND(.8)
C
	  IF(ITERM.LT.0) THEN
	    CALL MGOPRNTPLOT(NVEC)
	    PRINT*,' NO. VECTORS PLOTTED',NVEC
	  ELSE
C	    CALL MGOTCLOSE
	  ENDIF
C
	RETURN
C
	END
	SUBROUTINE FWINDW(IWINDW)
C
	COMMON /WINBLK/ IWINDO,WINDOW(2048)
	DATA TWOPI /6.2831853/
C
	GO TO (100,200,300) IWINDW+1
	PRINT*,'REQUESTED WINDOW DOES NOT EXIST'
 100	CONTINUE
	PRINT*,'IWINDW =',IWINDW,'  NO WINDOWING'
	DO N = 1,2048
	  WINDOW(N) = 1.
	ENDDO
	RETURN
 200	CONTINUE
C	PRINT*,'IWINDW =',IWINDW,'  HAMMING'
	ALPHA = .54
	GO TO 310
 300	CONTINUE
	ALPHA = .5
	PRINT*,'IWINDW =',IWINDW,'  HANNING'
 310	CONTINUE
	SUMSQ = 0.
	DO N = 1,2048
	  WINDOW(N) = ALPHA + (ALPHA-1.)*COS(TWOPI*(N-1)/2048.)
	  SUMSQ = SUMSQ + WINDOW(N)**2
	ENDDO
	RMS = SQRT(SUMSQ/2048.)
	DO N = 1,2048
	  WINDOW(N) = WINDOW(N)/RMS
	ENDDO
	RETURN
	END


      SUBROUTINE  DDIAPA (IX,IY)
C     (Add to Path)
C     Add the point (IX,IY) to the current path, which is assumed
C     to have  already been  started by  a call  to DDIBPA.   The
C     current point and visibility are updated in COMMON.
C     (27-May-1991)
C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C
C     EXTERNAL REFERENCES (FUNCTION,SUBROUTINE,COMMON)
C
C     EXTERNAL REFS       TKIOLL,      TKIOWB,      TKIOWH,      TKIOWN
C
      INTEGER             TKIOLL
C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C
C     NON-COMMON VARIABLES
C
C     SETS                BLANK
C
      INTEGER             BLANK,       DUMMY,       IX,          IY
C
C-----------------------------------------------------------------------
C                         P o s t S c r i p t
C           D i s p l a y   D e v i c e   I n t e r f a c e
C                       C O M M O N   B l o c k
C
C     DSSIZE                   display surface size in cm
C     IMAGE                    image transformation in effect
C     (LASTX,LASTY,VILAST)     last position and visibility of pen
C     LINEIN                   line intensity (0..1 scale)
C     LINEWT                   line weight (1..25 scale)
C     MAGFAC                   resolution magnification factor
C     (MOVEX,MOVEY)            position of first point in path
C     NPATH                    number of line segments in current page
C     PLSTEP                   plotter step size in cm
C     (PSXOFF,PSYOFF)          image offset in PostScript units (bp)
C     ROTATE                   plot frame is rotated
C     (SX,SY)                  scale factors (unit square to plot steps)
C     TIMAGE(*,*)              image transformation matrix
C     (XMAX,YMAX,ZMAX)         normalized device space extents
C     (MAXX,MAXY,MINX,MINY)    actual coordinate limits reached
C
C-----------------------------------------------------------------------
      INTEGER             LASTX,       LASTY,       LINEWT,      MAGFAC
      INTEGER             MAXX,        MAXY,        MINX,        MINY
      INTEGER             MOVEX,       MOVEY,       NPATH,       PSXOFF
      INTEGER             PSYOFF
C
      LOGICAL             DVINIT,      IMAGE,       ROTATE,      VILAST
C
      REAL                DSSIZE,      LINEIN,      PLSTEP,      SX
      REAL                SY,          TIMAGE,      XMAX,        YMAX
      REAL                ZMAX
C
      COMMON / DDI01  /   DSSIZE,      LINEIN,      PLSTEP,      SX
      COMMON / DDI01  /   SY,          TIMAGE(4,4), XMAX,        YMAX
      COMMON / DDI01  /   ZMAX,        LASTX,       LASTY,       LINEWT
      COMMON / DDI01  /   MAGFAC,      MAXX,        MAXY,        MINX
      COMMON / DDI01  /   MINY,        MOVEX,       MOVEY,       NPATH
      COMMON / DDI01  /   PSXOFF,      PSYOFF,      DVINIT,      IMAGE
      COMMON / DDI01  /   ROTATE,      VILAST
C
C
      DATA                BLANK     / 32 /
C
C     We can generate an  entry of size "-ddddd -ddddd R "; try to
C     keep line lengths under 80 characters.
C
      IF (TKIOLL(DUMMY) .GT. 64) CALL TKIOWH (2H$N,2)
C
C     Use relative coordinates for lines to reduce the  number of
C     bytes in the  verbose  PostScript  command language.   This
C     shortens the plot file by 5 to 10 percent.
C
C     We optimize output into 3 different forms:
C
C     # # R   (relative lineto)
C     # X     (relative lineto with delta-y = 0)
C     # Y     (relative lineto with delta-x = 0)
C
C     The  latter two cases  occur frequently enough  to be worth
C     taking advantage of  to compress the  output and reduce the
C     parsing  time.    We cannot  discard zero length  segments,
C     however, because that  would discard single  points from  a
C     point plot.
C
      IF (IX .EQ. LASTX) GO TO 10
      IF (IY .EQ. LASTY) GO TO 20
      CALL TKIOWN (IX-LASTX)
      CALL TKIOWB (BLANK)
      CALL TKIOWN (IY-LASTY)
      CALL TKIOWH (3H R ,3)
      GO TO 30
   10 CALL TKIOWN (IY-LASTY)
      CALL TKIOWH (3H Y ,3)
      GO TO 30
   20 CALL TKIOWN (IX-LASTX)
      CALL TKIOWH (3H X ,3)
   30 NPATH = NPATH + 1
      LASTX = IX
      LASTY = IY
      VILAST = .TRUE.
      MAXX = MAX0(MAXX,IX)
      MINX = MIN0(MINX,IX)
      MAXY = MAX0(MAXY,IY)
      MINY = MIN0(MINY,IY)
C
C     Insert a  line break  periodically to  prevent  excessively
C     long lines.
C
C     IF (MOD(NPATH,10) .EQ. 0) CALL TKIOWH (2H$N,2)
C
   40 RETURN
      END


Subroutine resdec(i1, nt, nnn, wid, idecay, ipion)
  Parameter (hbarc=0.19733)
  Parameter (ak0=0.498, apich=0.140, api0=0.135, an=0.940, addm=0.02)
  Parameter (maxstr=150001, maxr=1)
  Common /input2/ilab, manyb, ntmax, icoll, insys, ipot, mode, imomen, nfreq, icflow, icrho, icou, kpoten, kmul
  Common /lujets/n, k(9000, 5), p(9000, 5), v(9000, 5)
  Common /ludat1/mstu(200), paru(200), mstj(200), parj(200)
  Common /ludat2/kchg(500, 3), pmas(500, 4), parf(2000), vckm(4, 4)
  Common /ludat3/mdcy(500, 3), mdme(2000, 2), brat(2000), kfdp(2000, 5)
  Common /cc/e(maxstr)
  Common /ee/id(maxstr), lb(maxstr)
  Common /pa/rpion(3, maxstr, maxr)
  Common /pb/ppion(3, maxstr, maxr)
  Common /pc/epion(maxstr, maxr)
  Common /pd/lpion(maxstr, maxr)
  Common /input1/masspr, massta, iseed, iavoid, dt
  Common /resdcy/nsav, iksdcy
  Common /leadng/lb1, px1, py1, pz1, em1, e1, xfnl, yfnl, zfnl, tfnl, px1n, py1n, pz1n, dp1n
  External iarflv, invflv
  Common /tdecay/tfdcy(maxstr), tfdpi(maxstr, maxr), tft(maxstr)
  Common /rndf77/nseed
  Common /dpert/dpertt(maxstr, maxr), dpertp(maxstr), dplast(maxstr), dpdcy(maxstr), dpdpi(maxstr, maxr), dpt(maxstr, maxr), dpp1(maxstr, maxr), dppion(maxstr, maxr)
  Common /phidcy/iphidcy, pttrig, ntrig, maxmiss, ipi0dcy
  Save
  irun = idecay
  If (nt==ntmax .And. ipi0dcy==1 .And. ((lb1==4 .And. ipion==0) .Or. ipion>=1)) Then
     kf = 111
  Else If (lb1==0 .Or. lb1==25 .Or. lb1==26 .Or. lb1==27 .Or. lb1==28 .Or. lb1==29 .Or. iabs(lb1)==30 .Or. lb1==24 .Or. (iabs(lb1)>=6 .And. iabs(lb1)<=9) .Or. iabs(lb1)==16) Then
     kf = invflv(lb1)
  Else
     Return
  End If
  ip = 1
  n = 1
  k(ip, 1) = 1
  k(ip, 3) = 0
  k(ip, 4) = 0
  k(ip, 5) = 0
  k(ip, 2) = kf
  If (ipion==0) Then
     p(ip, 1) = px1
     p(ip, 2) = py1
     p(ip, 3) = pz1
     If ((lb1==0 .Or. lb1==28) .And. em1<(2*apich+api0+addm)) Then
        em1 = 2*apich + api0 + addm
     Else If (lb1>=25 .And. lb1<=27 .And. em1<(2*apich+addm)) Then
        em1 = 2*apich + addm
     Else If (iabs(lb1)==30 .And. em1<(apich+ak0+addm)) Then
        em1 = apich + ak0 + addm
     Else If (iabs(lb1)>=6 .And. iabs(lb1)<=9 .And. em1<(apich+an+addm)) Then
        em1 = apich + an + addm
     End If
     e1 = sqrt(em1**2+px1**2+py1**2+pz1**2)
     p(ip, 4) = e1
     p(ip, 5) = em1
     dpdecp = dpertp(i1)
  Else If (nt==ntmax .And. ipi0dcy==1 .And. ipion>=1) Then
     p(ip, 1) = ppion(1, ipion, irun)
     p(ip, 2) = ppion(2, ipion, irun)
     p(ip, 3) = ppion(3, ipion, irun)
     p(ip, 5) = epion(ipion, irun)
     p(ip, 4) = sqrt(p(ip,5)**2+p(ip,1)**2+p(ip,2)**2+p(ip,3)**2)
     dpdecp = dppion(ipion, irun)
  Else
     Print *, 'stopped in resdec() a'
     Stop
  End If
  Call ludecy(ip)
  If (nt==ntmax) Then
     tau0 = hbarc/wid
     taudcy = tau0*(-1.)*alog(1.-ranart(nseed))
     ndaut = n - nsav
     If (ndaut<=1) Then
        Write (10, *) 'note: ndaut(<1)=', ndaut
        Call lulist(2)
        Stop
     End If
     If (ipion==0) Then
        taudcy = taudcy*e1/em1
        tfnl = tfnl + taudcy
        xfnl = xfnl + px1/e1*taudcy
        yfnl = yfnl + py1/e1*taudcy
        zfnl = zfnl + pz1/e1*taudcy
     Else If (ipion>=1) Then
        taudcy = taudcy*p(ip, 4)/p(ip, 5)
        tfnl = tfdpi(ipion, irun) + taudcy
        xfnl = rpion(1, ipion, irun) + p(ip, 1)/p(ip, 4)*taudcy
        yfnl = rpion(2, ipion, irun) + p(ip, 2)/p(ip, 4)*taudcy
        zfnl = rpion(3, ipion, irun) + p(ip, 3)/p(ip, 4)*taudcy
     Else
        Print *, 'stopped in resdec() b', ipion, wid, p(ip, 4)
        Stop
     End If
     If (n>=(nsav+2) .And. ipion==0) Then
        Do idau = nsav + 2, n
           kdaut = k(idau, 2)
           If (kdaut==221 .Or. kdaut==113 .Or. kdaut==213 .Or. kdaut==-213 .Or. kdaut==310) Then
              ksave = kdaut
              pxsave = p(idau, 1)
              pysave = p(idau, 2)
              pzsave = p(idau, 3)
              esave = p(idau, 4)
              xmsave = p(idau, 5)
              k(idau, 2) = k(nsav+1, 2)
              p(idau, 1) = p(nsav+1, 1)
              p(idau, 2) = p(nsav+1, 2)
              p(idau, 3) = p(nsav+1, 3)
              p(idau, 4) = p(nsav+1, 4)
              p(idau, 5) = p(nsav+1, 5)
              k(nsav+1, 2) = ksave
              p(nsav+1, 1) = pxsave
              p(nsav+1, 2) = pysave
              p(nsav+1, 3) = pzsave
              p(nsav+1, 4) = esave
              p(nsav+1, 5) = xmsave
              Goto 111
           End If
        End Do
     End If
111  Continue
     enet = 0.
     Do idau = nsav + 1, n
        enet = enet + p(idau, 4)
     End Do
  End If
  Do idau = nsav + 1, n
     kdaut = k(idau, 2)
     lbdaut = iarflv(kdaut)
     If (nt==ntmax .And. (kdaut==130 .Or. kdaut==310 .Or. iabs(kdaut)==311)) Then
        If (kdaut==130) Then
           lbdaut = 22
        Else If (kdaut==310) Then
           lbdaut = 24
        Else If (iabs(kdaut)==311) Then
           If (ranart(nseed)<0.5) Then
              lbdaut = 22
           Else
              lbdaut = 24
           End If
        End If
     End If
     If (idau==(nsav+1)) Then
        If (ipion==0) Then
           lb(i1) = lbdaut
           e(i1) = p(idau, 5)
           px1n = p(idau, 1)
           py1n = p(idau, 2)
           pz1n = p(idau, 3)
           dp1n = dpdecp
        Else If (ipion>=1) Then
           lpion(ipion, irun) = lbdaut
           epion(ipion, irun) = p(idau, 5)
           ppion(1, ipion, irun) = p(idau, 1)
           ppion(2, ipion, irun) = p(idau, 2)
           ppion(3, ipion, irun) = p(idau, 3)
           rpion(1, ipion, irun) = xfnl
           rpion(2, ipion, irun) = yfnl
           rpion(3, ipion, irun) = zfnl
           tfdpi(ipion, irun) = tfnl
           dppion(ipion, irun) = dpdecp
        End If
     Else
        nnn = nnn + 1
        lpion(nnn, irun) = lbdaut
        epion(nnn, irun) = p(idau, 5)
        ppion(1, nnn, irun) = p(idau, 1)
        ppion(2, nnn, irun) = p(idau, 2)
        ppion(3, nnn, irun) = p(idau, 3)
        rpion(1, nnn, irun) = xfnl
        rpion(2, nnn, irun) = yfnl
        rpion(3, nnn, irun) = zfnl
        tfdpi(nnn, irun) = tfnl
        dppion(nnn, irun) = dpdecp
     End If
  End Do
  Return
End Subroutine resdec


module module_radiance

   !---------------------------------------------------------------------------
   ! Purpose: module for radiance data assimilation.
   !---------------------------------------------------------------------------

   use da_control, only : pi, use_landem, t_landem, t_kelvin
   use da_reporting, only : da_error,message

#ifdef RTTOV
   use rttov_const,  only : &
            errorstatus_success, &
            errorstatus_fatal,   &
            gas_id_watervapour,  &
            sensor_id_ir,        &
            sensor_id_mw,        &
            sensor_id_hi,        &
            sensor_id_po
   use rttov_types, only :  &
         rttov_options,     &
         rttov_opts_rt_ir,  &
         rttov_coefs,       &
         rttov_profile,      &
         rttov_transmission, &
         rttov_radiance,     &
         rttov_chanprof,    &
         rttov_emissivity
   use parkind1, only : jpim, jprb
   use mod_rttov_emis_atlas, only : &
         rttov_emis_atlas_data, &
         atlas_type_mw, &
         atlas_type_ir
#endif

#ifdef CRTM
  ! -- Modules to define CRTM constants etc.
   !USE Type_Kinds
   !USE Error_Handler
   !USE CRTM_Utility

  ! -- CRTM RT_models modules
   USE CRTM_Module, only : graupel_cloud, rain_cloud, snow_cloud,crtm_adjoint, &
      crtm_atmosphere_create, crtm_surface_create, &
      crtm_atmosphere_destroy, crtm_surface_destroy, &
      crtm_forward,crtm_init,crtm_k_matrix, &
      crtm_tangent_linear, h2o_id,hail_cloud,ice_cloud, &
      o3_id, water_cloud, crtm_rtsolution_type, crtm_channelinfo_type, &
      crtm_atmosphere_type, crtm_surface_type, crtm_geometry_type, &
      crtm_surface_zero, crtm_atmosphere_zero, crtm_destroy, &
      climatology_model_name, &
      crtm_options_type, crtm_options_create, crtm_options_destroy, &
      crtm_rtsolution_create, crtm_rtsolution_destroy, crtm_rtsolution_associated, &
      crtm_irlandcoeff_classification
   USE CRTM_Atmosphere_Define, only: crtm_atmosphere_associated, &
      MASS_MIXING_RATIO_UNITS, VOLUME_MIXING_RATIO_UNITS
   USE CRTM_Surface_Define, only: crtm_surface_associated
   USE CRTM_Options_Define, only: crtm_options_associated

   USE CRTM_SensorInfo
   USE CRTM_Planck_Functions, only : CRTM_Planck_Temperature, &
      CRTM_Planck_Radiance, CRTM_Planck_Temperature_TL, &
      CRTM_Planck_Temperature_AD
#endif

   use gsi_kinds      ,  only : r_kind,r_double,i_kind,r_single
   use gsi_constants  ,  only : deg2rad, rad2deg,       &
                            init_constants_derived, &
                            one, three, zero, half, &
                            one_tenth, two, four

   ! use irsse_model, only: forward_irsse
   implicit none

   real, parameter             :: q2ppmv = 1.60771704e+6   ! q_mixratio_to_ppmv

  ! cf. RTTOV-11 Users Guide Table 2
  ! index 19 is sentinel3 in Table 2, here we keep it as tiros for
  ! WRFDA backward compatibility
  Character (len=8), Parameter :: rttov_platform_name(1:35) =          &
     & (/ 'noaa    ', 'dmsp    ', 'meteosat', 'goes    ', 'gms     ',  &
        & 'fy2     ', 'trmm    ', 'ers     ', 'eos     ', 'metop   ',  &
        & 'envisat ', 'msg     ', 'fy1     ', 'adeos   ', 'mtsat   ',  &
        & 'coriolis', 'jpss    ', 'gifts   ', 'tiros   ', 'meghatr ',  &
        & 'kalpana ', 'reserved', 'fy3     ', 'coms    ', 'meteor-m',  &
        & 'gosat   ', 'calipso ', 'reserved', 'gcom-w  ', 'nimbus  ',  &
        & 'himawari', 'mtg     ', 'saral   ', 'metop-ng', 'landsat '/)

  ! cf. RTTOV-11 Users Guide Table 3
  ! List of instruments  !!!! HIRS is number 0
  CHARACTER(LEN=8), dimension(0:88):: rttov_inst_name =                &
     & (/ 'hirs    ', 'msu     ', 'ssu     ', 'amsua   ', 'amsub   ',  &
        & 'avhrr   ', 'ssmi    ', 'vtpr1   ', 'vtpr2   ', 'tmi     ',  &
        & 'ssmis   ', 'airs    ', 'hsb     ', 'modis   ', 'atsr    ',  &
        & 'mhs     ', 'iasi    ', 'amsre   ', 'imager  ', 'atms    ',  &
        & 'mviri   ', 'seviri  ', 'imager  ', 'sounder ', 'imager  ',  &
        & 'vissr   ', 'mvisr   ', 'cris    ', 'cmis    ', 'viirs   ',  &
        & 'windsat ', 'gifts   ', 'ssmt1   ', 'ssmt2   ', 'saphir  ',  &
        & 'madras  ', 'ssmisz  ', 'vhrr    ', 'imager  ', 'sounder ',  &
        & 'mwts    ', 'mwhs    ', 'iras    ', 'mwri    ', 'abi     ',  &
        & 'mi      ', 'msumr   ', 'tansofts', 'iir     ', 'mwr     ',  &
        & 'dummyir ', 'dummymw ', 'dummyhi ', 'dummypo ', 'scams   ',  &
        & 'smmr    ', 'ahi     ', 'irs     ', 'altika  ', 'iasing  ',  &
        & 'tm      ', 'fci     ', 'amsr    ', 'amsr2   ', 'vissr   ',  &
        & 'slstr   ', 'tirs    ', 'amr     ', 'oli     ', 'iris    ',  &
        & 'ici     ', 'gmi     ', 'mwts2   ', 'mwhs2   ', 'aster   ',  &
        & 'hatpro  ', 'mtvzagy ', 'metimage', 'mws     ', 'mwi     ',  &
        & 'epic    ', 'mrir    ', 'si      ', 'mrfirs  ', 'mbfiri  ',  &
        & 'lhr     ', 'ismar   ', 'mersi1  ', 'mersi2  ' /)

  ! cf. rttov_platform_name above and CRTM: v2.1.3 User Guide Table B.1
  ! n=noaa; f=dmsp; g=goes; eos-2/1=aqua/terra;
  ! xxxxxxxx means crtm does not have corresponding coefficient file.
  ! For satellite names that can not be directly mapped here to names
  ! used in crtm coeff names, they will be re-set in
  ! da_crtm_sensor_descriptor.inc
  Character (len=8), Parameter :: crtm_platform_name(1:35) =           &
     & (/ 'n       ', 'f       ', 'm       ', 'g       ', 'gms     ',  &
        & 'xxxxxxxx', 'trmm    ', 'ers     ', 'eos     ', 'metop   ',  &
        & 'envisat ', 'msg     ', 'xxxxxxxx', 'xxxxxxxx', 'mt      ',  &
        & 'coriolis', 'npp     ', 'gifts   ', 'tiros   ', 'meghat  ',  &
        & 'kalpana ', 'tiros   ', 'fy3     ', 'coms    ', 'xxxxxxxx',  &
        & 'xxxxxxxx', 'xxxxxxxx', 'reserved', 'gcom-w  ', 'xxxxxxxx',  &
        & 'himawari', 'xxxxxxxx', 'xxxxxxxx', 'xxxxxxxx', 'xxxxxxxx'/)

  ! cf. rttov_inst_name above and CRTM: v2.1.3 User Guide Table B.1
  ! List of instruments  !!!! HIRS is number 0
  ! xxxxxxxx means crtm does not have corresponding coefficient file.
  ! For instrument names that can not be directly mapped here to names
  ! used in crtm coeff names, they will be re-set in
  ! da_crtm_sensor_descriptor.inc
  Character (len=8), Dimension(0:88) :: crtm_sensor_name  =            &
     & (/ 'hirs    ', 'msu     ', 'ssu     ', 'amsua   ', 'amsub   ',  &
        & 'avhrr   ', 'ssmi    ', 'xxxxxxxx', 'spare   ', 'tmi     ',  &
        & 'ssmis   ', 'airs    ', 'hsb     ', 'modis   ', 'atsr    ',  &
        & 'mhs     ', 'iasi    ', 'amsre   ', 'imgr    ', 'atms    ',  &
        & 'mviri   ', 'seviri  ', 'imgr    ', 'sndr    ', 'imgr    ',  &
        & 'vissr   ', 'xxxxxxxx', 'cris    ', 'spare   ', 'viirs   ',  &
        & 'windsat ', 'xxxxxxxx', 'ssmt1   ', 'ssmt2   ', 'saphir  ',  &
        & 'madras  ', 'spare   ', 'imgr    ', 'reserved', 'reserved',  &
        & 'mwts    ', 'mwhs    ', 'iras    ', 'mwri    ', 'abi     ',  &
        & 'xxxxxxxx', 'xxxxxxxx', 'reserved', 'xxxxxxxx', 'xxxxxxxx',  &
        & 'reserved', 'reserved', 'reserved', 'reserved', 'xxxxxxxx',  &
        & 'xxxxxxxx', 'ahi     ', 'xxxxxxxx', 'xxxxxxxx', 'xxxxxxxx',  &
        & 'xxxxxxxx', 'xxxxxxxx', 'xxxxxxxx', 'amsr2   ', 'vissr   ',  &
        & 'xxxxxxxx', 'xxxxxxxx', 'xxxxxxxx', 'xxxxxxxx', 'xxxxxxxx',  &
        & 'xxxxxxxx', 'xxxxxxxx', 'xxxxxxxx', 'mwhs2   ', 'xxxxxxxx',  &
        & 'xxxxxxxx', 'xxxxxxxx', 'xxxxxxxx', 'xxxxxxxx', 'xxxxxxxx',  &
        & 'xxxxxxxx', 'xxxxxxxx', 'xxxxxxxx', 'xxxxxxxx', 'xxxxxxxx',  &
        & 'xxxxxxxx', 'xxxxxxxx', 'xxxxxxxx', 'xxxxxxxx'/)

#ifdef RTTOV
   type (rttov_coefs), allocatable   :: coefs(:)     ! coefficients structure
   type (rttov_options), allocatable :: opts(:)      ! options structure
   type (rttov_opts_rt_ir), allocatable :: opts_rt_ir(:) ! options structure
   type (rttov_emis_atlas_data) :: atlas
   integer(jpim), allocatable :: atlas_type(:), atlas_id(:)
#endif

   type satinfo_type
      integer, pointer   :: ichan(:)      ! channel index
      integer, pointer   :: iuse (:)      ! usage flag (-1: not use) from radiance info file
      real   , pointer   :: error(:)      ! error Standard Deviation from radiance info file
      real   , pointer   :: error_cld(:)  ! error Standard Deviation for cloudy radiance from radiance info file
      real   , pointer   :: polar(:)      ! polarisation (0:ver; 1:hori) from radiance info file
      real   , pointer   :: error_factor(:) ! error tuning factor ! from error tuning file
     ! new air mass bias correction coefs.
      real   , pointer   :: scanbias(:,:) ! scan bias without latitude band variation
      real   , pointer   :: scanbias_b(:,:,:) ! scan bias with latitude band variation
      real   , pointer   :: bcoef(:,:)   ! airmass predictor bias coefficients
      real   , pointer   :: bcoef0(:)    ! airmass constant coefficient
      real   , pointer   :: error_std(:) ! error standard deviation
   end type satinfo_type

   type (satinfo_type), pointer :: satinfo(:)

   CHARACTER( 80 ), allocatable, save :: Sensor_Descriptor(:)

end module module_radiance