	PROGRAM PROCMK17
C
C	READS MAKEFILE17.RESULTS2 AND ADDS SOME INFORMATION
C		MAKEFILE17.RESULTS2 IS SAME AS MAKEFILE17.RESULTS EXCEPT
C		THAT TIMES ARE ACTUAL TIMES OF SHOCK CROSSING.
C	IF RTEMP LT -1, IT MAKES A PLOT LIKE MAKEFILE17.  IF RTEMP = ACTUAL
C	VALUE, IT DOES NOTHING EXCEPT REWRITE
C	IF RTEMP = 0, THE TIME IS ACTUAL TIME OF THE SHOCK AND IT CALCULATES
C	AND WRITES SSCALE, COORDS, UPSTREAM VEL AND B, RATIO VEL AND B, B.N, V.N
C	IQUAL = 0 MEANS TIME IS FROM MAKEFILE17 AND NOT ACCURATE
C	IQUAL = 1 MEANS TIME HAS BEEN DETERMINED FROM SUMMARY PLOTS
C	IQUAL = 2 MEANS TIME HAS BEEN DETERMINED FROM SPLOT
C	IQUAL = 3 MEANS ANGBN HAS BEEN DETERMINED MANUALLY
C	The program also writes a record of TDS events, to for064.dat.
C	afterward, running ORDER64 puts them in chronological order into
C	for065.dat
C
	INTEGER YYMMDD,HHMMSS,YYYY,HH,MM,DDW,OK,OKT,TMCHANNEL,CH
	INTEGER YYYYW,YYMMDDW,HHW,MMW,NDAY
	INTEGER W_CHANNEL_OPEN
	integer*4 OK1,OK2,SCETI4(2),TDS_COUNT
	INTEGER*4 W_CHANNEL_CLOSE,W_EVENT,RET_SIZE,W_MESSAGES_OFF
	INTEGER*4 W_ITEM_I4,W_ITEM_R4,W_ITEM_R8
	REAL BX(50),BY(50),BZ(50),YY3D(50),VX(50),VY(50),VZ(50)
	REAL VTEMP(3),VTEMP1(3),SHNORM(3)
	REAL*8 SCET8,SCETSV,RGSE,SCETTEMP,SCETT(50),SCETINT
	character*32 ITEM
	character*4 event
	character*80	STREAM
	COMMON /FILEDAY/ STREAM
C
	DATA NERR /0/
	DATA INOUT /0/
	DATA XNOSE,RFLANK/14.6,25.6/
	DATA RE /6.378E3/
	DATA TWOPI /6.2831853/
C	data event /'HK'/
	data event /'CDF'/
	DATA INOUT /1/
	DATA IQUAL /0/
C
	OPEN(UNIT=69,FILE='MAKEFILE17.RESULTS',STATUS='OLD',READONLY)
	WRITE(99,*) ' '
	WRITE(99,*) ' '
 100	CONTINUE
C
C	READ A NEW LINE FROM THE SHOCK CROSSING LIST
C
C	READ(69,1107,END=300) SCETDAY,YYMMDD,HHMMSS,XTEMP,YTEMP,ZTEMP,
	READ(69,*,END=300) SCETDAY,YYMMDD,HHMMSS,XTEMP,YTEMP,ZTEMP,
     1	      RTEMP,INOUT
     1       ,IQUAL,SCALE,ANGBN,SUMSQ,VALF,ALFMACH,VRAT,BRAT,DELB,
     2	      TDS_COUNT,TDSM,PWR,ISPS
C*********
C	IF(IQUAL.EQ.0.OR.TDS_COUNT.EQ.0) THEN
c	IF(ISPS.EQ.0.AND.TDS_COUNT.NE.0) THEN
c	WRITE(99,1107) SCETDAY,YYMMDD,HHMMSS,XTEMP,YTEMP,ZTEMP,RTEMP,INOUT
c     1       ,IQUAL,SCALE,ANGBN,SUMSQ,VALF,ALFMACH,VRAT,BRAT,DELB,
c     2	      TDS_COUNT,TDSM,PWR,ISPS
c	ENDIF
c	GO TO 100
C*********
C	READ(69,*,END=300) SCETDAY,YYMMDD,HHMMSS,XTEMP,YTEMP,ZTEMP,
C     1		RTEMP,INOUT,IQUAL
C	IF(SCETDAY.GT.6549.) STOP
C	rtemp = -1.
	print*,' '
	print*,'input time',scetday,yymmdd,hhmmss
	YYYY = YYMMDD/10000.
	MON = (YYMMDD - 10000*YYYY)/100
	NDAY = MOD(YYMMDD,100)
	HH = HHMMSS/10000.
	MM = (HHMMSS - 10000.*HH)/100.
	SS = MOD(HHMMSS,100)
	SCET8 = DBLE(SCETDAY) + HH/24.D00 + MM/1440.E00 + SS/86400.D00
	print*,'calc scet8,yymmdd ',scet8,yymmdd
C	call w_ur8_to_ymd(scet8,yyyyw,monw,ddw,hhw,mmw,ssw,ms)
C	call w_ur8_from_ymd(scet8,yyyyw,monw,ddw,hhw,mmw,ssw,ms)
C	PRINT*,'return Y M D H M',YYYYW,MONW,DDW,HHW,MMW
C	SCET8 = DBLE(SCETDAY) + HHW/24.D00 + MMW/1440.E00 + SSW/86400.D00
C
C	OPEN A WIND DATA CHANNEL
C
	WRITE(STREAM,30) YYMMDD
 30	FORMAT('WI_LZ_WAV_',I8.8,'_V*.DAT')
	PRINT*,YYMMDD,STREAM
C
C	call w_ur8_to_ydoy(scet8,yyyy,idoy,msec)
C
	print*,'in main, stream=',stream
C
	ok = w_channel_open(tmchannel,stream)
	ch = tmchannel
C
	print*,'open, TMCHANNEL,ch,ok=',TMCHANNEL,ch,ok
	if (ok.ne.1) then
	  print*, 'Cannot open t/m channel'
	endif
c
	scetsv = 0.d00
	print*,'calling channel position 1',scetsv
	ok = w_channel_position(tmchannel,scet8)
	scetsv = scet8
	okt = w_channel_position(tmchannel,scet8)
C
 	ok = w_event(ch,event)
	ITEM = 'WIND_ORBIT_X(GSE)_R8'
	ok = W_ITEM_R8(ch, item, RGSE, 1, ret_size)
	XGSE = RGSE/RE
	ITEM = 'WIND_ORBIT_Y(GSE)_R8'
	ok = W_ITEM_R8(ch, item, RGSE, 1, ret_size)
	YGSE = RGSE/RE
	ITEM = 'WIND_ORBIT_Z(GSE)_R8'
	ok = W_ITEM_R8(ch, item, RGSE, 1, ret_size)
	ZGSE = RGSE/RE
	RRE = SQRT(XGSE**2 + YGSE**2 + ZGSE**2)
	RTEST = RTEMP/RE
C
	IF(RTEMP.LT.0.) GO TO 200
C
	IF(RTEMP.LT..5) THEN
C
C
	  OKT = W_MESSAGES_OFF(ch)
C
	  okt = w_channel_position(tmchannel,scet8)
 	  ok = w_event(ch,event)
C
	  RTEST = RTEMP/RE
C
C		CALCULATE A NEW SCALE
C
	  CC = (YGSE**2+ZGSE**2)/RFLANK**2
	  BB = -XGSE/XNOSE
	  SCALE = .5*(-BB + SQRT(BB**2 + 4.*CC))
c	  CALL SPLOT(TMCHANNEL,SCET8,SCALE,ANGBN,MINUP,TDS_COUNT,PWR,
C     1		TDSM,ISPS)
	ENDIF
C
C	IF(1) GO TO 200
C
c	  ANGBN = -9.
c	  SUMSQ = 0.
c	  ALFMACH = 0.
c	  VALF = 0.
	print 1107, scetday,yymmdd,hhmmss,xtemp,ytemp,ztemp,rtemp,inout
     1		,iqual,scale,angbn,sumsq,VALF,ALFMACH,VRAT,BRAT,DELB,
     1		TDS_COUNT,TDSM,PWR
	WRITE(99,1107) SCETDAY,YYMMDD,HHMMSS,XTEMP,YTEMP,ZTEMP,RTEMP,INOUT
     1       ,IQUAL,SCALE,ANGBN,SUMSQ,VALF,ALFMACH,VRAT,BRAT,DELB,
     2	      TDS_COUNT,TDSM,PWR,ISPS
 1107	FORMAT(F8.0,I9,I7,3F8.2,F7.2,2I3,F6.2,F4.0,F6.3,F6.0,F6.2,3F5.1,
     1	 I4,F6.1,E9.2,I3)
c	at present, 128 characters above
c	endif
	dds = scet8
C
	ok = w_channel_close(TMCHANNEL)
	if(1) GO TO 100
C
c	IF(ABS(RTEST-RRE).LT.1.E-2) GO TO 100
C
C	CALCULATE DISTANCE OF MODEL SHOCK AT THIS XGSE
C
	SCALE = 1.
	XPRM = XGSE
	YPRM = YGSE
	ZPRM = ZGSE
C	PUT IN ABBERATION DUE TO SOLAR WIND
C	SO FAR, I AM ONLY USING AN AVERAGE SOLAR WIND OF 450 KM/SEC, SO
C	ANGLE IS 3.8 DEG. SIN = .0665, COS = .9978
	XPRM = .9978*XGSE + .0665*YGSE
	YPRM = .9978*YGSE - .0665*XGSE
C
C
c	this is just a bank of statements that might be useful
c	  IF(RTEMP.LT..5) CALL
C	SPLOT(TMCHANNEL,SCET8,SCALE,ANGBN,MINUP,TDS_COUNT,PWR,TDSM,ISPS)
c	if(rtemp.lt..5) stop
C
c	IF(RRE.LT.25.) THEN
c	  SCET8 = SCET8 + .5D00
c	  call w_channel_position(ch,scet8)
c	  ITEM = 'WIND_ORBIT_X(GSE)_R8'
c	  ok = W_ITEM_R8(ch, item, RGSE, 1, ret_size)
c	  XGSE = RGSE/RE
c	  ITEM = 'WIND_ORBIT_Y(GSE)_R8'
c	  ok = W_ITEM_R8(ch, item, RGSE, 1, ret_size)
c	  YGSE = RGSE/RE
c	  ITEM = 'WIND_ORBIT_Z(GSE)_R8'
c	  ok = W_ITEM_R8(ch, item, RGSE, 1, ret_size)
c	  ZGSE = RGSE/RE
C	  ITEM = 'EVENT_SCET_R8'
C	  OK = W_ITEM_R8(ch, item, SCET8, 1, ret_size)
c	  ITEM = 'EVENT_SCET'
c	  ok = W_ITEM_I4(ch, item, SCETI4, 2, ret_size)
c	  RRE = SQRT(XGSE**2 + YGSE**2 + ZGSE**2)
C
c	  WRITE(77,1077) SCET8,SCETI4,XGSE,YGSE,ZGSE,RRE
C
c	ENDIF
C
C	ITEM = 'WIND_MFI_BPHI(GSE)_R4'
C	ok = W_ITEM_R4(ch, item, AZMAG, 1, ret_size)
C	ITEM = 'MAG_ELEVATION'
C	ok = W_ITEM_I4(ch, item, MAGEL, 1, ret_size)
C	ITEM = 'SUN_ANGLE'
C	ok = W_ITEM_I4(ch, item, SUNCLOCK, 1, ret_size)
C	ITEM = 'WIND_3DP_E_TEMP_R4'
C	ok = W_ITEM_R4(ch, item, TEMPE, 1, ret_size)
C	ITEM = 'WIND_3DP_ION_TEMP_R4'
C	ok = W_ITEM_R4(ch, item, TEMPI, 1, ret_size)
C	ITEM = 'C	  SNX = 1./XNOSE
C	  SNY = 2.*YGSE/(25.6*SCALE)**2
C	  SNZ = 2.*ZGSE/(25.6*SCALE)**2
C	  SNORM = SQRT(SNX**2 + SNY**2 + SNZ**2)
C	  PRINT*,N,orbtime,SNORM,bMAG(N),BX(N)
C	  BDOTN = (BX(N)*SNX + BY(N)*SNY + BZ(N)*SNZ)/SNORM/BMAG(N)
c	WIND_3DP_ION_DENSITY_R4'
C	ok = W_ITEM_R4(ch, item, DENS, 1, ret_size)
C	ok = W_ITEM_R4(ch, item, BMAG, 1, ret_size)
C	ITEM = 'WIND_SPIN_RATE_R4'
C	ok = W_ITEM_R4(ch, item, SPINRATE, 1, ret_size)
C	if(ok.ne.1) then
C	  spinrate = 2.
C	endif
C
 200	CONTINUE
C
C	CALCULATE SCALE FOR THIS SHOCK CROSSING
C
	ITEM = 'WIND_ORBIT_X(GSE)_R8'
	ok = W_ITEM_R8(ch, item, RGSE, 1, ret_size)
	XGSE = RGSE/RE
	ITEM = 'WIND_ORBIT_Y(GSE)_R8'
	ok = W_ITEM_R8(ch, item, RGSE, 1, ret_size)
	YGSE = RGSE/RE
	ITEM = 'WIND_ORBIT_Z(GSE)_R8'
	ok = W_ITEM_R8(ch, item, RGSE, 1, ret_size)
	ZGSE = RGSE/RE
	RRE = SQRT(XGSE**2 + YGSE**2 + ZGSE**2)
	CC = (YGSE**2+ZGSE**2)/RFLANK**2
	BB = -XGSE/XNOSE
	SCALE = .5*(-BB + SQRT(BB**2 + 4.*CC))
C	print*,' scale after 200 ',scale
	  SNX = 1./XNOSE
	  SNY = 2.*YGSE/(25.6*SCALE)**2
	  SNZ = 2.*ZGSE/(25.6*SCALE)**2
	  SNORM = SQRT(SNX**2 + SNY**2 + SNZ**2)
