      PROGRAM Lattic_ntuple
*         CREATES N-TUPLE FROM FLUKA EVENTS
      PARAMETER (Nntuple=76,idimev=10000)

**
      DIMENSION XTUP(nntuple)
      DIMENSION ihelp(idimev),gmhelp(idimev)
      CHARACTER*8 CHTAG(nntuple)
      CHARACTER*80 FILE,FILE1,FILE2,RUNTIT
      CHARACTER*32 RUNTIM
      PARAMETER ( MXUSBN = 20 )
      PARAMETER (IXDIM=100, IYDIM=100, IZDIM=2)
      PARAMETER (NCMAX=100)
      LOGICAL  LNTZER
      CHARACTER*10 TITUSB
      DIMENSION  XLOW(MXUSBN), XHIGH (MXUSBN), YLOW  (MXUSBN),
     &                YHIGH (MXUSBN), ZLOW  (MXUSBN), ZHIGH (MXUSBN),
     &                DXUSBN(MXUSBN), DYUSBN(MXUSBN), DZUSBN(MXUSBN),
     &                TCUSBN(MXUSBN), BKUSBN(MXUSBN), B2USBN(MXUSBN),
     &                NXBIN (MXUSBN), NYBIN (MXUSBN), NZBIN (MXUSBN),
     &                ITUSBN(MXUSBN), IDUSBN(MXUSBN),
     &                LNTZER(MXUSBN),
     &                TITUSB(MXUSBN)
      PARAMETER ( PI = 3.141592653589793D0 )
      DIMENSION qem(4,3),em(4,3)
      DIMENSION qehad(4,4),ehad(4,4)
      DIMENSION qesamp(3),esamp(3)
      DIMENSION qehsamp(4),ehsamp(4)
      EQUIVALENCE (qem(1,1),xtup(1))
      EQUIVALENCE (qesamp(1),xtup(13))
      EQUIVALENCE (qetot,xtup(16))
      EQUIVALENCE (qehad(1,1),xtup(17))
      EQUIVALENCE (qehsamp(1),xtup(33))
      EQUIVALENCE (qehtot,xtup(37))
      EQUIVALENCE (qetotal,xtup(38))
*
      EQUIVALENCE (em(1,1),xtup(39))
      EQUIVALENCE (esamp(1),xtup(51))
      EQUIVALENCE (etot,xtup(54))
      EQUIVALENCE (ehad(1,1),xtup(55))
      EQUIVALENCE (ehsamp(1),xtup(71))
      EQUIVALENCE (ehtot,xtup(75))
      EQUIVALENCE (etotal,xtup(76))
       
**
      COMMON/PAWC/H(70000)
      COMMON/QUEST/IQUEST(100)
      DATA CHTAG/
     &     'qes1r1','qes2r1','qes3r1',
     &     'qes1r2','qes2r2','qes3r2',
     &     'qes1r3','qes2r3','qes3r3',
     &     'qes1r4','qes2r4','qes3r4',
     &     'qes1t','qes2t','qes3t',
     &     'qemtot',
     &     'qhs1r1','qhs2r1','qhs3r1', 'qhs4r1',
     &     'qhs1r2','qhs2r2','qhs3r2','qhs4r2',
     &     'qhs1r3','qhs2r3','qhs3r3', 'qhs4r3',
     &     'qhs1r4','qhs2r4','qhs3r4','qhs4r4',
     &     'qhs1t','qhs2t','qhs3t','qhs4t',
     &     'qhtot','qtotal',
     &     'es1r1','es2r1','es3r1',
     &     'es1r2','es2r2','es3r2',
     &     'es1r3','es2r3','es3r3',
     &     'es1r4','es2r4','es3r4',
     &     'es1t','es2t','es3t',
     &     'emtot',
     &     'hs1r1','hs2r1','hs3r1', 'hs4r1',
     &     'hs1r2','hs2r2','hs3r2','hs4r2',
     &     'hs1r3','hs2r3','hs3r3', 'hs4r3',
     &     'hs1r4','hs2r4','hs3r4','hs4r4',
     &     'hs1t','hs2t','hs3t','hs4t',
     &     'htot','total'/
*
      IQUEST(10)=65000
      CALL HLIMIT(70000)
      WRITE(*,*)' Type the OUTPUT file:'
      READ (*,'(A)')FILE2
