c--------------------------------------------
c userfunction for AYEBALL. 
c--------------------------------------------

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
        logical function userin
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

c---
c  		User initialization routine
c		Called once at the beginning of aqcuisition and used
c		to initialize various things.
c---

	implicit none

	include 'aye_fix.inc'
	include 'aye_flt.inc'

c  		et 	- event type
c  		np	- number of parameters
c  		ev	- event vector
c
c..the event-structure is:
c       1) for the ppac event:
c          - event type bit register
c          - ppac-readout R,L,U,D
c          - deltaE (ppac)
c          - TDC TOF (ppac-ionchamber)
c          - TAC TOF (ppac-ionchamber)
c          - RF TOF (ppac-rf)
c          - Pile up signal (=1/2 for OK/PILEUP)         
c          - Ion chamber anodes
c          - Ion chamber position
c
c..the pseudoevent structure is:
c
c	       	  pev(#)                 contents
c               -----------             -----------------------------
c		    1-20                Ege
c		    21-40               Tge
c		    41-60               doppler corrected energies 
c		    61-80               bit hit pattern germanium
c		    81-100              adc hit pattern germanium
c		    101,102,103	        1st, 2nd, 3rd corrected energy
c	      	    104		        number of eurogam Ge
c	      	    105		        number of tessa Ge
c	      	    106		        number of all Ge
c
c                   120                 event type bit register
c                   121                 event length
c
c                   122                 monitor DE
c                   123                 monitor E
c
c                   131                 R
c                   132                 L
c                   133                 U
c                   134                 D
c                   135                 X
c                   136                 RL               
c                   137                 Y
c                   138                 UD
c                   139                 deltaE
c                   140                 TDC TOF (PPAC - ION)
c                   141                 TAC TOF (PPAC - ION)
c                   142                 RF TOF 
c                   143                 rec-gamma TAC
c                   144                 PPAC,IC pileup bits (1,2)
c                   145                 E * T**2
c                  151-153              Ion anodes  E1,E2,E3
c                   157                 Ion position raw
c                   160                 calculated position  
c                   161                 E1+E2     
c                   162                 E1+E2+E3                     
c

c				Created: July 1995
c					 DJB, ANL
c

c
c                   201-212             n dets time of flight
c                   221-232             n dets total energy
c                   241-252             n dets slow component
c
c                                        August 1995, DS

c
c       declaring variables ...
c

	integer*2	et,np
	integer*2	ev(*),nPEV
	parameter	(nPEV=300)
	integer*2	pev(nPEV)

	integer*2	i,j,k,m,n,index,locev,locpev
        integer*4       ii
	integer*2	nrge1,nrge2,nrge
	integer*2	evtype,evbits(16),patge1(16),patge2(16)
        integer*2       npat(16)
        integer*4       nfold,nfoldn
                                                                     
	real*8		delran
	integer*4	iseed

	real*4		gamma
	real*4		ang1_5,dps1_5
	parameter	(ang1_5=158.)
	real*4		ang6_10,dps6_10
	parameter	(ang6_10=134.)
	real*4		ang11_15,dps11_15
	parameter	(ang11_15=101.0)
	real*4		ang16_20,dps16_20
	parameter	(ang16_20=79.0)
	real*4		degrad
	parameter	(degrad=57.29578)
	real*4		dps(20)

	integer*2 NANODES
	real*4 R,L,U,D,X,Y,RL,UD
	integer*2 lowt,hight

        integer*2 data
        integer*4 ddata

        data lowt,hight /10,2040/
        data iseed /123457/
        DATA NANODES/3/            

        integer*4 spn, mass, z

        logical user, user1, userex, fixflt

        INTEGER*4  INZVECTOR(*),W2VECTOR(*),W1VECTOR(*),CONVECTOR(*)

        CHARACTER*10 CON_NAME, H_NAME
        LOGICAL H_OK, CON_OK 
        LOGICAL CONNUMBER
        LOGICAL H1NUMBER, H2NUMBER
        INTEGER*4 Z1_CON_N, Z2_CON_N, Z3_CON_N, Z4_CON_N, Z5_CON_N, Z6_CON_N
        INTEGER*4 M1_CON_N, M2_CON_N, M3_CON_N, M4_CON_N, M5_CON_N
        INTEGER*4 N_CON_N(12)
        INTEGER*4 NE_H_N, NSE_H_N, NRF_H_N
        INTEGER*4 NHIT_H_N, NHITN_H_N, NHITG_H_N
        INTEGER*4 NHITRF_H_N, NHITE_H_N, NHITSE_H_N
        INTEGER*4 GGPART_H_N, GPART_H_N

c        
c        getting access to conditions ...
c

        CON_NAME='Z1'
        CON_OK=CONNUMBER(CON_NAME,Z1_CON_N)
        CON_NAME='Z2'
        CON_OK=CONNUMBER(CON_NAME,Z2_CON_N)
        CON_NAME='Z3'
        CON_OK=CONNUMBER(CON_NAME,Z3_CON_N)
        CON_NAME='Z4'
        CON_OK=CONNUMBER(CON_NAME,Z4_CON_N)
        CON_NAME='Z5'
        CON_OK=CONNUMBER(CON_NAME,Z5_CON_N)
        CON_NAME='Z6'
        CON_OK=CONNUMBER(CON_NAME,Z6_CON_N)

        CON_NAME='M1'
        CON_OK=CONNUMBER(CON_NAME,M1_CON_N)
        CON_NAME='M2'
        CON_OK=CONNUMBER(CON_NAME,M2_CON_N)
        CON_NAME='M3'
        CON_OK=CONNUMBER(CON_NAME,M3_CON_N)
        CON_NAME='M4'
        CON_OK=CONNUMBER(CON_NAME,M4_CON_N)
        CON_NAME='M5'
        CON_OK=CONNUMBER(CON_NAME,M5_CON_N)

        CON_NAME='N1'
        CON_OK=CONNUMBER(CON_NAME,N_CON_N(1))
        CON_NAME='N2'
        CON_OK=CONNUMBER(CON_NAME,N_CON_N(2))
        CON_NAME='N3'
        CON_OK=CONNUMBER(CON_NAME,N_CON_N(3))
        CON_NAME='N4'
        CON_OK=CONNUMBER(CON_NAME,N_CON_N(4))
        CON_NAME='N5'
        CON_OK=CONNUMBER(CON_NAME,N_CON_N(5))
        CON_NAME='N6'
        CON_OK=CONNUMBER(CON_NAME,N_CON_N(6))
        CON_NAME='N7'
        CON_OK=CONNUMBER(CON_NAME,N_CON_N(7))
        CON_NAME='N8'
        CON_OK=CONNUMBER(CON_NAME,N_CON_N(8))
        CON_NAME='N9'
        CON_OK=CONNUMBER(CON_NAME,N_CON_N(9))
        CON_NAME='N10'
        CON_OK=CONNUMBER(CON_NAME,N_CON_N(10))
        CON_NAME='N11'
        CON_OK=CONNUMBER(CON_NAME,N_CON_N(11))
        CON_NAME='N12'
        CON_OK=CONNUMBER(CON_NAME,N_CON_N(12))

c        
c        getting access to histograms ...
c

        H_NAME='NE'
        H_OK=H2NUMBER(H_NAME,NE_H_N)
        H_NAME='NSE'
        H_OK=H2NUMBER(H_NAME,NSE_H_N)
        H_NAME='NRF'
        H_OK=H2NUMBER(H_NAME,NRF_H_N)

        H_NAME='NHIT'
        H_OK=H1NUMBER(H_NAME,NHIT_H_N)

        H_NAME='NHITRF'
        H_OK=H1NUMBER(H_NAME,NHITRF_H_N)
        H_NAME='NHITE'
        H_OK=H1NUMBER(H_NAME,NHITE_H_N)
        H_NAME='NHITSE'
        H_OK=H1NUMBER(H_NAME,NHITSE_H_N)

        H_NAME='NHITN'
        H_OK=H1NUMBER(H_NAME,NHITN_H_N)
        H_NAME='NHITG'
        H_OK=H1NUMBER(H_NAME,NHITG_H_N) 

        H_NAME='GGPART'
        H_OK=H2NUMBER(H_NAME,GGPART_H_N)

        H_NAME='GPART'
        H_OK=H2NUMBER(H_NAME,GPART_H_N)

	call defPEV (pev(1),pev(nPEV))
	call deffix(fixarr,fixzzz)
	call defflt(fltarr,fltzzz)
c---
c		Define the random number seeds.
c---
	iseed = 123457

        userin=.true.

        return

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	entry  user (et,np,ev,INZVECTOR,W2VECTOR,W1VECTOR,CONVECTOR)
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

c-------------------------------------------------------------
c  START PROCESSING THE EVENT HERE!!!!!!!! 
c------------------------------------------------------------- 
        call zeroI2(npev,pev)

	nrge1 = 0
	nrge2 = 0
        nrge  = 0      
        locev=1                       !pointer for raw event vector
        pev(121)=np                   !event length in words

c-------------------------------------------------------------
c  get the event type bit register 
c------------------------------------------------------------- 
        evtype=ev(locev)
        locev=locev+1
        call bit16(evtype,evbits)
        pev(120)=evtype

c-------------------------------------------------------------
c  Monitor Event  
c-------------------------------------------------------------
      if ( iand(evtype,1) .ne. 0) then

        pev(122)=ev(locev)      !demon
        pev(123)=ev(locev+1)    !emon
        locev=locev+2
        userin=.true.
        return                  !ignore anything else
      endif
  
c-------------------------------------------------------------
c  Do all the germanium and neutron stuff here if they fired
c-------------------------------------------------------------
      if ( iand(evtype,60) .ne. 0) then                       

c..Get the hit pattern for the germaniums.
	call bit16(ev(locev),patge1)
	call bit16(ev(locev+1),patge2)
        locev=locev+2

 	do i=1,20
	   j = i       !loc of raw ge e in pev
	   k = 20 + i  !loc of ge time in pev
	   l = 40 + i  !loc of corrected ge e in pev
	   m = 60 + i  !loc of bit hit patt for ge #i in pev    
	   n = 80 + i  !loc of adc hit patt for ge #i in pev

           index=0
           if (i.le.10) then
              if (patge1(i).eq.1) index=1                !EG are 1-10
           else                                         
              if (patge2(i-10).eq.1) index=2             !TESSA are 11-20
           endif                           
	   if (index.gt.0) then                          !check ge bits
              pev(j) = ev(locev)                         !raw ge energy
              pev(k) = iand(ev(locev+1),'0fff'x)         !ge time
              locev = locev + 2
              pev(m) = i                                 !bit hit pattern
              if (pev(j).gt.1 .and. pev(j).lt.8190) then !valid ge energy
                 pev(n)=i                                !adc hit pattern
	         nrge = nrge + 1                         !total ge mult
                 if (index.eq.1) then
   	            nrge1 = nrge1 + 1                    !EG mult
                 else
                    nrge2 = nrge2 + 1                    !TESSA mult
                 endif
	         delran = ran(iseed) - 0.5
                 pev(l) = nint(dps(i)*pev(j) + delran)
                 if (nrge.le.3) pev(100+nrge)=pev(l)     !1st 3 energies
              endif 
	   endif
        enddo    

	pev(104) = nrge1
	pev(105) = nrge2
        pev(106) = nrge	

c
c       taking care of the neutron detectors ...
c
        call bit16(ev(locev),npat)        
            
        locev=locev+1

        locpev=200

        nfold=0
 	do i=1,12
          if ((npat(i)).eq.1) then

c           neutron detector hit pattern       

            II=I
            call h1inc(NHIT_H_N,ii)

c           neutron detector RF       

            data=iand(ev(locev),'0FFF'X)
            pev(locpev+i)=data
            ddata=data
            call h2inc(NRF_H_N,ddata,ii)   

c           neutron detector RF hit pattern      
            if ((data.gt.0).and.(data.lt.4095)) call h1inc(NHITRF_H_N,ii)

c           neutron detector energy                     

            data=iand(ev(locev+1),'0FFF'X)
            pev(locpev+20+i)=data
            ddata=data
            call h2inc(NE_H_N,ddata,ii)   

c           neutron detector energy hit pattern      
            if ((data.gt.0).and.(data.lt.2047)) call h1inc(NHITE_H_N,ii)

c           neutron detector slow component energy                     

            data=iand(ev(locev+2),'0FFF'X)
            pev(locpev+40+i)=data
            ddata=data
            call h2inc(NSE_H_N,ddata,ii)   

c           neutron detector energy hit pattern      
            if ((data.gt.0).and.(data.lt.2047)) call h1inc(NHITSE_H_N,ii)

            locev=locev+3
            nfold=nfold+1
          endif
        enddo

        pev(260)=nfold

      endif
c-------------------------------------------------------------
c  Do all the PPAC and Ion Chamber stuff here if they fired
c-------------------------------------------------------------
      if ( iand(evtype,106) .ne. 0) then                       
c----------
c PPAC part
c----------
c..first generate the (X,Y) position & the LR and UD sums        
              R = FLOAT(iand(EV(locev),'0FFF'X))
              L = FLOAT(iand(EV(locev+1),'0FFF'X))
              U = FLOAT(iand(EV(locev+2),'0FFF'X))
              D = FLOAT(iand(EV(locev+3),'0FFF'X))
c..store R,L,U,D readouts (raw data)
              PEV(131)=R
              PEV(132)=L
              PEV(133)=U
              PEV(134)=D
              IF(R.GT.lowt .AND .R.LT. hight
     &                     .AND.
     &           L.GT.lowt .AND. L.LT. hight) THEN 
                 X  = ( (R-L) + XOFFSET ) * XSCALE   
                 RL = (R+L)/2
                 PEV(135)=NINT(X)
                 PEV(136)=NINT(RL)
              ENDIF        
              IF(U.GT.lowt .AND. U.LT. hight
     &                     .AND.
     &           D.GT.lowt .AND.D.LT. hight) THEN
                 Y = ( (D-U) + YOFFSET ) * YSCALE   
                 UD = (U+D)/2
                 PEV(137)=NINT(Y)
                 PEV(138)=NINT(UD)
             ENDIF

    	     locev = locev + 4
                
c..PPAC DELTA ENERGY
          pev(139)=ev(locev)
      	  locev = locev + 1
c..TOF tdc (ppac-dssd time of flight)   
             pev(140) = and (ev(locev),X'0FFF')
	     locev = locev + 1
c..TOF TAC (ppac-dssd time of flight for long times)   
             pev(141) = ev(locev)
	     locev = locev + 1
c..TOF (ppac-rf)
	     pev(142) = and (ev(locev),X'0FFF')
	     locev = locev + 1
c..TOF (rec-gamma TAC)
	     pev(143) = and (ev(locev),X'0FFF')
	     locev = locev + 1
c...pileup bit for PPAC and IC
           pev(144)=ev(locev)
           LOCEV=LOCEV+1   
c-------------------
c Ionization chamber
c-------------------
c..anodes
           do i=1,NANODES
              pev(150+i) = iand(ev(locev),'0FFF'X)
              LOCEV=LOCEV+1
           enddo
c..raw position
           pev(157) = iand(ev(locev),'0FFF'X) 
           LOCEV=LOCEV+1
C..CALCULATED STUFF (position, E1+E2, E1+E2+E3)
           if((pev(151).ge.10)
     &         .and.(pev(152).ge.10)
     &         .and.(pev(153).ge.10))then 
           	pev(160) = pev(157)                        
            	PEV(161) = nint( float( PEV(151)+PEV(152)          ) /2.0)
           	PEV(162) = nint( float( PEV(151)+PEV(152)+pev(153) ) /2.0)
           endif

c..E * T**2
c            if (pev(162).gt.1 .and. pev(140).gt.1) then
c               pev(145) = nint(float(pev(162)) 
c     1                 * float(pev(140))**2 / float(xet2gain))
c            endif    

      endif

      user=.true.

      return

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      entry user1(et,np,ev,INZVECTOR,W2VECTOR,W1VECTOR,CONVECTOR)
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

c     
c     getting atomic number ...
c

      z=0
      if (convector(2*z1_con_n-1).eq.1) then
        z=1
      elseif (convector(2*z2_con_n-1).eq.1) then
        z=2
      elseif (convector(2*z3_con_n-1).eq.1) then
        z=3         
      elseif (convector(2*z4_con_n-1).eq.1) then
        z=4
      elseif (convector(2*z5_con_n-1).eq.1) then
        z=5
      elseif (convector(2*z5_con_n-1).eq.1) then
        z=6
      endif

c      type *,'----------'
c      type *,'z= ',z

c     
c     getting mass ...
c

      mass=0
      if (convector(2*m1_con_n-1).eq.1) then
        mass=1
      elseif (convector(2*m2_con_n-1).eq.1) then
        mass=2
      elseif (convector(2*m3_con_n-1).eq.1) then
        mass=3         
      elseif (convector(2*m4_con_n-1).eq.1) then
        mass=4
      elseif (convector(2*m5_con_n-1).eq.1) then
        mass=5
      endif

c      type *,'m= ',mass

c     
c     getting neutron fold ...
c
   
      nfoldn=0
      do i=1,12
        if (convector(2*N_CON_n(i)-1).eq.1) then
          nfoldn=nfoldn+1
          ii=i
          call h1inc(nhitn_h_n,ii)
        endif
      enddo

      pev(261)=nfoldn
     
c      type *,'n= ',nfoldn

c
c     incrementing gamma spectra gated with Z, M/Q and neutron fold ...
c

      spn=mass*24+z*4+nfoldn

c      type *,'nrge= ',nrge

      if (nrge.eq.1) then
        ii=pev(101)
        call h2inc(gpart_h_n,ii,spn)
      else
        do i=1,nrge
          ii=pev(100+i)
          call h2inc(ggpart_h_n,ii,spn)
        enddo    
      endif

      user1=.true.

      return
       
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	entry userex
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

        userex=.true.

	return

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	entry fixflt
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c---
c		Entry FixFlt is called each time the fix/flt parameters
c		are being changed. In this way the doppler shifts always
c		have the appropriate values
c---

	gamma = 1./sqrt(1. - beta*beta)

	dps1_5 = (1. - beta*cos(ang1_5/degrad))*gamma
	dps6_10 = (1. - beta*cos(ang6_10/degrad))*gamma
	dps11_15 = (1. - beta*cos(ang11_15/degrad))*gamma
	dps16_20 = (1. - beta*cos(ang16_20/degrad))*gamma
	
	dps(1)  = dps1_5    
	dps(2)  = dps1_5      
	dps(3)  = dps1_5 
	dps(4)  = dps1_5 
	dps(5)  = dps1_5 
	dps(6)  = dps6_10    
	dps(7)  = dps6_10
	dps(8)  = dps6_10    
	dps(9)  = dps6_10
	dps(10) = dps6_10
	dps(11) = dps11_15
	dps(12) = dps11_15   
	dps(13) = dps11_15
	dps(14) = dps11_15
	dps(15) = dps11_15 
	dps(16) = dps16_20
	dps(17) = dps16_20
	dps(18) = dps16_20 
	dps(19) = dps16_20 
	dps(20) = dps16_20

        fixflt=.true.

	return
	end