C	  PRINT*,N,orbtime,SNORM,bMAG,BX(N)
C
C	AVERAGE B FOR MINUP MINUTES UPSTREAM OF SHOCK
C
	MINUP = 10
	UPN = 2*(MINUP+2)*60./46.
	NPTUPN = UPN
	BXAVR = 0.
	BYAVR = 0.
	BZAVR = 0.
	DENS = 0.
	SAMPL = 1.E-9
	scettemp = scet8
C
C	BACKUP IF THIS IS AN INBOUND PASS, LEAVE TWO MINUTES BLANK
C
C		INTERVAL FOR MFI DATA IS 46 SEC
C	IF(inout.eq.1) then
	  scettemp = scet8 - (minup+2)*1.d00/1440.d00
C	ELSE
C	  scettemp = scet8 + 2.d00/1440.d00
C	ENDIF
	okt = w_channel_position(tmchannel,scettemp)
C
C	GET BOTH DOWNSTREAM AND UPSTREAM DATA
C
 	ok = w_event(ch,event)
 	ITEM = 'WIND_MFI_SCET_R8'
	  ok = W_ITEM_R8(ch, item, SCETT, NPTUPN, ret_size)
	  IF(OK.NE.1) THEN
	    PRINT*,'PROGRAM FAILED TO FIND CDF DATA,OK,YYMMDD=',OK,YYMMDD
	    WRITE(99,1107) SCETDAY,YYMMDD,HHMMSS,XTEMP,YTEMP,ZTEMP,RTEMP,INOUT
     1       ,IQUAL,SCALE
	    GO TO 100
	  ENDIF
	print*,'after scett item, nptupn,ret_size=', scett(1),scett(RET_SIZE),
     1   nptupn,ret_size
	NPTUPN = RET_SIZE
 	ITEM = 'WIND_MFI_BX(GSE)_R4'
	  ok = W_ITEM_R4(ch, item, BX, NPTUPN, ret_size)
	ITEM = 'WIND_MFI_BY(GSE)_R4'
	  ok = W_ITEM_R4(ch, item, BY, NPTUPN, ret_size)
	ITEM = 'WIND_MFI_BZ(GSE)_R4'
	  ok = W_ITEM_R4(ch, item, BZ, NPTUPN, ret_size)
	ITEM = 'WIND_3DP_ION_DENSITY_R4'
	ok = W_ITEM_R4(ch, item, YY3D, NPTUPN, ret_size)
	ITEM = 'WIND_3DP_ION_VX(GSE)_R4'
	ok = W_ITEM_R4(ch, item, VX, NPTUPN, ret_size)
	ITEM = 'WIND_3DP_ION_VY(GSE)_R4'
	ok = W_ITEM_R4(ch, item, VY, NPTUPN, ret_size)
	ITEM = 'WIND_3DP_ION_VZ(GSE)_R4'
	ok = W_ITEM_R4(ch, item, VZ, NPTUPN, ret_size)
C	print*,'bx',(bx(I),I=1,NPTUPN)
C	print*,'by',(by(I),I=1,NPTUPN)
C	print*,'bz',(bz(I),I=1,NPTUPN)
C	print*,'ST',(scett(I),I=1,NPTUPN)
C
C	UPSTREAM AVERAGE
C
c	do i = 1,nptupn
c	print*,i,scett(i),bx(i),by(i),bz(i)
c	enddo
	BXAVR = 0.
	BYAVR = 0.
	BZAVR = 0.
	VXAVR = 0.
	VYAVR = 0.
	VZAVR = 0.
	SUMSQ = 0.
	DENS = 0.
	COUNT = 1.E-9
	  IF(INOUT.EQ.0) THEN
C		IT'S OUTBOUND, AVERAGE FROM SHOCK TIME + 2 MIN TO + MINUP+2
	    PPBN1 = DMOD(SCET8,1.d00)*24.D00 + 2.D00/60.D00
	    PPBN2 = PPBN1 + MINUP/60.D00
	  ELSE
	    PPBN2 = DMOD(SCET8,1.D00)*24.D00 - 2.D00/60.D00
	    PPBN1 = PPBN2 - DFLOAT(MINUP)/60.D00
	  ENDIF
	SCETINT = DINT(SCET8)
	print*,'ppbn',scet8,SCETINT,ppbn1,ppbn2
	time = DMOD(scet8,1.D00)*24.d00
	N = 0
	DOWHILE(TIME.LT.PPBN1.AND.N.LE.NPTUPN)
	  N = N+1
	  IF(YY3D(N).GT.0.) DENS0 = YY3D(N)
	  time = DMOD(scett(n),1.D00)*24.d00
	ENDDO
	DO N = 1,NPTUPN
	  time = DMOD(scett(n),1.D00)*24.d00
	  IF(TIME.LE.PPBN2.AND.TIME.GE.PPBN1) THEN
	  print*,'pp check up',time,ppbn2,n,nptupn
	    COUNT = COUNT+1.
	    BXAVR = BXAVR + BX(N)
	    BYAVR = BYAVR + BY(N)
	    BZAVR = BZAVR + BZ(N)
	    SUMSQ = SUMSQ + BX(N)**2 + BY(N)**2 + BZ(N)**2
	print*,n,scett(n),bx(n),by(n),bz(n)
	    IF(YY3D(N).GT.0.) THEN
	      DENS = DENS + YY3D(N)
	      DENS0 = YY3D(N)
	    ELSE
	      DENS = DENS + DENS0
	    ENDIF
	    VXAVR = VXAVR + VX(N)
	    VYAVR = VYAVR + VY(N)
	    VZAVR = VZAVR + VZ(N)
	  ENDIF
	ENDDO
	BXAVR = BXAVR/COUNT
	BYAVR = BYAVR/COUNT
	BZAVR = BZAVR/COUNT
	VXAVR = VXAVR/COUNT
	VYAVR = VYAVR/COUNT
	VZAVR = VZAVR/COUNT
	DENS = DENS/COUNT
C	IF(DENS.LT.0.) DENS = 7.
	SQAVR = BXAVR**2 + BYAVR**2 + BZAVR**2
	SUMSQ = SUMSQ/COUNT - SQAVR
	print*,'shock normal',snx/snorm,sny/snorm,snz/snorm
	print*,'bAVR',bXAVR,BYAVR,BZAVR,COUNT
	IF(SQAVR.NE.0.) SUMSQ = SUMSQ/SQAVR
	BMAG = SQRT(BXAVR**2+BYAVR**2+BZAVR**2)
	BDOTN = 0.
	IF(SNORM*BMAG.NE.0.)
     1		BDOTN = (BXAVR*SNX + BYAVR*SNY + BZAVR*SNZ)/SNORM/BMAG
	BDOTN = ABS(BDOTN)
	ANGBN = ACOSD(BDOTN)
	print*,'bmag,angbn,SUMSQ',bmag,angbn,SUMSQ
	VALF = 0.
	IF(DENS.GT.0.) VALF = 21.9*BMAG/SQRT(DENS)  !Bmag in nT, dens in cu.cm.
C
	VDOTN = (VXAVR*SNX + VYAVR*SNY + VZAVR*SNZ)/SNORM
	VDOTN = ABS(VDOTN)
	ALFMACH = 0.
	IF(VALF.NE.0.) ALFMACH = VDOTN/VALF
C
C	DOWNSTREAM AVERAGE
C
	BXAVRD = 0.
	BYAVRD = 0.
	BZAVRD = 0.
	VXAVRD = 0.
	VYAVRD = 0.
	VZAVRD = 0.
	SUMSQD = 0.
	COUNT = 1.E-9
	  IF(INOUT.EQ.0) THEN
C		IT'S OUTBOUND, AVERAGE FROM SHOCK TIME MINUP-2 MIN TO -2
	    PPBN2 = DMOD(SCET8,1.D00)*24.D00 - 2.D00/60.D00
	    PPBN1 = PPBN2 - DFLOAT(MINUP)/60.D00
	  ELSE
	    PPBN1 = DMOD(SCET8,1.d00)*24.D00 + 2.D00/60.D00
	    PPBN2 = PPBN1 + MINUP/60.D00
	  ENDIF
	SCETINT = DINT(SCET8)
	print*,'ppbn',scet8,SCETINT,ppbn1,ppbn2
	DO N = 1,NPTUPN
	  time = DMOD(scett(n),1.D00)*24.d00
	  IF(TIME.LE.PPBN2.AND.TIME.GE.PPBN1) THEN
	  print*,'pp check down',time,ppbn2,n,nptupn
	    COUNT = COUNT+1.
	    BXAVRD = BXAVRD + BX(N)
	    BYAVRD = BYAVRD + BY(N)
	    BZAVRD = BZAVRD + BZ(N)
	    SUMSQD = SUMSQ + BX(N)**2 + BY(N)**2 + BZ(N)**2
	print*,n,scett(n),bx(n),by(n),bz(n)
	    VXAVRD = VXAVRD + VX(N)
	    VYAVRD = VYAVRD + VY(N)
	    VZAVRD = VZAVRD + VZ(N)
	  ENDIF
	ENDDO
	BXAVRD = BXAVRD/COUNT
	BYAVRD = BYAVRD/COUNT
	BZAVRD = BZAVRD/COUNT
	VXAVRD = VXAVRD/COUNT
	VYAVRD = VYAVRD/COUNT
	VZAVRD = VZAVRD/COUNT
C	IF(DENS.LT.0.) DENS = 7.
	SQAVRD = BXAVRD**2 + BYAVRD**2 + BZAVRD**2
	SUMSQD = SUMSQD/COUNT - SQAVR
	print*,'shock normal',snx/snorm,sny/snorm,snz/snorm
	print*,'bAVRD',bXAVRD,BYAVRD,BZAVRD,COUNT
	IF(SQAVRD.NE.0.) SUMSQD = SUMSQD/SQAVRD
	BMAG = SQRT(BXAVRD**2+BYAVRD**2+BZAVRD**2)
	DELB = SQRT((BXAVRD-BXAVR)**2+(BYAVRD-BYAVR)**2+(BZAVRD-BZAVR)**2)
C	BDOTN = 0.
C	IF(SNORM*BMAG.NE.0.)
C     1		BDOTN = (BXAVR*SNX + BYAVR*SNY + BZAVR*SNZ)/SNORM/BMAG
C	BDOTN = ABS(BDOTN)
C	ANGBN = ACOSD(BDOTN)
	print*,'bmag,angbn,SUMSQ',bmag,angbn,SUMSQ
C	VALF = 0.
C	IF(DENS.GT.0.) VALF = 21.9*BMAG/SQRT(DENS)  !Bmag in nT, dens in cu.cm.
C
	VTEMP(1) = BXAVR
	VTEMP(2) = BYAVR
	VTEMP(3) = BZAVR
	SHNORM(1) = SNX/SNORM
	SHNORM(2) = SNY/SNORM
	SHNORM(3) = SNZ/SNORM
	CALL CROSSP(VTEMP,SHNORM,VTEMP1,BTAN)
C	print*,'up',vtemp
C	print*,'up',shnorm
C	print*,'up',vtemp1
C	print*,'up',btan
	VTEMP(1) = BXAVRD
	VTEMP(2) = BYAVRD
	VTEMP(3) = BZAVRD
	CALL CROSSP(VTEMP,SHNORM,VTEMP1,BTAND)
C	print*,'dn',vtemp
C	print*,'dn',shnorm
C	print*,'dn',vtemp1
C	print*,'dn',btand
	BRAT = 0.
	IF(BTAN.NE.0.) BRAT = BTAND/BTAN
C
	VDOTND = (VXAVRD*SNX + VYAVRD*SNY + VZAVRD*SNZ)/SNORM
	VDOTND = ABS(VDOTND)
	VRAT = 0.
	IF(VDOTND.NE.0.) VRAT = VDOTN/VDOTND
C
C	ALFMACH = 0.
C	IF(VALF.NE.0.) ALFMACH = VDOTN/VALF
C
c	IQUAL=1
C
	print*,'at rtemp test, rtemp = ',rtemp
	IF(RTEMP.LT.-.5) CALL
     1	 SPLOT(TMCHANNEL,SCET8,SCALE,ANGBN,MINUP,TDS_COUNT,PWR,TDSM,ISPS)
	print 1107, scetday,yymmdd,hhmmss,XGSE,YGSE,ZGSE,RRE,inout
     1	  ,iqual,scale,angbn,sumsq,VALF,ALFMACH,VRAT,BRAT,DELB,
     1		TDS_COUNT,TDSM,PWR,ISPS
C	print*,'delb',delb
	WRITE(99,1107) SCETDAY,YYMMDD,HHMMSS,XGSE,YGSE,ZGSE,RRE,INOUT
     1       ,IQUAL,SCALE,ANGBN,SUMSQ,VALF,ALFMACH,VRAT,BRAT,DELB,
     2	      TDS_COUNT,TDSM,PWR,ISPS
c	okt = w_channel_position(tmchannel,scet8)
C	if(1) stop
	ok = w_channel_close(TMCHANNEL)
	GO TO 100
 300	CONTINUE
	STOP
	END
	SUBROUTINE SPLOT(CDFCH,SCET,SCALE0,ANGBN,MINUP,TDSC,PWR,TDSM,ISPS)