c
      CALL HROPEN(44,'RD3',FILE2,'N',1024,ISTAT)
      CALL HBOOKN(2000,'example',nntuple,'RD3',nntuple*100,CHTAG)
 1000 CONTINUE
      CALL HLDIR('//RD3','T')
      CALL HLDIR('//PAWC','T')
      WRITE(*,*)' Type the input file:, 0 to finish'
      READ (*,'(A)')FILE1
      IF ( file1 .eq. '0') GO TO 2000
         FILE=FILE1
      OPEN (UNIT=1,FILE=FILE,STATUS='OLD',FORM='UNFORMATTED',
     &      ERR= 200)
       GO TO 300
  200  CONTINUE
       WRITE(*,*)' Error opening primary file!'
       GO TO 2000
  300  CONTINUE

      IREAD=0
      READ(1)RUNTIT,RUNTIM
      IREAD=IREAD+1
      ib0=0
      DO 1201 IB=IB0+1,1000
         READ (1,ERR=1205,END=1500) NB, TITUSB(IB), ITUSBN(IB),
     &                   IDUSBN(IB),
     &                   XLOW(IB),XHIGH(IB),NXBIN(IB),
     &                   DXUSBN(IB),YLOW(IB),
     &                   YHIGH(IB),NYBIN(IB),DYUSBN(IB),
     &                   ZLOW(IB),ZHIGH(IB),NZBIN(IB),
     &                   DZUSBN(IB),LNTZER(IB),BKUSBN(IB),
     &                   B2USBN(IB),TCUSBN(IB)
         IREAD=IREAD+1
         NBOLD=NB
         NBtot=IB
         WRITE(*,*)XLOW(IB),XHIGH(IB),NXBIN(IB)
         WRITE(*,*)YLOW(IB),YHIGH(IB),NYBIN(IB)
         WRITE(*,*)ZLOW(IB),ZHIGH(IB),NZBIN(IB)
         WRITE(*,*)' NB',NB,NBTOT
 1201 CONTINUE
 1205 CONTINUE
      REWIND 1
      DO I=1,IREAD
        READ(1)
      ENDDO
      WRITE(*,*) IREAD
      DO IEV=1,100000000
         DO I=1,NNTUPLE
            XTUP(i)=0.
         ENDDO
*     
         DO IB=1,NBTOT
            READ(1,END=1500)NB,IEVD,WEI
            IF ( LNTZER(IB) ) THEN
               READ (1, END=1500) NHITS,(IHELP(J),GMHELP(J),J=1,NHITS)
            ELSE
               NHITS=NXBIN(IB)*NYBIN(IB)*NZBIN(IB)
               READ (1, END=1500) (GMHELP(J),J=1,NHITS)
            ENDIF
            DO J=1,NHITS
*                WRITE(*,*) 'IEVD,IHELP(J),GMHELP(J)',
*     &          IEVD,IHELP(J),GMHELP(J)
               IF ( LNTZER(IB) ) THEN
                  IXYZ = IHELP(J)
               ELSE
                  IXYZ =J
               END IF
               IREG=MOD(IXYZ-1,NXBIN(IB)) +1 
               ISAMP= MOD((IXYZ-IREG)/NXBIN(IB),NYBIN(IB))+1
               IRAD=(IXYZ-IREG-(ISAMP-1)*NXBIN(IB))/NXBIN(IB)/
     &              NYBIN(IB) +1
               IREG=IREG+NINT(XLOW(IB))-1 
               ISAMP=(ISAMP-1)/5+1            
*     WRITE(*,*) 'ib: IREG,ISAMP,IRAD',IB, IREG,ISAMP,IRAD
               IF (IB .EQ. 1 ) THEN
                  IF ( IREG .EQ. 4 ) THEN
                     QEM(IRAD,ISAMP)=QEM(IRAD,ISAMP)+GMHELP(J) 
                     QESAMP(ISAMP)=QESAMP(ISAMP)+GMHELP(J) 
                     QETOT=QETOT+GMHELP(J) 
                     QETOTAL=QETOTAL+GMHELP(J) 
                  ELSE IF (IREG .EQ. 21 ) THEN
                     ISAMP=ISAMP-3
                     QEHAD(IRAD,ISAMP)=QEHAD(IRAD,ISAMP)+GMHELP(J) 
                     QEHSAMP(ISAMP)=QEHSAMP(ISAMP)+GMHELP(J) 
                     QEHTOT=QEHTOT+GMHELP(J)
                     QETOTAL=QETOTAL+GMHELP(J) 
                  ENDIF
               ELSE 
                  IF ( IREG .EQ. 4 ) THEN
                     EM(IRAD,ISAMP)=EM(IRAD,ISAMP)+GMHELP(J) 
                     ESAMP(ISAMP)=ESAMP(ISAMP)+GMHELP(J) 
                     ETOT=ETOT+GMHELP(J) 
                     ETOTAL=ETOTAL+GMHELP(J) 
                  ELSE IF (IREG .EQ. 21 ) THEN
                     ISAMP=ISAMP-3
                     EHAD(IRAD,ISAMP)=EHAD(IRAD,ISAMP)+GMHELP(J) 
                     EHSAMP(ISAMP)=EHSAMP(ISAMP)+GMHELP(J) 
                     EHTOT=EHTOT+GMHELP(J)
                     ETOTAL=ETOTAL+GMHELP(J) 
                  ENDIF
               ENDIF            
            ENDDO
         ENDDO
         CALL HFN(2000,XTUP)
      ENDDO
 1500 CONTINUE
      CLOSE(1)
      CLOSE(2)
      GOTO 1000
 2000 CONTINUE
 2200 CONTINUE
      CALL HROUT(0,ICYCLE,' ')
      CALL HREND('RD3')
      STOP
      END


