*-- Author : John V. Morris
SUBROUTINE FSUMR
PARAMETER( TWOPI=6.283185)
PARAMETER( NBINR=40 ) ! number of radius bins
LOGICAL PLANAR,RADIAL
COMMON /FTQRUN/ NRUN,NRUN0,NRUN1,MAXEV,PLANAR,RADIAL
PARAMETER( MXC=40 ) ! maximum stored results
COMMON/FVOUTR/VEL(MXC),EVEL(MXC),RMIC(MXC),EMIC(MXC),IDVF(MXC),
& SEGS(MXC),ESEG(MXC),ASYM(MXC),EASYM(MXC),
& SEGN(MXC),ESEGN(MXC),SEGF(MXC),ESEGF(MXC)
COMMON/FCOUNT/ NDATE0,NTIME0,ISTATP(20),ISTATR(20),IFRHV,IFPHV,
& NEVENT,NFIEL0,NPRES0,NECUR0,NPCUR0,IRTE0,IRTP0,
& IEVIN,NFPEVT,NHITSP,NFREVT,NHITSR,NMIN92,
& TOTL,H1L,RTIME,REFF,ILRET
COMMON/FHITLS/ LHITSP(0:8), LHITSR(0:8)
COMMON/FHLUN/ LUNH, LUNS, LMES, IL4L5
COMMON /QUEST/ IQUEST(100)
DIMENSION IOUT(6), FOUT(17)
DIMENSION PERCY(4)
DIMENSION RELEF(12),ERLEF(12),QWR(12)
DIMENSION ABIEFF(13),ABINEF(13),ABIFEF(13)
DIMENSION AVEC(19),BVEC(24),HVEC(9),CVEC(9),VVEC(18),TVEC(18)
DIMENSION EVEC(39)
DIMENSION HSIG(3)
DIMENSION AR(2),ASIG(2)
DATA ICH/ 2/
CHARACTER*20 UNITS
DIMENSION UNITS(6)
DIMENSION XEFF(9)
DIMENSION C6703(NBINR),E6703(NBINR)
DATA UNITS/' microns/nsec',' microns',' ',' per-cent',
+ ' nsec ',' from DT width'/
BETA = TAN(TWOPI/96.)
CALL VZERO(PERCY,4)
IF(IEVIN.GT.0)THEN
DO 1099 J=1,4
1099 PERCY(J) = FLOAT(ISTATR(J))*100.0/FLOAT(IEVIN)
ENDIF
NPOL = 0
NBINST = 3*NBINR/8 + 1
NBINEN = 6*NBINR/8
DO 69011 J = 1 , NBINR
N = NINT( HMAX(89+J) )
IF( N.GT.250 )THEN
CALL FPEAKF(89+J,area,xmax,thresh)
CALL HFITGA(89+J,G1,G2,G3,GXHI,ICH,HSIG)
S6701 = GXHI
IF( S6701.GT.1. ) THEN
S6701 = SQRT(S6701)
ELSE
S6701 = 1.0
ENDIF
CALL HMINIM(89+J,-100.)
BACK = G2
C6703(J) = BACK
EBACK = HSIG(2)*S6701
IF(J.GE.NBINST.and.J.LE.NBINEN) THEN
NPOL = NPOL + 1
E6703(J) = EBACK
ELSE
E6703(J) = 0.0
ENDIF
ELSE
C6703(J) = 0.0
E6703(J) = 0.0
ENDIF
69011 CONTINUE
CALL HPAK(88,C6703)
CALL HPAKE(88,E6703)
IF(NPOL.GT.10) THEN
CALL HFITPO(88,2,AR,GXHI,ICH,ASIG)
SLD = AR(2)
ESLD = ASIG(2)
VELD = BETA/AR(2)*10000.
EVELD = VELD*ASIG(2)/AR(2)
IF(RMIC(1).GT.0.0) THEN
EPCNT = SQRT( (EVELD/VELD)**2 + (EMIC(1)/RMIC(1))**2 )
RMIC(1)= RMIC(1)*VELD
EMIC(1)= RMIC(1)*EPCNT
ENDIF
ELSE
VELD = 0.
EVELD = 0.
ENDIF
IF( HMAX(89).GT.250. )THEN
CALL FPEAKF(89,area,xmax,thresh)
CALL HFITGA(89,G1,G2,G3,GXHI,ICH,HSIG)
CALL HMINIM(89,-100.)
S6702 = GXHI
IF( S6702.GT.1. )THEN
S6702 = SQRT(S6702)
ELSE
S6702 = 1.0
ENDIF
RTZERO = G2
ETZERO = HSIG(2)*S6702
ELSE
RTZERO = 0.
ETZERO = 0.
ENDIF
NNMAX = 0
DO 1080 JW=1,12
IDH = 55 + JW
NN = NINT( HSUM(IDH) )
QWR(JW) = HSTATI(IDH,1,'HIST',1)
IF( NN.GT.NNMAX ) NNMAX=NN
RELEF(JW) = FLOAT(NN)
ERLEF(JW) = SQRT( RELEF(JW) )
1080 CONTINUE
EFCEN = 0.0
ERCEN = 0.0
IF( NNMAX.GT.0 ) THEN
EFCEN = ( RELEF(1)+RELEF(2)+RELEF(3)+RELEF(10)+RELEF(11)
& +RELEF(12) )*100.0 /(RELEF(4)+RELEF(5)+RELEF(6)
& +RELEF(7)+RELEF(8)+RELEF(9) )
ERCEN = SQRT( RELEF(1)+RELEF(2)+RELEF(3)+RELEF(10)+RELEF(11)
& +RELEF(12) )
ERCEN = 100.0*ERCEN/( RELEF(4)+RELEF(5)+RELEF(6)
& +RELEF(7)+RELEF(8)+RELEF(9) )
DO 1081 JW=1,12
RELEF(JW) = 100.0*RELEF(JW)/FLOAT(NNMAX)
ERLEF(JW) = 100.0*ERLEF(JW)/FLOAT(NNMAX)
1081 CONTINUE
ENDIF
DO 10 IVD = 1 , 13
IF((SEGS(13+IVD) + SEGS(26+IVD)).EQ.0.0) THEN
ABIEFF(IVD) = 0.0
ELSE
ABIEFF(IVD) = SEGS(13+IVD) / (SEGS(13+IVD) + SEGS(26+IVD))
ENDIF
IF((SEGN(13+IVD) + SEGN(26+IVD)).EQ.0.0) THEN
ABINEF(IVD) = 0.0
ELSE
ABINEF(IVD) = SEGN(13+IVD) / (SEGN(13+IVD) + SEGN(26+IVD))
ENDIF
IF((SEGF(13+IVD) + SEGF(26+IVD)).EQ.0.0) THEN
ABIFEF(IVD) = 0.0
ELSE
ABIFEF(IVD) = SEGF(13+IVD) / (SEGF(13+IVD) + SEGF(26+IVD))
ENDIF
EVEC(IVD) = ABIEFF(IVD)
EVEC(13+IVD)= ABINEF(IVD)
EVEC(26+IVD)= ABIFEF(IVD)
10 CONTINUE
TFR = SEGS(1)/FLOAT( ISTATR(1) )
ETF = ESEG(1)/FLOAT( ISTATR(1) )
TDG = SEGS(1)*400.0/FLOAT( ISTATR(11) )
EDG = ESEG(1)*400.0/FLOAT( ISTATR(11) )
HPE = FLOAT(ISTATR(11))/FLOAT(ISTATR(1))
IOUT(1) = NRUN0
IOUT(2) = NDATE0
IOUT(3) = NTIME0
IOUT(4) = NPRES0
IOUT(5) = ISTATR(1)
FOUT(1) = HPE
FOUT(2) = TFR
FOUT(3) = ETF
FOUT(4) = TDG
FOUT(5) = EDG
FOUT(6) = VEL(1)
FOUT(7) = EVEL(1)
FOUT(8) = VELD
FOUT(9) = EVELD
FOUT(12)= RMIC(1)
FOUT(13)= EMIC(1)
FOUT(14)= RTZERO
FOUT(15)= ETZERO
FOUT(16)= EFCEN
FOUT(17)= ERCEN
AVQ = HSTATI(68,1,'HIST',1)
RMS = HSTATI(68,2,'HIST',2)
XN = HSUM(68)
IF(XN.GT.0.0) RMS = RMS/SQRT(XN)
FOUT(10)= AVQ
FOUT(11)= RMS
DO 3001 NSM=0,2
NL0 = NSM*3
HLE0 = FLOAT( LHITSR(NL0) )/FLOAT(ISTATR(1))
HLE1 = FLOAT( LHITSR(NL0+1) )/FLOAT(ISTATR(1))
HLE2 = FLOAT( LHITSR(NL0+2) )/FLOAT(ISTATR(1))
HVEC(NL0+1) = HLE0
HVEC(NL0+2) = HLE1
HVEC(NL0+3) = HLE2
3001 CONTINUE
DO 3201 NSM=0,2
NL0 = NSM*3
CLE0 = SEGS(NL0+5)/FLOAT(ISTATR(1))
CLE1 = SEGS(NL0+6)/FLOAT(ISTATR(1))
CLE2 = SEGS(NL0+7)/FLOAT(ISTATR(1))
CVEC(NL0+1) = CLE0
CVEC(NL0+2) = CLE1
CVEC(NL0+3) = CLE2
3201 CONTINUE
DO 3002 NSM=0,2
VVEC(NSM*2+1) = VEL(NSM+2)
VVEC(NSM*2+2) = EVEL(NSM+2)
3002 CONTINUE
DO 3022 NSO=0,8
TVEC(NSO+1) = VEL(NSO+5)
TVEC(NSO+10) = EVEL(NSO+5)
3022 CONTINUE
DO 3003 NSM=0,2
VVEC(NSM*2+7) = RMIC(NSM+2)
VVEC(NSM*2+8) = EMIC(NSM+2)
3003 CONTINUE
DO 3004 NSM=0,2
AVQ = HSTATI(69+NSM,1,'HIST',1)
RMS = HSTATI(69+NSM,2,'HIST',2)
XN = HSUM(69+NSM)
IF(XN.GT.0.0) RMS = RMS/SQRT(XN)
VVEC(NSM*2+13) = AVQ
VVEC(NSM*2+14) = RMS
3004 CONTINUE
IF(ILRET.EQ.0) THEN
IF(H1L.GT.0.0) THEN
IOUT(6) = 0 + IFRHV*10
ELSE
IOUT(6) = 1 + IFRHV*10
ENDIF
ELSE
IOUT(6) = 2 + IFRHV*10
ENDIF
AVEC(1) = FLOAT(IOUT(5))
DO 100 I = 1 , 17
AVEC(1+I) = FOUT(I)
IF(I.LT.13) BVEC(I*2-1) = RELEF(I)
IF(I.LT.13) BVEC(I*2 ) = QWR(I)
100 CONTINUE
AVEC(19) = FLOAT(IFRHV)
CALL SVEC(20,0,EVEC)
CALL SVEC(21,0,AVEC)
CALL SVEC(22,0,BVEC)
CALL SVEC(23,0,VVEC)
CALL SVEC(24,0,HVEC)
CALL SVEC(25,0,CVEC)
CALL SVEC(26,0,TVEC)
RETURN
END
*