C
C	PLOT THINGS TO IDENTIFY SHOCK POSITION, NAMELY B, DENSITY,
C		SW VELOCITY
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
	COMMON /FILEDAY/ TODAY
	character*32 ITEM
	character*80 TODAY,STR
	character*4 event
	INTEGER*4 CH,NDAY,ret_size,ok,okt
	INTEGER*4 W_EVENT,W_CHANNEL_OPEN,W_CHANNEL_CLOSE,CDFCH,TDSCH
	INTEGER*4 NDATA(2050),SCETI4(2),NEVT,TDS_CHANNEL,TDS_COUNT,TDSC
	INTEGER*4 TDSF_COUNT,FILL_COUNT
	REAL YY(600),PP(600),YY3D(600),YY3S(600),YYSD(600),YYSS(600)
	REAL PP1(600),XRE(600),YRE(600),ZRE(600),VDATA(2050),SPECT(1025)
	REAL SSCALE(600),BDOTN(600),EFFLEN(9)
	REAL*8 SCET,SCET1,SCET2,SCSV(600),SCETT,RGSE,DNDAY,SCETTDS1,SCETTDS2
	REAL*8 SCETINT
	DATA RE /6378./
	DATA AVRF,UPVSD/ 0., 0./
	DATA ISIZE /2048/
	DATA XNOSE,RFLANK/14.6,25.6/
	DATA RNOSE0,RFLANK0 /14.6,25.6/
	DATA EFFLEN /41.1, 3.79, 2.17, 41.1, 3.79, 2.17, 3*1./
	DATA NPLOTS /0/
C
	event = 'CDF'
	ITERM = -1
C	ITERM = -3
C	ITERM = 3
C
C	PLOT 4 HOURS CENTERED ON SCET
C
	NDAY = SCET
	print*,'at call splot, nday,scet of shock crossing=',nday,scet
	SCETINT = DINT(SCET)
	SCET1 = SCET - 2.D00/24.D00
	DNDAY = DBLE(NDAY)
	SCET1 = DMAX1(DNDAY,SCET1)
	SCET2 = SCET1 + 4.D00/24.D00
	SCET2 = DMIN1(SCET2,DNDAY + .999D00)
	PRINT*,'SPLOT CALLED, SCET1,SCET,SCET2=',SCET1,SCET,SCET2
	PRINT*,'TODAY in SPLOT',TODAY
	PRINT*,'NDAY,SCET1,2',NDAY,SCET1,SCET2
C
	CALL MGOINIT
	CALL MGOSETUP(ITERM)
	CALL MGOERASE
	NPLOTS = NPLOTS+1
C
C	PLOT MAGNITUDE OF B
C
C	NUMBER OF MFI POINTS IN FOUR HOURS
	NGET = 240./.75
	YMAX = 5.
C	SET POSITION TO BEGINNING OF DAY
	scett = 0.d00
	call w_channel_position(CDFCH,scett)
	call w_channel_position(CDFCH,scet1)
	NP = 0
C
 	  ok = w_event(CDFCH,EVENT)
	  IF(OK.EQ.1) THEN
	    ITEM = 'WIND_MFI_SCET_R8'
	    ok = W_ITEM_R8(cdfch, item, SCSV, NGET, ret_size)
	    ITEM = 'WIND_MFI_BMAG_R4'
	    ok = W_ITEM_R4(cdfch, item, YY, NGET, ret_size)
C	    print*,'load',n,np,ret_size,scsv(np),yy(np)
	  ELSE
	    IF(OK.EQ.82) GO TO 100
	  ENDIF
C	  DO NP = 1,RET_SIZE
	    NP = 0
	  DOWHILE(SCSV(NP).LT.SCET2)
	    NP = NP+1
	    PP(NP) = (SCSV(NP) - NDAY)*24.D00
	    YMAX = AMAX1(YY(NP),YMAX)
	ENDDO
	NP = MIN0(NP,NGET,RET_SIZE)
	NP = NP-1
C
 100 	  print*,'asked for and got, for MFI',nget,NP
	PRINT*,'1ST,LAST TIME',PP(1),PP(NP)
	PRINT*,'1ST,LAST BMAG',YY(1),YY(NP)
	CALL MGOWINDOW(1,6,1)
	XSTRT = PP(1) - .1
	XEND = (SCET2-NDAY)*24.D00 + .1
	CALL MGOSETLIM(XSTRT,0.,XEND,1.1*YMAX)
	IF(NP.GT.0) CALL MGOCONNECT(PP,YY,NP)
	PPSH = (SCET - NDAY)*24.D00
	CALL MGOSETLTYPE(1)
	CALL MGORELOCATE(PPSH,0.)
	CALL MGODRAW(PPSH,1.1*YMAX)
	CALL MGOSETLTYPE(0)
C	CALL MGOSETEXPAND(.8)
	CALL MGOBOX(1,2)
	WRITE(STR,1001) TODAY(11:14),TODAY(15:16),TODAY(17:18)
 1001	FORMAT('HOURS OF ',A4,'/',A2,'/',A2)
	CALL MGOXLABEL(19,STR)
	CALL MGOYLABEL(3,'|B|')
C
C	CALL MGOSETEXPAND(1.)
C	TRANGE = GY2-GY1
C	TINC = .07*TRANGE
C	XTITLE = GX2 +.005*(GX2-GX1)
C	YTITLE = GY2
C	CALL MGOSETEXPAND(.8)
	PRINT*,'TODAY in SPLOT 2',TODAY
C
C	PLOT 3DP,SWE DENSITY,SOLARWIND SPEED
C		SWE IS DOTTED, 3DP IS SOLID
	scett = 0.d00
	call w_channel_position(CDFCH,scett)
	call w_channel_position(CDFCH,scet1)
	print*,'3DP channel set to',cdfch,scet1
C	NUMBER OF 3DP POINTS IN FOUR HOURS
	NGET = 240./.75
 	ok = w_event(CDFCH,EVENT)
        ITEM = 'WIND_SWE_SCET_R8'
	ok = W_ITEM_R8(cdfch, item, SCSV, NGET, ret_size)
 	print*,'asked for SCET8 and got',nget,RET_SIZE
	ITEM = 'WIND_SWE_DENSITY_R4'
	ok = W_ITEM_R4(cdfch, item, YY, NGET, ret_size)
	ITEM = 'WIND_SWE_VX(GSE)_R4'
	ok = W_ITEM_R4(cdfch, item, YYSS, NGET, ret_size)
C	PRINT*,'TODAY in SPLOT 3',TODAY

	YMAX = 5.
C	YSMAX = 1100.
	YSMAX = -10000.
	YSMIN = 10000.
	NP = 0
	N = 1
C	DO N = 1,NGET
	DOWHILE(SCSV(N).LT.SCET2.AND.N.LE.RET_SIZE)
	  IF(YY(N).GT.0.) THEN
	    NP = NP+1
	    PP(NP) = (SCSV(N) - NDAY)*24.D00
	    YY(NP) = YY(N)
	    YYSS(NP) = ABS(YYSS(N))
	    YMAX = AMAX1(YY(NP),YMAX)
	    YSMAX = AMAX1(YYSS(NP),YSMAX)
	    YSMIN = AMIN1(YYSS(NP),YSMIN)
	  ENDIF
	  N = N+1
	ENDDO
 	print*,'asked for SWE_DENS and got',nget,RET_SIZE,NP
	NPS = NP
	IF(NPS.GT.0) THEN
	  PRINT*,'SWE MIN,MAX',YSMIN,YSMAX
	  PRINT*,'1ST,LAST TIME',NPS,PP(1),PP(NPS)
	  PRINT*,'1ST,LAST SWE VX',NPS,YYSS(1),YYSS(NPS)
	ELSE
	  PRINT*,'NO SWE DATA'
	ENDIF
C
        ITEM = 'WIND_3DP_SCET_R8'
	ok = W_ITEM_R8(cdfch, item, SCSV, NGET, ret_size)
	ITEM = 'WIND_3DP_ION_DENSITY_R4'
	ok = W_ITEM_R4(cdfch, item, YY3D, NGET, ret_size)
	ITEM = 'WIND_3DP_ION_VX(GSE)_R4'
	ok = W_ITEM_R4(cdfch, item, YY3S, NGET, ret_size)
C
c***********
c	IF(ITERM.LT.0) THEN
c	  CALL MGOPRNTPLOT(NVEC)
c	  PRINT*,' NO. VECTORS PLOTTED',NVEC
c	ELSE
c	  CALL MGOTCLOSE
c	ENDIF
c	print*,'nget=',nget
c	print*,'return from splot'
c	if(1) return
c***********
	NP = 0
	N = 1
C	DO N = 1,NGET
	DOWHILE(SCSV(N).LT.SCET2.AND.N.LE.RET_SIZE)
	  IF(YY3D(N).GT.0..AND.YY3S(N).GT.-1.E8) THEN
	    NP = NP+1
	    PP1(NP) = (SCSV(N) - NDAY)*24.D00
	    SCSV(NP) = SCSV(N)
	    YY3D(NP) = YY3D(N)
	    YY3S(NP) = ABS(YY3S(N))
	    YMAX  = AMAX1(YY3D(NP),YMAX)
	    YSMAX = AMAX1(YY3S(NP),YSMAX)
	    YSMIN = AMIN1(YY3S(NP),YSMIN)
	  ENDIF
	  N = N+1
	ENDDO
	NP3 = NP-1
	IF(NP3.GT.0) THEN
	  PRINT*,'1ST,LAST TIME',NP3,PP1(1),PP1(NP3)
	  PRINT*,'1ST,LAST 3DP',NP3,YY3D(1),YY3D(NP3)
	ELSE
	  PRINT*,'NO 3DP DATA'
	ENDIF
C
	PRINT*,'TODAY in SPLOT 4',TODAY
	CALL MGOWINDOW(1,6,2)
	CALL MGOSETLIM(XSTRT,0.,XEND,YMAX)
	CALL MGOSETLTYPE(1)
	IF(NPS.GT.0) CALL MGOCONNECT(PP,YY,NPS)		! SWE ION DENSITY
	CALL MGOSETLTYPE(0)
	IF(NP3.GT.0) CALL MGOCONNECT(PP1,YY3D,NP3)	! 3DP ION DENSITY
C	CALL MGOSETEXPAND(.8)
	CALL MGOBOX(1,2)
	CALL MGOYLABEL(7,'DENSITY')
C
C	PLOT SOLAR WIND SPEED
C
	CALL MGOWINDOW(1,6,3)
	CALL MGOSETLIM(XSTRT,YSMIN,XEND,YSMAX)
	CALL MGOSETLTYPE(1)
	IF(NPS.GT.0) CALL MGOCONNECT(PP,YYSS,NPS)		! SWE VX
	CALL MGOSETLTYPE(0)
	IF(NP3.GT.0) CALL MGOCONNECT(PP1,YY3S,NP3)		! 3DP VX
	CALL MGOBOX(1,2)
	CALL MGOYLABEL(6,'ION VX')
C
C	PLOT B dot N
C
C	this is done by expanding the model shock uniformly, by multiplying
C	RNOSE0 and RFLANKO by a factor SSCALE, so that the expanded model
C	shock passes through the orbit point.  This gives a quadratic
C	equation for SSCALE, which will be plotted in the next window.
C	Then, since the equation of the model shock can be written
C	x/rnose + (y^2 + z^2)/rflank^2 = 1, the normal is the gradient
C	[1./rnose, 2 y/rflank^2, 2 z/rflank^2]
C
	call w_channel_position(CDFCH,scet)
 	ok = w_event(CDFCH,event)
	ITEM = 'WIND_ORBIT_X(GSE)_R8'
	ok = W_ITEM_R8(cdfch, item, RGSE, 1, ret_size)
	XGSE = RGSE/RE
	ITEM = 'WIND_ORBIT_Y(GSE)_R8'
	ok = W_ITEM_R8(cdfch, item, RGSE, 1, ret_size)
	YGSE = RGSE/RE
	ITEM = 'WIND_ORBIT_Z(GSE)_R8'
	ok = W_ITEM_R8(cdfch, item, RGSE, 1, ret_size)
	ZGSE = RGSE/RE
	SNX = 1./XNOSE
	SNY = 2.*YGSE/(25.6*SCALE0)**2
	SNZ = 2.*ZGSE/(25.6*SCALE0)**2
	SNORM = SQRT(SNX**2 + SNY**2 + SNZ**2)
C
	scett = 0.d00
	call w_channel_position(CDFCH,scett)
 	ok = w_event(CDFCH,event)
c	print*,'channel set to 0.',cdfch,scett
	call w_channel_position(CDFCH,scet1)
c 	ok = w_event(CDFCH,event)
	SSMAX = 0.
	SSMIN = 100.
	BDMAX = 90.
	BDMIN = 0.
C
C	calculate times corresponding to 2 min to 2+minup min before shock
C
	print*,'going to 1,np3 loop',np3
	    PPBN1 = (SCET-NDAY)*24.D00 - 2.D00/60.D00
	    PPBN2 = PPBN1 - MINUP/60.D00
	DO N = 1,NP3
  	  ok = w_event(CDFCH,event)
	  SCETT = SCSV(N)
	  ITEM = 'WIND_ORBIT_X(GSE)_R8'
	  ok = W_ITEM_R8(cdfch, item, RGSE, 1, ret_size)
	  XRE(N) = RGSE/RE
	  ITEM = 'WIND_ORBIT_Y(GSE)_R8'
	  ok = W_ITEM_R8(cdfch, item, RGSE, 1, ret_size)
	  YRE(N) = RGSE/RE
	  ITEM = 'WIND_ORBIT_Z(GSE)_R8'
	  ok = W_ITEM_R8(cdfch, item, RGSE, 1, ret_size)
	  ZRE(N) = RGSE/RE
	  SSCALE(N) = .5*(XRE(N)/RNOSE0 + SQRT((XRE(N)/RNOSE0)**2
     1	     + 4.*(YRE(N)**2+ZRE(N)**2)/RFLANK0**2))
	  SSMAX = AMAX1(SSMAX,SSCALE(N))
	  SSMIN = AMIN1(SSMIN,SSCALE(N))
	  ITEM = 'WIND_MFI_BX(GSE)_R4'
	  ok = W_ITEM_R4(cdfch, item, BX, 1, ret_size)
	  ITEM = 'WIND_MFI_BY(GSE)_R4'
	  ok = W_ITEM_R4(cdfch, item, BY, 1, ret_size)
	  ITEM = 'WIND_MFI_BZ(GSE)_R4'
	  ok = W_ITEM_R4(cdfch, item, BZ, 1, ret_size)
	  BNORM = SQRT(BX**2+BY**2+BZ**2)
	  XNORM = 1./SSCALE(N)/RNOSE0
	  YNORM = 2.*YRE(N)/(SSCALE(N)*RFLANK0)**2
	  ZNORM = 2.*ZRE(N)/(SSCALE(N)*RFLANK0)**2
	  RNORM = SQRT(XNORM**2+YNORM**2+ZNORM**2)
	  BDOTN(N) = (BX*SNX + BY*SNY + BZ*SNZ)/BNORM/SNORM
	  dot = bdotn(n)
	  BDOTN(N) = ACOSD(ABS(BDOTN(N)))
	write(77,1077) n,bx,by,bz,dot,bdotn(n)
 1077	format(i5,6f10.3)
	  BDMAX = AMAX1(BDMAX,BDOTN(N))
	  BDMIN = AMIN1(BDMIN,BDOTN(N))
	  time = (scett-nday)*24.d00
	ENDDO
C
	print*,'end np3 loop'
C
C	PLOT THETA BN
C
	CALL MGOWINDOW(1,6,4)
	CALL MGOSETLIM(XSTRT,BDMIN,XEND,BDMAX)
	IF(NP3.GT.0) CALL MGOCONNECT(PP1,BDOTN,NP3)
C	  DRAW AVERAGE BN ANGLE
	IF(ANGBN.GT.0.) THEN
	  CALL MGOSETLTYPE(1)
C	  USE SCALE TO DETERMINE INOUT
	  IF(SSCALE(1).LT.SSCALE(NP3)) THEN
C		IT'S OUTBOUND, DRAW FROM SHOCK TIME + 2 MIN TO + MINUP+2
	    PPBN1 = (SCET-NDAY)*24.D00 + 2.D00/60.D00
	    PPBN2 = PPBN1 + MINUP/60.D00
	  ELSE
	    PPBN1 = (SCET-NDAY)*24.D00 - 2.D00/60.D00
	    PPBN2 = PPBN1 - MINUP/60.D00
	  ENDIF
	  CALL MGORELOCATE(PPBN1,ANGBN)
	  CALL MGODRAW(PPBN2,ANGBN)
	  CALL MGOSETLTYPE(0)
	ENDIF
	CALL MGOBOX(1,2)
	CALL MGOYLABEL(10,'ANG(B\u.N)')
C
C	PLOT SCALE
C
	CALL MGOWINDOW(1,6,5)
	CALL MGOSETLIM(XSTRT,SSMIN,XEND,SSMAX)
	IF(NP3.GT.0) CALL MGOCONNECT(PP1,SSCALE,NP3)
	CALL MGOSETLTYPE(1)
	CALL MGORELOCATE(PPSH,SSMIN)
	CALL MGODRAW(PPSH,SSMAX)
	CALL MGOSETLTYPE(0)
	CALL MGOBOX(1,2)
	CALL MGOYLABEL(5,'SCALE')
	XPR = XSTRT + .02*(XEND-XSTRT)
	YPR = SSMIN + .5*(SSMAX-SSMIN)
	CALL MGORELOCATE(XPR,YPR)
	WRITE(STR,1003) SCALE0
 1003	FORMAT('INPUT SCALE',F5.2)
	CALL MGOLABEL(16,STR)
C
C	PLOT TDS EVENTS
C
	TDS_COUNT = 0
	TDSF_COUNT = 0
	FILL_COUNT = 0
C	  COUNT EVENTS WITHIN 5 MIN OF CROSSING TIME
	SCETTDS1 = SCET - 5.D00/1440.D00
	SCETTDS2 = SCET + 5.D00/1440.D00
	EVENT = 'TDSF'
	YMAX = 150.
	CALL MGOWINDOW(1,6,6)
	CALL MGOSETLIM(XSTRT,0.,XEND,YMAX)
	CALL MGOBOX(1,2)
	CALL MGOYLABEL(3,'TDS')
C
	tdsch = cdfch
	EVENT = 'TDSF'
	scett = 0.d00
	print*,'going to get TDS events'
	call w_channel_position(TDSCH,scett)
	call w_channel_position(TDSCH,scet1)
	print*,'TDS channel set to',TDSCH,scet1
	PWR = 0.
	TDSM = 0.
 200	OK = W_EVENT(TDSCH,EVENT)
	print*,'tds event, event, ok=  ',event,ok
	IF(OK.EQ.82) GO TO 250
	IF(OK.NE.1) GO TO 200
C	ITEM = 'DATA'
C	ok = W_ITEM_I4(TDSCH, item, NDATA, ISIZE, ret_size)
	ITEM = 'EVENT_NUMBER'
	okt = W_ITEM_I4(TDSCH, item, NEVT, 1, ret_size)
C	print*,'tds event, event, ok, no.=  ',event,ok,nevt
C	the following was necessary to overcome a problem in tds_phys
	if(ok.ne.1) go to 200
	IPRC = 4
	CALL TDS_PHYS(TDSCH,IPRC,NDATA,VDATA,SPECT)
	ITEM = 'EVENT_SCET'
	ok = W_ITEM_I4(TDSCH, item, SCETI4, 2, ret_size)
	ITEM = 'FAST_RX_SPEED'
	ok = W_ITEM_I4(cdfch, item, ISPS, 1, ret_size)
C	ITEM = 'EVENT_TRUE_SCET_R8'
C	ITEM = 'EVENT_SCET_R8'
C	ok = W_ITEM_R8(TDSCH, item, SCETT, 1, ret_size)
C
	ITEM = 'CHANNEL'
	ok = W_ITEM_I4(TDSCH, item, TDS_CHANNEL, 1, ret_size)
	EFL = EFFLEN(TDS_CHANNEL)
C
	ITEM = 'EVENT_NUMBER'
	ok = W_ITEM_I4(TDSCH, item, NEVT, 1, ret_size)
C	IF(SCETT.GE.SCETTDS1.AND.SCETT.LE.SCETTDS2) print*,'tds',sceti4,nevt
	ITEM = 'FAST_RX_SPEED_R4'
	ok = W_ITEM_R4(TDSCH, item, SPS, 1, ret_size)
	ITEM = 'FAST_SAMPLER_THRESHOLD'
	ok = W_ITEM_R4(TDSCH, item, VMIN, 1, ret_size)
	NVMAX = MAX0(NDATA(1023),NDATA(1024),NDATA(1025))
	NVMIN = MIN0(NDATA(1023),NDATA(1024),NDATA(1025))
	VMAX = MAX0(NVMAX-128,128-NVMIN)
C	ITEM = 'EVENT_CENTER_SCET_R8'
	ITEM = 'EVENT_SCET_R8'
	ok = W_ITEM_R8(TDSCH, item, SCETT, 1, ret_size)
C	print*,'draw check, scet1,T,2',scet1,scett,scet2
	IF(SCETT.GE.SCET1.AND.SCETT.LE.SCET2) THEN
	  TDSTIME = (SCETT - NDAY)*24.D00
	  CALL MGORELOCATE(TDSTIME,VMIN)
	  CALL MGODRAW(TDSTIME,VMAX)
C	  CALL TDSDATA(TDSCH,NDATA,SPS,AVRF,UPVSD)
	  IF(TDS_CHANNEL.EQ.1) THEN
	    AVRF1 = AVRF
	    UPVSD1 = UPVSD
	  ELSE
	    AVRF2 = AVRF
	    UPVSD2 = UPVSD
	  ENDIF
C
	  IF(TDS_CHANNEL.EQ.1) WRITE(64,1064) NEVT,SCETI4,'T',TDS_CHANNEL,VMAX
     1		,AVRF1,UPVSD1,UPVSD2
 1064	  FORMAT(I10,I10,I8,A2,I3,F5.0,F7.3,2F6.2)
	ENDIF
C
	IF(SCETT.GE.SCETTDS1.AND.SCETT.LE.SCETTDS2) THEN
	   TDS_COUNT = TDS_COUNT+1
	   TDSF_COUNT = TDSF_COUNT + 1
	   TDSC = TDS_COUNT
	  DO N = 1,2048
	    TDSM = AMAX1(TDSM,1000.*ABS(VDATA(N))/EFL)  ! in mV/m
	    PWR = PWR + (VDATA(N)/EFL)**2
	  ENDDO
	ENDIF
C
	GO TO 200
C
 250	EVENT = 'FILL'
	scett = 0.d00
	call w_channel_position(TDSCH,scett)
	call w_channel_position(TDSCH,scet1)
	print*,'FILL channel set to',TDSCH,scet1
 240	CONTINUE
 	OK = W_EVENT(TDSCH,EVENT)
	print*,'fill event, event, ok=  ',event,ok
	IF(OK.EQ.82) GO TO 300
	IF(OK.NE.1) GO TO 240
C	ITEM = 'DATA'
C	ok = W_ITEM_I4(TDSCH, item, NDATA, ISIZE, ret_size)
	ITEM = 'CHANNEL'
	ok = W_ITEM_I4(TDSCH, item, TDS_CHANNEL, 1, ret_size)
	EFL = EFFLEN(TDS_CHANNEL)
	IF(TDS_CHANNEL.GT.2) GO TO 240
	IPRC = 4
	CALL TDS_PHYS(TDSCH,IPRC,NDATA,VDATA,SPECT)
	ITEM = 'EVENT_SCET'
	ok = W_ITEM_I4(TDSCH, item, SCETI4, 2, ret_size)
C	print*,'item,val,ok ',item,sceti4,ok
	ITEM = 'EVENT_SCET_R8'
	ok = W_ITEM_R8(TDSCH, item, SCETT, 1, ret_size)
C	FILL CHANNELS ARE IN CHRONOLOGICAL ORDER
	IF(SCETT.GT.SCET2+1.D-02) GO TO 300
c	print*,'item,val,ok ',item,scett,ok
	ITEM = 'EVENT_NUMBER'
	ok = W_ITEM_I4(TDSCH, item, NEVT, 1, ret_size)
	ITEM = 'FAST_RX_SPEED_R4'
	IF(TDS_CHANNEL.GT.2) ITEM = 'SLOW_RX_SPEED_R4'
	ok = W_ITEM_R4(TDSCH, item, SPS, 1, ret_size)
	ITEM = 'FAST_SAMPLER_THRESHOLD'
	IF(TDS_CHANNEL.GT.2) ITEM = 'SLOW_SAMPLER_THRESHOLD'
	ok = W_ITEM_R4(TDSCH, item, VMIN, 1, ret_size)
	NVMAX = MAX0(NDATA(1023),NDATA(1024),NDATA(1025))
	NVMIN = MIN0(NDATA(1023),NDATA(1024),NDATA(1025))
	VMAX = MAX0(NVMAX-128,128-NVMIN)
C	ITEM = 'EVENT_CENTER_SCET_R8'
C	print*,'FILL EVENT AT',TDSCH,scett,nevt,VMAX
	IF(SCETT.GE.SCET1.AND.SCETT.LE.SCET2) THEN
	  TDSTIME = (SCETT - NDAY)*24.D00
	  CALL MGORELOCATE(TDSTIME,VMIN)
	  CALL MGODRAW(TDSTIME,VMAX)
	  CALL TDSDATA(TDSCH,NDATA,SPS,AVRF,UPVSD)
	  IF(TDS_CHANNEL.EQ.1.OR.TDS_CHANNEL.EQ.5) THEN
	    AVRF1 = AVRF
	    UPVSD1 = UPVSD
	  ELSE
	    AVRF2 = AVRF
	    UPVSD2 = UPVSD
	  ENDIF
C
C	  print*,'draw check, scettds1,T,2',scettds1,scett,scettds2
	  IF(SCETT.GE.SCETTDS1.AND.SCETT.LE.SCETTDS2) THEN
	    TDS_COUNT = TDS_COUNT+1
	    FILL_COUNT = FILL_COUNT+1
	    TDSC = TDS_COUNT
	    DO N = 1,2048
	      TDSM = AMAX1(TDSM,1000.*ABS(VDATA(N))/EFL)  ! in mV/m
	      PWR = PWR + (VDATA(N)/EFL)**2
	    ENDDO
C	    print*,'chk',nevt,fill_count,tdsm,pwr
	  ENDIF
C
	  IF(TDS_CHANNEL.EQ.1) WRITE(64,1064) NEVT,SCETI4,'F',TDS_CHANNEL,VMAX
     1		,AVRF,UPVSD1,UPVSD2
	  IF(TDS_CHANNEL.EQ.3) WRITE(64,1064) NEVT,SCETI4,'F',TDS_CHANNEL,VMAX
     1		,AVRF,UPVSD1,UPVSD2
	ENDIF
C
c	  DO N = 1,2048
c	    TDSM = AMAX1(TDSM,1000.*VDATA(N)/EFL)  ! in mV/m
c	    PWR = PWR + (VDATA(N)/EFL)**2
c	  ENDDO
C
	IF(TDS_CHANNEL.GT.2) GO TO 240
C	  IF(SCETT.GE.SCETTDS1.AND.SCETT.LE.SCETTDS2) TDS_COUNT = TDS_COUNT+1
	GO TO 240			! GET ANOTHER FILL EVENT
C
 300	CONTINUE
C
C	ok = w_channel_close(TDSCH)
	CLOSE(UNIT=64)
C
 301	CALL MGOPLOTID('PROCMK17','SPLOT')
C
	RRE = SQRT(XRE(1)**2+YRE(1)**2+ZRE(1)**2)
	WRITE(STR,1002) XRE(1),YRE(1),ZRE(1),RRE
 1002	FORMAT('X,Y,Z,R=',4F6.1)
	CALL MGORELOCATE(XSTRT,1.2*YMAX)
	CALL MGOPUTLABEL(36,STR,9)
C
	RRE = SQRT(XRE(NP3)**2+YRE(NP3)**2+ZRE(NP3)**2)
	STR = 'NO 3DP DATA'
	IF(NP3.NE.0) WRITE(STR,1002) XRE(NP3),YRE(NP3),ZRE(NP3),RRE
	CALL MGORELOCATE(XEND,1.2*YMAX)
	CALL MGOPUTLABEL(36,STR,7)
	IF(ITERM.LT.0) THEN
	  CALL MGOPRNTPLOT(NVEC)
	  PRINT*,' NO. VECTORS PLOTTED',NVEC
	ELSE
c	  CALL MGOTCLOSE
	ENDIF
C
	TDSC = TDS_COUNT
	IF(TDS_COUNT.NE.0) PWR =  2.*PWR/TDS_COUNT   ! 2 CHANNELS, EVENTS
C		APPEAR TWICE
	print*,' tds,fill counts ',tdsf_count,fill_count
	RETURN
	END
	SUBROUTINE TDSDATA(CH,NDATA,SPS,AVRF,UPVSD)
C
C	CALCULATES AVERAGE FREQUENCY AND PERHAPS OTHER THINGS.
C
	INTEGER*4 CH,NDATA(1)
	REAL ZCROSS(1030),DATA(2050),SPECT(1025)
	REAL SPS,AVRF,UPVSDR

C
C	FIND ZERO CROSSINGS, USING ONLY THE CENTER SECTION FROM 512 TO 1536
C
	IZCNT = 0
	IL = 511
	IZ = IL
	IPROCESS = 4
	CALL TDS_PHYS(CH,IPROCESS,NDATA,DATA,SPECT)
C	  IF(NDATA(IL).EQ.0) PRINT*,'ZERO DATA',IL,NDATA(IL),NDATA(IL+1)
	IPROCESS = 0
	DO IL = 512,1536
	  IZ = IL
C	  IF(NDATA(IL).EQ.128) PRINT*,'ZERO DATA',IL,NDATA(IL-1),
C     1   NDATA(IL),NDATA(IL+1)
C
C		COUNT ONLY POS TO NEG
	  IF(NDATA(IL).GT.128.AND.NDATA(IL+1).LE.128) 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
	        DELZ = .5
		IF((S1-S2).NE.0.) DELZ = S1/(S1 - S2)
		IF(DELZ.LE.1.AND.DELZ.GE.0.) THEN
			ZCROSS(IZCNT) = IL + DELZ
		ELSE
			ZCROSS(IZCNT) = IL + .5
		ENDIF
	  ENDIF
	ENDDO
C	print*,'ndata',ndata(1023),ndata(1024),ndata(1025),ndata(1026)
C	print*,'data',data(1023),data(1024),data(1025),data(1026)
C	print*,'found zero crossings',izcnt
C
C	CALCULATE UP VS DOWN
C
	VUP = 0.
	VDWN = 0.
	DO N = 2,2047
	  VUP = AMAX1(VUP,DATA(N))
	  VDWN = AMIN1(VDWN,DATA(N))
	ENDDO
	UPVSD = 0.
	IF(VDWN.NE.0.) UPVSD = ABS(VUP)/ABS(VDWN)
	IF(UPVSD.LT.1..AND.UPVSD.GT.0.) UPVSD = 1./UPVSD
C
	SPSKHZ = .001*SPS
C	PRINT*,'IZCNT,SPS',IZCNT,SPS
	AVRPER = 1024.
	IF(IZCNT.GT.1) THEN
	  AVRPER = (ZCROSS(IZCNT)-ZCROSS(1))/(IZCNT-1)
C	  RMS = SQRT(STD/(IZCNT-1) - AVRPER**2)
C	  IF(IZCNT.NE.0) RMS = SPSKHZ*(1./AVRPER - 1./(AVRPER+RMS))
	ENDIF
	AVRF = 1./AVRPER
C
	RETURN
	END


      SUBROUTINE INITIALIZE()

*******************************************************************
*   This subroutine serves to
*     a) set default values for the SM parameters
*     b) set default values for the parameters (as limits on
*      sparticle masses) used for actual experimental constraints
*     c) read the tables that are used for actual experimental
*      constraints from the directory EXPCON
*******************************************************************

      IMPLICIT NONE

      CHARACTER*256 FILENAME,EXPCON_PATH,catpath

      INTEGER NBIN,I,J
      INTEGER NhZind,NhZbb,NhZll,NhZinv,NhZjj,NhZgg
      INTEGER NhA4b,NhA4tau,NhA2b2tau,NhA2tau2b
      INTEGER NAAA6b,NAAA6tau,NAAZ4b,NAAZ4tau,NAAZ2b2tau
      INTEGER Ncccc02,Ncccc04,Ncccc05,Ncccc06,Ncccc08,Ncccc1
      INTEGER Nccgg02,Nccgg04,Nccgg05,Nccgg06,Nccgg08,Nccgg1
      INTEGER Ncctt02,Ncctt04,Ncctt05,Ncctt06,Ncctt08,Ncctt1
      INTEGER Ngggg02,Ngggg04,Ngggg05,Ngggg06,Ngggg08,Ngggg1
      INTEGER Nttgg02,Nttgg04,Nttgg05,Nttgg06,Nttgg08,Nttgg1
      INTEGER Ntttt02,Ntttt04,Ntttt05,Ntttt06,Ntttt08,Ntttt1
      INTEGER Nstblsn,Nstnc,Nsbnb,Nglsq
      INTEGER NHAATAUS1,NHAATAUS2,NHAABMU
      INTEGER NHAAMUS1,NHAAMUS2,NHAAMUS3
      INTEGER NHAAMUS4

      DOUBLE PRECISION ALSMZ,ALEMMZ,GF,g1,g2,S2TW
      DOUBLE PRECISION MS,MC,MB,MBP,MT,MTAU,MMUON,MZ,MW
      DOUBLE PRECISION VUS,VCB,VUB,ALEM0,MPI,MEL,MSTRANGE
      DOUBLE PRECISION GZMAX,GZINVMAX,MCHAMIN,MCMIN,SIGNEU1,SIGNEU
      DOUBLE PRECISION MSLMIN,MSTMIN,MSQMIN,MGLMIN
      DOUBLE PRECISION hZind(1000,2),hZbb(1000,2),hZll(1000,2)
      DOUBLE PRECISION hZinv(1000,2),hZjj(1000,2),hZgg(1000,2)
      DOUBLE PRECISION hA4b(10000,3),hA4tau(10000,3)
      DOUBLE PRECISION hA2b2tau(10000,3),hA2tau2b(10000,3)
      DOUBLE PRECISION AAA6b(10000,3),AAA6tau(10000,3)
      DOUBLE PRECISION AAZ4b(10000,3),AAZ4tau(10000,3)
      DOUBLE PRECISION AAZ2b2tau(10000,3)
      DOUBLE PRECISION cccc02(100,2),cccc04(100,2),cccc05(100,2)
      DOUBLE PRECISION cccc06(100,2),cccc08(100,2),cccc1(100,2)
      DOUBLE PRECISION ccgg02(100,2),ccgg04(100,2),ccgg05(100,2)
      DOUBLE PRECISION ccgg06(100,2),ccgg08(100,2),ccgg1(100,2)
      DOUBLE PRECISION cctt02(100,2),cctt04(100,2),cctt05(100,2)
      DOUBLE PRECISION cctt06(100,2),cctt08(100,2),cctt1(100,2)
      DOUBLE PRECISION gggg02(100,2),gggg04(100,2),gggg05(100,2)
      DOUBLE PRECISION gggg06(100,2),gggg08(100,2),gggg1(100,2)
      DOUBLE PRECISION ttgg02(100,2),ttgg04(100,2),ttgg05(100,2)
      DOUBLE PRECISION ttgg06(100,2),ttgg08(100,2),ttgg1(100,2)
      DOUBLE PRECISION tttt02(100,2),tttt04(100,2),tttt05(100,2)
      DOUBLE PRECISION tttt06(100,2),tttt08(100,2),tttt1(100,2)
      DOUBLE PRECISION stblsn(100,2),stnc(100,2),sbnb(100,2)
      DOUBLE PRECISION glsq(100,2)
      DOUBLE PRECISION HAATAUS1(100,2),HAATAUS2(100,2),HAABMU(100,2)
      DOUBLE PRECISION HAAMUS1(100,2),HAAMUS2(100,2),HAAMUS3(100,2)
      DOUBLE PRECISION HAAMUS4(100,4)
      DOUBLE PRECISION Xf,sigmaV,vcsll,vcsbb,x(100),dNdx(100),EMIN
      DOUBLE PRECISION sigmaPiN,sigmaS,csPsi,csNsi,csPsd,csNsd
      DOUBLE PRECISION OMG,OMGMIN,OMGMAX,muH2

      COMMON/HIGGSMS/muH2
      COMMON/ALEM0/ALEM0
      COMMON/GAUGE/ALSMZ,ALEMMZ,GF,g1,g2,S2TW
      COMMON/SMSPEC/MS,MC,MB,MBP,MT,MTAU,MMUON,MZ,MW
      COMMON/SMEXT/MPI,MEL,MSTRANGE
      COMMON/CKM/VUS,VCB,VUB
      COMMON/LEP/GZMAX,GZINVMAX,MCHAMIN,MCMIN,SIGNEU1,SIGNEU,
     .      MSLMIN,MSTMIN,MSQMIN,MGLMIN,
     .      hZind,hZbb,hZll,hZinv,hZjj,hZgg,
     .      hA4b,hA4tau,hA2b2tau,hA2tau2b,
     .      AAA6b,AAA6tau,AAZ4b,AAZ4tau,AAZ2b2tau,
     .      cccc02,cccc04,cccc05,cccc06,cccc08,cccc1,
     .      ccgg02,ccgg04,ccgg05,ccgg06,ccgg08,ccgg1,
     .      cctt02,cctt04,cctt05,cctt06,cctt08,cctt1,
     .      gggg02,gggg04,gggg05,gggg06,gggg08,gggg1,
     .      ttgg02,ttgg04,ttgg05,ttgg06,ttgg08,ttgg1,
     .      tttt02,tttt04,tttt05,tttt06,tttt08,tttt1,
     .      stblsn,stnc,sbnb,glsq,
     .      NhZind,NhZbb,NhZll,NhZinv,NhZjj,NhZgg,
     .      NhA4b,NhA4tau,NhA2b2tau,NhA2tau2b,
     .      NAAA6b,NAAA6tau,NAAZ4b,NAAZ4tau,NAAZ2b2tau,
     .      Ncccc02,Ncccc04,Ncccc05,Ncccc06,Ncccc08,Ncccc1,
     .      Nccgg02,Nccgg04,Nccgg05,Nccgg06,Nccgg08,Nccgg1,
     .      Ncctt02,Ncctt04,Ncctt05,Ncctt06,Ncctt08,Ncctt1,
     .      Ngggg02,Ngggg04,Ngggg05,Ngggg06,Ngggg08,Ngggg1,
     .      Nttgg02,Nttgg04,Nttgg05,Nttgg06,Nttgg08,Nttgg1,
     .      Ntttt02,Ntttt04,Ntttt05,Ntttt06,Ntttt08,Ntttt1,
     .      Nstblsn,Nstnc,Nsbnb,Nglsq
      COMMON/LHCHAA/HAATAUS1,HAATAUS2,HAABMU,
     .      HAAMUS1,HAAMUS2,HAAMUS3,HAAMUS4,
     .      NHAATAUS1,NHAATAUS2,NHAABMU,
     .      NHAAMUS1,NHAAMUS2,NHAAMUS3,NHAAMUS4
      COMMON/MICROMG/OMG,OMGMIN,OMGMAX,Xf,sigmaV,vcsll,vcsbb,
     .      x,dNdx,EMIN,NBIN
      COMMON/MICROMG2/sigmaPiN,sigmaS,csPsi,csNsi,csPsd,csNsd

* SM inputs:

*   Higgs mass squared
      muH2=(125.1d0)**2
*   Alpha_EM(0)
      ALEM0= 1d0/137.036d0
*   Alpha_s at MZ:
      ALSMZ= 0.1172d0
*   Electroweak parameters:
      GF= 1.16639d-5
*   Alpha_em at MZ (used in RGES):
      ALEMMZ= 1d0/127.92d0
*   Z, W pole masses:
      MZ= 91.1876d0
      MW= 80.42d0
*   Lepton masses:
      MTAU= 1.777d0
      MMUON= 105.6583715d-3
*   Quark pole masses:
      MS= 0.19d0
      MC= 1.4d0
      MBP= 4.54d0
      MT= 175d0
*   Running MS_bar bottom mass MB at the scale MB:
      MB= 4.214d0
*   Elements of the Kobayashi-Maskawa matrix:
      VUS= 0.22d0
      VCB= 0.04d0
      VUB= 0.004d0
*   Pion/electron masses
      MPI=135d-3
      MEL=510.998928d-6
*   Strange quark running mass:
      MSTRANGE=95D-3

c*   Values recommended by the LHCXSWG
c
c*   Alpha_EM(0)
c      ALEM0= 1d0/137.036d0
c*   Alpha_s at MZ:
c      ALSMZ= 0.118d0
c*   Electroweak parameters:
c      GF= 1.1663787d-5
c*   Alpha_em at MZ (used in RGES):
c      ALEMMZ= 1d0/127.92d0
c*   Z, W pole masses:
c      MZ= 91.1876d0
c      MW= 80.385d0
c*   Lepton masses:
c      MTAU= 1.77682d0
c      MMUON= 0.1056583715d0
c*   Quark pole masses:
c      MS= 0.19d0
c      MC= 1.51d0
c      MBP= 4.92d0
c      MT= 172.5d0
c*   Running MS_bar bottom mass MB at the scale MB:
c      MB= 4.18d0
c*   Elements of the Kobayashi-Maskawa matrix:
c      VUS= 0.22d0
c      VCB= 0.04d0
c      VUB= 0.004d0
c*   Pion/electron masses
c      MPI=135d-3
c      MEL=.510998928d-3

* Dark matter constraints
* (Used only if OMGFLAG=/=0)

c      OMGMIN=0.1187d0-0.0017d0
c      OMGMAX=0.1187d0+0.0017d0
      OMGMIN=0.1187d0*0.9d0   ! Planck
      OMGMAX=0.1187d0*1.1d0   ! +/-10%
      sigmaPiN=34d0
      sigmaS=42d0
      NBIN=10
      EMIN=1d-3
      DO I=1,100
       x(I)=0d0
       dNdx(I)=0d0
      ENDDO
      DO I=1,NBIN
        x(I)=(NBIN-I)*DLOG10(Emin)/(NBIN-1d0)
      ENDDO

*   Collider constraints on sparticles:

*   Limit on the Z width for Z -> h(i) + a(j):
      GZMAX=5.78d-3
*   Limit on the inv. Z width from Z -> neutralinos:
      GZINVMAX=0.5d-3
*   Limit on sigma(e+e- -> neutralinos (1,1)):
      SIGNEU1=1d-2
*   Limit on sigma(e+e- -> neutralinos (i,j)) (i*j > 1):
      SIGNEU=1d-1
*   Lower limit on chargino masses:
      MCHAMIN=103.5d0
*   Lower limit on slepton masses:
      MSLMIN=99.9d0
*   Lower limit on stau masses:
      MSTMIN=93.2d0
*   Lower limit on squark masses:
      MSQMIN=100d0
*   Lower limit on gluino mass:
      MGLMIN=180d0
*   Lower limit on charged Higgs mass:
      MCMIN=78.6d0

*   LEP constraints

      CALL getenv('EXPCON_PATH',EXPCON_PATH)
      if(EXPCON_PATH.eq.' ')  EXPCON_PATH='../EXPCON'

      FILENAME=catpath(EXPCON_PATH,'hZind.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 111  READ(11,*,END=112,ERR=2)(hZind(I,J),J=1,2)
      I=I+1
      GOTO 111
 112  NhZind=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'hZbb.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 211  READ(11,*,END=212,ERR=2)(hZbb(I,J),J=1,2)
      I=I+1
      GOTO 211
 212  NhZbb=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'hZll.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 311  READ(11,*,END=312,ERR=2)(hZll(I,J),J=1,2)
      I=I+1
      GOTO 311
 312  NhZll=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'hZinv.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 411  READ(11,*,END=412,ERR=2)(hZinv(I,J),J=1,2)
      I=I+1
      GOTO 411
 412  NhZinv=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'hZjj.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 511  READ(11,*,END=512,ERR=2)(hZjj(I,J),J=1,2)
      I=I+1
      GOTO 511
 512  NhZjj=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'hZgg.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 611  READ(11,*,END=612,ERR=2)(hZgg(I,J),J=1,2)
      I=I+1
      GOTO 611
 612  NhZgg=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'hA4b.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 711  READ(11,*,END=712,ERR=2)(hA4b(I,J),J=1,3)
      I=I+1
      GOTO 711
 712  NhA4b=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'hA4tau.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 811  READ(11,*,END=812,ERR=2)(hA4tau(I,J),J=1,3)
      I=I+1
      GOTO 811
 812  NhA4tau=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'hA2b2tau.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 821  READ(11,*,END=822,ERR=2)(hA2b2tau(I,J),J=1,3)
      I=I+1
      GOTO 821
 822  NhA2b2tau=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'hA2tau2b.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 831  READ(11,*,END=832,ERR=2)(hA2tau2b(I,J),J=1,3)
      I=I+1
      GOTO 831
 832  NhA2tau2b=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'AAA6b.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 911  READ(11,*,END=912,ERR=2)(AAA6b(I,J),J=1,3)
      I=I+1
      GOTO 911
 912  NAAA6b=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'AAA6tau.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 921  READ(11,*,END=922,ERR=2)(AAA6tau(I,J),J=1,3)
      I=I+1
      GOTO 921
 922  NAAA6tau=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'AAZ4b.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1101 READ(11,*,END=1102,ERR=2)(AAZ4b(I,J),J=1,3)
      I=I+1
      GOTO 1101
 1102 NAAZ4b=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'AAZ4tau.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1111 READ(11,*,END=1112,ERR=2)(AAZ4tau(I,J),J=1,3)
      I=I+1
      GOTO 1111
 1112 NAAZ4tau=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'AAZ2b2tau.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1121 READ(11,*,END=1122,ERR=2)(AAZ2b2tau(I,J),J=1,3)
      I=I+1
      GOTO 1121
 1122 NAAZ2b2tau=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'cccc02.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1201 READ(11,*,END=1202)cccc02(I,1)
      READ(11,*,END=1202,ERR=2)cccc02(I,2)
      I=I+1
      GOTO 1201
 1202 Ncccc02=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'cccc04.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1211 READ(11,*,END=1212)cccc04(I,1)
      READ(11,*,END=1212,ERR=2)cccc04(I,2)
      I=I+1
      GOTO 1211
 1212 Ncccc04=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'cccc05.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1221 READ(11,*,END=1222)cccc05(I,1)
      READ(11,*,END=1222,ERR=2)cccc05(I,2)
      I=I+1
      GOTO 1221
 1222 Ncccc05=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'cccc06.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1231 READ(11,*,END=1232)cccc06(I,1)
      READ(11,*,END=1232,ERR=2)cccc06(I,2)
      I=I+1
      GOTO 1231
 1232 Ncccc06=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'cccc08.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1241 READ(11,*,END=1242)cccc08(I,1)
      READ(11,*,END=1242,ERR=2)cccc08(I,2)
      I=I+1
      GOTO 1241
 1242 Ncccc08=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'cccc1.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1251 READ(11,*,END=1252)cccc1(I,1)
      READ(11,*,END=1252,ERR=2)cccc1(I,2)
      I=I+1
      GOTO 1251
 1252 Ncccc1=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'ccgg02.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1301 READ(11,*,END=1302)ccgg02(I,1)
      READ(11,*,END=1302,ERR=2)ccgg02(I,2)
      I=I+1
      GOTO 1301
 1302 Nccgg02=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'ccgg04.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1311 READ(11,*,END=1312)ccgg04(I,1)
      READ(11,*,END=1312,ERR=2)ccgg04(I,2)
      I=I+1
      GOTO 1311
 1312 Nccgg04=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'ccgg05.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1321 READ(11,*,END=1322)ccgg05(I,1)
      READ(11,*,END=1322,ERR=2)ccgg05(I,2)
      I=I+1
      GOTO 1321
 1322 Nccgg05=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'ccgg06.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1331 READ(11,*,END=1332)ccgg06(I,1)
      READ(11,*,END=1332,ERR=2)ccgg06(I,2)
      I=I+1
      GOTO 1331
 1332 Nccgg06=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'ccgg08.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1341 READ(11,*,END=1342)ccgg08(I,1)
      READ(11,*,END=1342,ERR=2)ccgg08(I,2)
      I=I+1
      GOTO 1341
 1342 Nccgg08=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'ccgg1.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1351 READ(11,*,END=1352)ccgg1(I,1)
      READ(11,*,END=1352,ERR=2)ccgg1(I,2)
      I=I+1
      GOTO 1351
 1352 Nccgg1=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'cctt02.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1401 READ(11,*,END=1402)cctt02(I,1)
      READ(11,*,END=1402,ERR=2)cctt02(I,2)
      I=I+1
      GOTO 1401
 1402 Ncctt02=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'cctt04.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1411 READ(11,*,END=1412)cctt04(I,1)
      READ(11,*,END=1412,ERR=2)cctt04(I,2)
      I=I+1
      GOTO 1411
 1412 Ncctt04=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'cctt05.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1421 READ(11,*,END=1422)cctt05(I,1)
      READ(11,*,END=1422,ERR=2)cctt05(I,2)
      I=I+1
      GOTO 1421
 1422 Ncctt05=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'cctt06.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1431 READ(11,*,END=1432)cctt06(I,1)
      READ(11,*,END=1432,ERR=2)cctt06(I,2)
      I=I+1
      GOTO 1431
 1432 Ncctt06=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'cctt08.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1441 READ(11,*,END=1442)cctt08(I,1)
      READ(11,*,END=1442,ERR=2)cctt08(I,2)
      I=I+1
      GOTO 1441
 1442 Ncctt08=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'cctt1.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1451 READ(11,*,END=1452)cctt1(I,1)
      READ(11,*,END=1452,ERR=2)cctt1(I,2)
      I=I+1
      GOTO 1451
 1452 Ncctt1=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'gggg02.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1501 READ(11,*,END=1502)gggg02(I,1)
      READ(11,*,END=1502,ERR=2)gggg02(I,2)
      I=I+1
      GOTO 1501
 1502 Ngggg02=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'gggg04.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1511 READ(11,*,END=1512)gggg04(I,1)
      READ(11,*,END=1512,ERR=2)gggg04(I,2)
      I=I+1
      GOTO 1511
 1512 Ngggg04=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'gggg05.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1521 READ(11,*,END=1522)gggg05(I,1)
      READ(11,*,END=1522,ERR=2)gggg05(I,2)
      I=I+1
      GOTO 1521
 1522 Ngggg05=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'gggg06.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1531 READ(11,*,END=1532)gggg06(I,1)
      READ(11,*,END=1532,ERR=2)gggg06(I,2)
      I=I+1
      GOTO 1531
 1532 Ngggg06=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'gggg08.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1541 READ(11,*,END=1542)gggg08(I,1)
      READ(11,*,END=1542,ERR=2)gggg08(I,2)
      I=I+1
      GOTO 1541
 1542 Ngggg08=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'gggg1.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1551 READ(11,*,END=1552)gggg1(I,1)
      READ(11,*,END=1552,ERR=2)gggg1(I,2)
      I=I+1
      GOTO 1551
 1552 Ngggg1=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'ttgg02.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1601 READ(11,*,END=1602)ttgg02(I,1)
      READ(11,*,END=1602,ERR=2)ttgg02(I,2)
      I=I+1
      GOTO 1601
 1602 Nttgg02=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'ttgg04.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1611 READ(11,*,END=1612)ttgg04(I,1)
      READ(11,*,END=1612,ERR=2)ttgg04(I,2)
      I=I+1
      GOTO 1611
 1612 Nttgg04=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'ttgg05.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1621 READ(11,*,END=1622)ttgg05(I,1)
      READ(11,*,END=1622,ERR=2)ttgg05(I,2)
      I=I+1
      GOTO 1621
 1622 Nttgg05=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'ttgg06.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1631 READ(11,*,END=1632)ttgg06(I,1)
      READ(11,*,END=1632,ERR=2)ttgg06(I,2)
      I=I+1
      GOTO 1631
 1632 Nttgg06=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'ttgg08.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1641 READ(11,*,END=1642)ttgg08(I,1)
      READ(11,*,END=1642,ERR=2)ttgg08(I,2)
      I=I+1
      GOTO 1641
 1642 Nttgg08=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'ttgg1.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1651 READ(11,*,END=1652)ttgg1(I,1)
      READ(11,*,END=1652,ERR=2)ttgg1(I,2)
      I=I+1
      GOTO 1651
 1652 Nttgg1=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'tttt02.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1701 READ(11,*,END=1702)tttt02(I,1)
      READ(11,*,END=1702,ERR=2)tttt02(I,2)
      I=I+1
      GOTO 1701
 1702 Ntttt02=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'tttt04.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1711 READ(11,*,END=1712)tttt04(I,1)
      READ(11,*,END=1712,ERR=2)tttt04(I,2)
      I=I+1
      GOTO 1711
 1712 Ntttt04=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'tttt05.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1721 READ(11,*,END=1722)tttt05(I,1)
      READ(11,*,END=1722,ERR=2)tttt05(I,2)
      I=I+1
      GOTO 1721
 1722 Ntttt05=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'tttt06.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1731 READ(11,*,END=1732)tttt06(I,1)
      READ(11,*,END=1732,ERR=2)tttt06(I,2)
      I=I+1
      GOTO 1731
 1732 Ntttt06=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'tttt08.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1741 READ(11,*,END=1742)tttt08(I,1)
      READ(11,*,END=1742,ERR=2)tttt08(I,2)
      I=I+1
      GOTO 1741
 1742 Ntttt08=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'tttt1.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1751 READ(11,*,END=1752)tttt1(I,1)
      READ(11,*,END=1752,ERR=2)tttt1(I,2)
      I=I+1
      GOTO 1751
 1752 Ntttt1=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'stblsn.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1761 READ(11,*,END=1762,ERR=2)(stblsn(I,J),J=1,2)
      I=I+1
      GOTO 1761
 1762 Nstblsn=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'stnc.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1771 READ(11,*,END=1772,ERR=2)(stnc(I,J),J=1,2)
      I=I+1
      GOTO 1771
 1772 Nstnc=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'sbnb.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1781 READ(11,*,END=1782,ERR=2)(sbnb(I,J),J=1,2)
      I=I+1
      GOTO 1781
 1782 Nsbnb=I-1
      CLOSE(11)

      FILENAME=catpath(EXPCON_PATH,'glsq.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1791 READ(11,*,END=1792,ERR=2)(glsq(I,J),J=1,2)
      I=I+1
      GOTO 1791
 1792 Nglsq=I-1
      CLOSE(11)

* Read ATLAS upper limit
* HAATAUS1(I,1): CP-odd Higgs mass
* HAATAUS1(I,2): upper limit on sigma[H_125]/sigma_SM*BR[H->2A]*BR[A->2tau]**2
      FILENAME=catpath(EXPCON_PATH,'1505_01609.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1901 READ(11,*,END=1902,ERR=2)(HAATAUS1(I,J),J=1,2)
      I=I+1
      GOTO 1901
 1902 NHAATAUS1=I-1
      CLOSE(11)

* Read CMS upper limit
* HAATAUS2(I,1): CP-odd Higgs mass
* HAATAUS2(I,2): upper limit on sigma[H_125]*BR[H->2A]*BR[A->2tau]**2
      FILENAME=catpath(EXPCON_PATH,'1510_06534.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1903 READ(11,*,END=1904,ERR=2)(HAATAUS2(I,J),J=1,2)
      I=I+1
      GOTO 1903
 1904 NHAATAUS2=I-1
      CLOSE(11)

* Read CMS upper limit
* HAABMU(I,1): CP-odd Higgs mass
* HAABMU(I,2): upper limit on sigma[H_125]/sigma_SM*BR[H->2A]*BR[A->2mu]*BR[A->2b]
      FILENAME=catpath(EXPCON_PATH,'cms_pas_hig_14_041.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1905 READ(11,*,END=1906,ERR=2)(HAABMU(I,J),J=1,2)
      I=I+1
      GOTO 1905
 1906 NHAABMU=I-1
      CLOSE(11)

* Read CMS upper limit
* HAAMUS1(I,1): CP-odd Higgs mass
* HAAMUS1(I,2): upper limit on sigma[H_125]/sigma_SM*BR[H->2A]*BR[A->2mu]**2
      FILENAME=catpath(EXPCON_PATH,'cms_pas_hig_15_011.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1907 READ(11,*,END=1908,ERR=2)(HAAMUS1(I,J),J=1,2)
      I=I+1
      GOTO 1907
 1908 NHAAMUS1=I-1
      CLOSE(11)

* Read CMS upper limit
* HAAMUS2(I,1): CP-odd Higgs mass
* HAAMUS2(I,2): upper limit on sigma[H_125]/sigma_SM*BR[H->2A]*BR[A->2mu]**2
      FILENAME=catpath(EXPCON_PATH,'cms_pas_hig_14_022.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1909 READ(11,*,END=1910,ERR=2)(HAAMUS2(I,J),J=1,2)
      I=I+1
      GOTO 1909
 1910 NHAAMUS2=I-1
      CLOSE(11)

* Read CMS upper limit
* HAAMUS3(I,1): CP-odd Higgs mass
* HAAMUS3(I,2): upper limit on sigma[H_125]/sigma_SM*BR[H->2A]*BR[A->2mu]**2
      FILENAME=catpath(EXPCON_PATH,'cms_pas_hig_14_019.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1911 READ(11,*,END=1912,ERR=2)(HAAMUS3(I,J),J=1,2)
      I=I+1
      GOTO 1911
 1912 NHAAMUS3=I-1
      CLOSE(11)

* Read CMS upper limit
* HAAMUS4(I,1): CP-even Higgs mass
* HAAMUS4(I,2): upper limit on sigma[H]*BR[H->2A]*BR[A->2mu]**2, M_A = 0.25Ge
* HAAMUS4(I,3): upper limit on sigma[H]*BR[H->2A]*BR[A->2mu]**2, M_A = 2GeV
* HAAMUS4(I,4): upper limit on sigma[H]*BR[H->2A]*BR[A->2mu]**2, M_A = 3.55GeV
      FILENAME=catpath(EXPCON_PATH,'1506_00424.dat')
      OPEN(11,FILE=FILENAME,STATUS='UNKNOWN',ERR=1)
      I=1
 1913 READ(11,*,END=1914,ERR=2)(HAAMUS4(I,J),J=1,4)
      I=I+1
      GOTO 1913
 1914 NHAAMUS4=I-1
      CLOSE(11)

      RETURN

*   Error catch

 1    WRITE(*,*)"Cannot find the file ",FILENAME
      STOP

 2    WRITE(*,*)"Read error in the file ",FILENAME
      STOP

      END

      integer function strlen(st)

*     Logical length of a string (omitting blanks)
*
*     | F | O | R | T | R | A | N |  |  |  |  |  |  |  |
*     <------------ full length returned by len() ----->
*     <---- logical length ------> <- trailing blank -->
*
      implicit none
      character      st*(*)
      strlen = len(st)
      do while (st(strlen:strlen) .eq. ' ')
       strlen = strlen - 1
      enddo
      return
      end

      character*(*) function catpath(st1,st2)

*     st1 is a string containing the path.
*     st2 is the file name or an other directory name
*     return value is the string "st1/st2"

      implicit none
      character*(*) st1
      character*(*) st2
      integer strlen
      catpath = st1(1:strlen(st1)) // '/' // st2
      return
      end


c     Josh - added argument iPl to control many pole self energy.
      subroutine xsph (ipr2, ispec, vixan, xkstep, xkmax, gamach, rgrd,
     1             nph, lmaxph, potlbl, spinph, iatph, nat, rat, iphat,
     2             ixc, vr0, vi0, ixc0, lreal, rfms2, lfms2, l2lp,
     3             ipol, ispin, le2, angks, ptz, iPl,
     4             izstd, ifxc, ipmbse, itdlda, nonlocal)
c squelch compiler warning about unused dummy variables, apparently
c removed from f85e
c    iGrid, (after iPl)
c  , ibasis)

c     Cluster code -- multiple shell single scattering version of FEFF
c     This program (or subroutine) calculates potentials and phase
c     shifts for unique potentials specifed by atoms and overlap cards.
c
c     Input files:  potph.inp    input data, atoms, overlaps, etc.
c     Output:       phases.bin   phase shifts for use by the rest of the
c                                program
c                   xxx.dat      various diagnostics

      implicit double precision (a-h, o-z)

      include '../HEADERS/const.h'
      include '../HEADERS/dim.h'

      double precision col1(nex), col2(nex), col3(nex)
      double precision col4(nex), col5(nex)

c     Notes:
c        nat    number of atoms in problem
c        nph    number of unique potentials
c        ihole  hole code of absorbing atom
c        iph=0 for central atom

c     Specific atom input data
c     iphat(natx)  -  given specific atom, which unique pot?
      dimension iphat(natx)
c     rat(3,natx)  -  cartesian coords of specific atom
      dimension rat(3,natx)

c     Unique potential input data
c     iatph(0:nphx)  - given unique pot, which atom is model?
c                      (0 if none specified for this unique pot)
      dimension iatph(0:nphx)
c     xnatph(0:nphx) - given unique pot, how many atoms are there
c                      of this type? (used for interstitial calc)
      dimension xnatph(0:nphx), spinph(0:nphx)
c     potlbl(0:nphx)    -   label for user convienence
      character*6 potlbl(0:nphx)

c     folp(0:nphx) -  overlap factor for rmt calculation
      dimension folp(0:nphx)
c     novr(0:nphx) -  number of overlap shells for unique pot
      dimension novr(0:nphx)
c     iphovr(novrx,0:nphx) -  unique pot for this overlap shell
      dimension iphovr(novrx,0:nphx)
c     nnovr(novrx,0:nphx) -   number of atoms in overlap shell
      dimension nnovr(novrx,0:nphx)
c     rovr(novrx,0:nphx)  -   r for overlap shell
      dimension rovr(novrx,0:nphx)

c     Free atom data
c     xion(0:nphx)  - ionicity, input
      dimension xion(0:nphx)
c     iz(0:nphx)    - atomic number, input
      dimension iz(0:nphx)

c     Overlap calculation results
c     edens(251,0:nphx)   -   overlapped density*4*pi
      dimension edens(251,0:nphx)
c     vtot (251,0:nphx)   -   overlapped total potential
      dimension vtot (251,0:nphx), vclap (251,0:nphx)

c     Muffin tin calculation results
c     imt(0:nphx)  -  r mesh index just inside rmt
      dimension imt(0:nphx), inrm(0:nphx), folpx(0:nphx)
c     rmt(0:nphx)  -  muffin tin radius
      dimension rmt(0:nphx)
c     rnrm(0:nphx)  -  Norman radius
      dimension rnrm(0:nphx), qnrm(0:nphx)
      dimension xnmues(0:lx,0:nphx)
      real rfms2
      integer ipol, ispin, lfms2
      complex*16 ptz
      dimension ptz(-1:1, -1:1)
      dimension lmaxph(0:nphx)

c     PHASE output
c     eref(nex, nspx)         -     interstitial energy ref
      complex*16 eref(nex, nspx)
c     ph(nex,-ltot:ltot,nspx,0:nphx) - phase shifts
      complex*16 ph( nex, -ltot:ltot, nspx, 0:nphx)
c     lmax(0:nphx)      -     number of ang mom levels
      dimension lmax(0:nphx)

      character*80 title(nheadx)

      complex*16  em(nex)
      complex*16  rkk(nex,8,nspx), xsec(nex,nspx)
      dimension xsnorm(nex, nspx)
      dimension dgc0(251), dpc0(251)

c     additioal data needed for relativistic version
      dimension dgc(251,30,0:nphx), dpc(251,30,0:nphx)
      dimension adgc(10,30,0:nphx), adpc(10,30,0:nphx)
      dimension dgcn(nrptx,30), dpcn(nrptx,30)
      dimension edenvl(251,0:nphx), eorb(30), kappa(30)
      dimension vvalgs (251,0:nphx), xnval(30,0:nphx), iorb(-4:3,0:nphx)

c     nrx = max number of r points for phase and xsect r grid
      parameter (nrx = nrptx)
      dimension ri(nrptx), vtotph(nrx), rhoph(nrx)
      dimension  dmagx(nrptx), dmag(251,0:nphx)
      dimension dgcx(nrptx), dpcx(nrptx), vvalph(nrx), rhphvl(nrx)
      dimension vch (251), vchp(nrx)

      logical lopt
      character*512 slog

c     Josh - Added iPl for PLASMON card, and iexist for mpse.dat
      integer iPl
c      integer iexist

   10 format (4x, a, i5)

c     Phase shift calculation
c     Atom r grid
      dx = 0.05d0
      x0 = 8.8d0
c     Phase r grid
      dxnew = rgrd

      call rdpot ( ntitle, title, rnrmav, xmu, vint, rhoint,
     1                  emu, s02, erelax, wp, ecv,rs,xf, qtotel,
     2                  imt, rmt, inrm, rnrm, folp, folpx, xnatph,
     3                  dgc0, dpc0, dgc, dpc, adgc, adpc,
     3                  edens, vclap, vtot, edenvl, vvalgs, dmag, xnval,
     4                  eorb, kappa, iorb, qnrm, xnmues, nohole, ihole,
     5                  inters, totvol, iafolp, xion, iunf, iz, jumprm)
c      lopt=true for the Rivas code of optical constants
       lopt = .false.
       if (lopt) call getedg(ihole,iz(0), emu)
       if (lopt) ik0 = 1
       if (lopt) then
         call wlog('   Fixing edge energy from Elam table...')
         write(slog,fmt="('   emu = ',f10.3,' eV')") emu*hart
         call wlog(slog)
       endif

       do 15 iph = 0, nph
 15    novr(iph) = 0

c  update header, since e.g. one may use diff ixc for the same potential
        call sthead (ntitle, title, nph, iz, rmt, rnrm,
     1          xion, ihole, ixc,
     2          vr0, vi0, gamach, xmu, xf, vint, rs,
     2          lreal, rgrd)
c     Make energy mesh
      edge = xmu - vr0
      if (.not.lopt) emu = emu - vr0

cc    manual input. Later make TDLDA and PMBSE cards
cc    TDLDA ifxc  (izstd=1 if TDLDA card is present)
c     izstd = 0
c     ifxc = 0
cc    PMBSE  ipmbse  nonlocal ifxc itdlda
c     ipmbse = 2
c     ibasis = 2
cc    ipmbse=0 (do not run); 1-LF only; 2-PM only; 3-combined;
cc           4-combined with s-function kernel splitting
c     nonlocal = 0
cc    nonlocal = 0 (local fxc); 1-read W from pot.ch; 2-from yoshi.dat
c     itdlda = 2
cc    itdlda = 0, 1, 2 should be run in sequence
cc    end of manual input

c     check that logic is set up correctly
      if (ipmbse.le.0) itdlda = 0
      if (nohole.lt.0) then
c       core-hole potential is used already
        if (ifxc.ne.0) then
          call wlog(' Reset ifxc=0 since NOHOLE card is absent')
          ifxc = 0
          if (ipmbse.gt.0) nonlocal = 0
        endif
        if (ipmbse.eq.3 .and. izstd.eq.0) then
          call wlog(' Reset ipmbse=1 since NOHOLE card is absent')
          ipmbse = 1
        endif
      endif
      if (izstd.gt.0 .and. itdlda.gt.0) then
c       no need run PMBSE in this case
        call wlog(' Ignored PMBSE cards since TDLDA is present')
        itdlda = 0
      endif
      if (ipmbse.eq.2 .and. nonlocal.gt.0 .and. ifxc.gt.0) then
c       accounting for core-hole twice. reset ifxc=0
        call wlog(' Reset ifxc=0 since core-hole potential is used.')
        ifxc = 0
      endif
      if (ipmbse.eq.1 .and. nonlocal.gt.0) then
c       V_ch should be zero
        nonlocal = 0
      endif

c     Josh - if nohole = 2, read wscrn.dat and add ch pot to vtot.
c     Need to add file check and emesh check.
      if (nohole.eq.2)  then
         open (unit=13, file='wscrn.dat', status='old', iostat=ios)
         call chopen (ios, 'wscrn.dat', 'ffmod2(xsph)')
         open (unit=14, file='vtot.dat', status='replace',iostat=ios)
         call chopen (ios, 'vtot.dat', 'ffmod2(xsph)')
         do i = 1, 251
            read(13,'(2e20.10)',end=20) dum1, dum2
            dum3 = vtot(i,0)
            vtot(i,0) = vtot(i,0) - dum2
            write(14,'(3e20.10)') dum1, dum3, dum2
         end do
 20      continue
         nohole = 0
         close(13)
         close(14)
      end if
c     Josh END

      if (itdlda.eq.0)  then
!     Josh - Replaced call to phmesh with phmesh2, which allows user
!     defined grids read from grid.inp. Details can be found in phmesh2.f
!         call phmesh2 (ipr2, ispec, edge, emu, vi0, gamach, xkmax,
!     &        xkstep, vixan, ne, ne1, em, ik0, ne3,iGrid)
        call phmesh (ipr2, ispec, edge, emu, vi0, gamach,
     1                 xkmax, xkstep, vixan, ne, ne1, em, ik0, ne3)
      else
c       nesvi TDLDA
c        call meshlda (xkstep, ne, ne1, em, ik0)
        corr = 1.0
      endif

      if (itdlda.eq.1) then
c       to get the mesh only
        do 93  i = 1, ne1
          write(3,94) dble(em(i))*hart
 94       format (7f10.5)
 93     continue
        stop 'TDLDA energy mesh is written out'
c       end of itdlda=1 calculations
      endif

c     Make old grid to report distances in xsect.bin
      do 95 i = 1, 251
 95   ri(i) = exp(-x0+dx*(i-1))

c     open xsect.bin and write the header
c--json--      open (unit=1, file='xsect.bin', status='unknown', iostat=ios)
c--json--      call chopen (ios, 'xsect.bin', 'potph')
c--json--      call wthead (1, ntitle, title)
c skip old output in title ( title lines are above ------ )
c     write(1,*) 'vtot in eV, rho in code units, includes 4pi'
c     write(1,*) 'ipot, vtot(imt), rho(imt) '
c     write(1,122) 'interstitial', vint*hart, rhoint
c     do 386  iph = 0, nph
c        write(1,123)iph,vtot(imt(iph),iph)*hart,edens(imt(iph),iph)
c 386 continue
c 122 format (1x, a, 1p, 2e20.6)
c 123 format (i10, 1p, 2e20.6)
c     write(1,42)  emu*hart
c  42 format ('       edge ', 2f20.5)
c     write(1,*)  imt(0), ' imt(0)'
c     write(1,200)  vint*hart, rhoint, ri(imt(0)+1)
c 200 format ('  v, rho, r', /, 1p, 3e20.4, ' intersitial')
c     do 220  iii = imt(0), imt(0)-4, -1
c        write(1,210)  vtot(iii,0)* hart, edens(iii,0), ri(iii), iii
c 210 format (1p, 3e20.4, i6)
c 220 continue

c--json--      write(1,45)
c--json--   45 format (1x, 71('-'))
c--json--      write(1,55) s02, erelax, wp, edge, emu
c--json--   55 format ( 3e13.5, 2e15.7, ' method to calculate xsect')
c--json--      write(1,56) gamach*hart, ne1, ik0
c--json--   56 format (1p, e15.7, 2i4,
c--json--     1       ' gamach in eV, # of points on horizintal axis')
c--json--      write(1,57)
c--json--   57 format ('        em              xsnorm            xsec  ')
c--json--c     end of the xsect.bin header

c     nsp = 1 - spin average caclulations; 2 - spin up and down
      nsp = 1
      if (abs(ispin).eq.1) nsp = nspx
c     scale spin density on each atom appropriately
      do iph = 0, nph
       do i = 1, 251
         dmag(i,iph) = dmag(i, iph) * spinph(iph)
       enddo
      enddo

      do 300 isp = 1, nsp
        if (ispin.ne.0) then
c         make spin dependent potential if needed
c         isp = 1-spin-down; 2-spin-up potentials
          idmag = (-1)**isp
          if (nsp.eq.1) then
             idmag = 1
             if(ispin.lt.0) idmag=-1
          endif
          call  istprm (nph, nat, iphat, rat, iatph, xnatph,
     1               novr, iphovr, nnovr, rovr, folp, folpx, iafolp,
     1               edens, edenvl, idmag,
     2               dmag, vclap, vtot, vvalgs, imt, inrm, rmt, rnrm,
     3               ixc, rhoint,vint, rs, xf, xmu, xmunew,
     5               rnrmav, qtotel, inters, totvol)
          xmunew = xmu
          if (abs(ispin).eq.1 .and. nsp.eq.2) then
c           |ispinp| = |ispin|, but sign is determined by isp
             ispinp = abs(ispin)
             if (isp.eq.1) ispinp = -ispinp
          else
c            sign is determined by spin (always for ispin=-2,2)
             ispinp = ispin
          endif
        else
c         spin-independent case
          ispinp = 0
        endif

c       calculate operators of interest (s_z, l_z, t_z)
        xmuvr = xmu - vr0
        if (ipr2.ge.3) call szlz(ispinp,ecv,nph,nat,rgrd,nohole,rfms2,
     2     lfms2, lmaxph, edens, edenvl, dmag, vtot, vvalgs, rmt, rnrm,
     2     ixc, rhoint, vint, xmuvr, jumprm,
     3     xnval, iorb, x0, dx, xion, iunf, iz,
     5     adgc, adpc, dgc, dpc, ihole, rat, iphat, corr)
c    1                   em, ne1, ne, ik0 )

c       Cross section calculation, use phase mesh for now
c       Absorbing atom is iph=0
        write(slog,10) 'absorption cross section'
        call wlog(slog)
        iph = 0
        call fixvar (rmt(0), edens(1,0), vtot(1,0), dmag(1,0),
     1             vint, rhoint, dx, dxnew, jumprm,
     2             vjump, ri, vtotph, rhoph, dmagx)
        call fixdsx (iph, dx, dxnew, dgc, dpc, dgcn, dpcn)
        if (mod(ixc,10) .ge. 5) then
           if (jumprm .gt. 0) jumprm = 2
           call fixvar (rmt(0), edenvl(1,0), vvalgs(1,0), dmag(1,0),
     1             vint, rhoint, dx, dxnew, jumprm,
     2             vjump, ri, vvalph, rhphvl, dmagx)
           if (jumprm .gt. 0) jumprm = 1
        endif
        call fixdsp (dx, dxnew, dgc0, dpc0, dgcx, dpcx, jnew)

        if (itdlda.eq.0) then
c         Josh - added argument iPl to control many pole self energy
c         BR - removed eorb, gamach, ifxc, vi0
          call xsect (ipr2, dxnew, x0, ri, ne, ne1, ik0, em, edge,
     1       ihole, emu, corr, dgcx, dpcx, jnew,
     2       ixc0, lreal, rmt(0), rnrm(0), xmuvr, iPl,
     3       vtotph, vvalph, rhoph, dmagx, rhphvl,
     4       dgcn, dpcn, adgc(1,1,iph), adpc(1,1,iph), xsec(1,isp),
     5       xsnorm(1,isp), rkk(1,1,isp), iz(0), xion(0), iunf,
     6       xnval(1,iph), izstd, iorb(-4,iph), l2lp,
     7       ipol, ispinp, le2, angks,ptz)
        else
          if (nonlocal.gt.0) then
c           read potential with core-hole from a file
            if (nonlocal.eq.1) then
c              call rdpotp(vch)
            elseif (nonlocal.eq.2) then
c             open (unit=3, file='MgO_Mgk.dat', status='old')
              open (unit=3, file='wscrn.dat', status='old')
c             open (unit=3, file='w_m5p.dat', status='old')
c             open (unit=3, file='ni_l2.dat', status='old')
c             open (unit=3, file='ni_l2_sp.dat', status='old')
              n=0
 338          n = n+1
                read(3,337, end=339) dum1, dum2
c               use frac.ne.1  to mix bare and screened ch pot
c                frac = 0.80
c                frac = 1.00
                vch(n) = -1.d0*dum2
 337            format(6e20.10)
                goto 338
 339          continue
              close (unit=3)
            endif
            call fixvar (rmt(0), edens(1,0), vch, dmag(1,0),
     1             vint, rhoint, dx, dxnew, jumprm,
     2             vjump, ri, vchp, rhoph, dmagx)
            do 333 i = 1, nrptx
               if (ri(i).lt.rmt(0)) then
                 if (nonlocal.eq.1) then
                   vchp(i) = vchp(i) - vtotph(i)
                 endif
               elseif (ri(i).lt.40.d0) then
c                 assume const/r behaviour
                  vchp(i) = vchp(i-1) * ri(i-1) / ri(i)
               else
                  vchp(i) = 0
               endif
c           testing: write core-hole potential in fort.17
               if (ri(i).lt.40.d0) write(17,332) ri(i), vchp(i)
 332            format(2f30.5)
 333        continue

            close (unit=17)
c           itest = 2
c           if (itest.eq.2) stop
          else
            do 334 i =1, nrptx
 334        vchp(i) = 0
          endif

c         Josh - added argument iPl to control many pole self energy
c          call xsectd (ipr2,dxnew, x0, ri, ne, ne1, ik0, em, edge,
c     1       ihole, emu, corr, dgcx, dpcx, jnew,
c     2       ixc0, lreal, rmt(0), rnrm(0), xmuvr, vi0, iPl,
c     3       gamach, vtotph, vvalph,vchp, rhoph, dmagx, rhphvl,
c     4       dgcn, dpcn, adgc(1,1,iph), adpc(1,1,iph), xsec(1,isp),
c     5       xsnorm(1,isp), rkk(1,1,isp),iz(0), xion(0), iunf,
c     6       xnval(1,iph), ipmbse, ifxc, ibasis, eorb, kappa,
c     7       iorb(-4,iph), l2lp, ipol, ispinp, le2, angks,ptz, itdlda)
        endif

        do 60  iph = 0, nph
          write(slog,10) 'phase shifts for unique potential', iph
          call wlog(slog)
c         fix up variable for phase
          call fixvar (rmt(iph), edens(1,iph), vtot(1,iph), dmag(1,iph),
     1                vint, rhoint, dx, dxnew, jumprm,
     2                vjump, ri, vtotph, rhoph, dmagx)
          if (mod(ixc,10) .ge.5) then
            if (jumprm .gt. 0) jumprm = 2
            call fixvar (rmt(iph), edenvl(1,iph), vvalgs(1,iph),
     1                dmag(1,iph), vint, rhoint, dx, dxnew, jumprm,
     2                vjump, ri, vvalph, rhphvl, dmagx)
            if (jumprm .gt. 0) jumprm = 1
            call fixdsx (iph, dx, dxnew, dgc, dpc, dgcn, dpcn)
          endif
          if (iph .eq. 0)  then
            itmp = ihole
          else
            itmp = 0
          endif

          call phase (iph, dxnew, x0, ri, ne, ne1, ne3, em, ixc, nsp,
     1            lreal, rmt(iph),rnrm(iph), xmuvr, iPl,
     2            vtotph, vvalph, rhoph, dmagx, rhphvl,
     3            dgcn, dpcn, adgc(1,1,iph), adpc(1,1,iph), eref(1,isp),
     4            ph(1,-ltot,isp,iph), lmax(iph), iz(iph), itmp,
     5            xion(iph), iunf, xnval(1,iph), ispinp)
c          call phase (iph, dxnew, x0, ri, ne, ne1, ne3, em, ixc, nsp,
c     1            lreal, rmt(iph),rnrm(iph), xmuvr, vi0, iPl,
c     2            gamach, vtotph, vvalph, rhoph, dmagx, rhphvl,
c     3            dgcn, dpcn, adgc(1,1,iph), adpc(1,1,iph), eref(1,isp),
c     4            ph(1,-ltot,isp,iph), lmax(iph), iz(iph), itmp,
c     5            xion(iph), iunf, xnval(1,iph), ispinp)
 60     continue

 300  continue

c     write main output to xsect.bin
c--json--  340 format (e17.9, 4e13.5)
      if (abs(ispin).ne.1 .or. nspx.eq.1) then
        do 350  ie = 1, ne
c--json--           write(1,340) dble(em(ie))*hart, dimag(em(ie))*hart,
c--json--     1                 xsnorm(ie,1), dble(xsec(ie,1)), dimag(xsec(ie,1))
           col1(ie) = dble(em(ie))*hart
           col2(ie) = dimag(em(ie))*hart
           col3(ie) = xsnorm(ie,1)
           col4(ie) = dble(xsec(ie,1))
           col5(ie) = dimag(xsec(ie,1))
  350   continue
      else
c       nspx = 2
        do 380  ie = 1, ne
c--json--           write(1,340) dble(em(ie))*hart, dimag(em(ie))*hart,
c--json--     1             (xsnorm(ie,1) + xsnorm(ie,nspx)) / 2.d0 ,
c--json--     2           dble( (xsec(ie,1) + xsec(ie,nspx)) ),
c--json--     3          dimag( (xsec(ie,1) + xsec(ie,nspx)) )
           col1(ie) = dble(em(ie))*hart
           col2(ie) = dimag(em(ie))*hart
           col3(ie) = (xsnorm(ie,1) + xsnorm(ie,nspx)) / 2.d0
           col4(ie) = dble( (xsec(ie,1) + xsec(ie,nspx)) )
           col5(ie) = dimag( (xsec(ie,1) + xsec(ie,nspx)) )
c          Normalize rkk to the average over up/down spin
c          nsp=2
           xnorm1 = sqrt( 2*xsnorm(ie,1) /
     1                         (xsnorm(ie,1) + xsnorm(ie,nspx)) )
           xnorm2 = sqrt( 2*xsnorm(ie,nspx) /
     1                         (xsnorm(ie,1) + xsnorm(ie,nspx)) )
           do 360 kdif = 1,8
             rkk (ie, kdif, 1) = rkk (ie, kdif, 1) * xnorm1
             rkk (ie, kdif, nspx) = rkk (ie, kdif, nspx) * xnorm2
  360      continue
  380   continue
      endif
c--json--      close (unit=1)

      call json_xsect(ntitle, title, s02, erelax, wp, edge, emu,
     1                gamach*hart, ne, ne1, ik0,
     2                col1, col2, col3, col4, col5)

c     disable for now since dimensions are different
      if (ipr2 .ge. 2)  then
         call wphase (nph, em, eref, lmax, ne, ph, ntitle, title)
      endif

c     Write out phases for paths and genfmt
      call wrxsph (nsp, ne, ne1, ne3, nph, ihole, rnrmav, xmuvr,
     &     edge, ik0, ixc, rs, vint,
     &     em, eref, lmax, iz, potlbl, ph, rkk)

      if (ipr2 .ge. 1) then
c       calculate axafs
c       axafs does not make sense for |ispin| = 1
        call axafs (em, emu, xsec(1,1), ne1, ik0)
      endif

      return
      end