*-- Author : S.Burke SUBROUTINE FFTRUE(JTRUE) ********************************************************************** * * * Fill the TRUE array from the track JTRUE * * * ********************************************************************** DOUBLE PRECISION Z,DZ,S(5),DTRAN(5,5) INTEGER FFCHG *KEEP,FKNPL. CHARACTER*5 CKDBG PARAMETER (CKDBG='FKDBG') PARAMETER (NPL=72) LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL &, SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN &, RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT * * Per-track values can go in H1WORK; note that LTRUE and LFIRST must * be set at least per event. * * This is about 36k words long; the remaining common blocks are * about 3.6k in total. Some of this could be in /H1WORK/, but the * blocks would have to be reorganised. * COMMON /H1WORK/ * /FKPROJ/ & SPRO(5,NPL),CPRO(5,5,NPL) * /FKFILT/ &, SFIL(5,NPL),CFIL(5,5,NPL) * /FKSMTH/ &, SSMT(5,NPL),CSMT(5,5,NPL) &, SSMTR(5,NPL),CSMTR(5,5,NPL) * /FKINT/ &, DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL) &, QGAIN(5,5,NPL),IAPROX,LFIRST * /FKRSID/ &, RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL) &, CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL) &, CHIFIL(NPL),CHISMT(NPL) * /FKTRUE/ &, TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE * /FKDBG/ &, LTRPL(NPL),LTRPLD(NPL) *KEEP,FFSTEE. PARAMETER (NFT=72) LOGICAL LRISV,LWMAP,LGRAPH,LTRUTH REAL DSX,DSY,DSQOP,DSTTH,DSPHI,PMCUT,PCUT,CHPCUT &, QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX COMMON /FFSTEE/ DSX,DSY,DSQOP,DSTTH,DSPHI &, PMCUT,IDIAG,JPLRSV,LRISV,LWMAP(NFT),JPLMAX &, IRP(NPL),JPLFT(NPL),JFTPL(NFT) &, LUNGKS,IWKGKS,IDGKS,LUNHB,LUNGKM,IWKGKM,IDGKM &, LGRAPH,LTRUTH,IHFF,IHFK,ISRJCT,PCUT,CHPCUT &, QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX *KEEP,FKCONS. DOUBLE PRECISION ZPL,DZPL,RADL COMMON /FKCONS/ ZPL(NPL),DZPL(NPL),RADL(NPL) *KEEP,FKTRUE. *KEEP,BCS. INTEGER NHROW,NHCOL,NHLEN PARAMETER (NHROW = 2, NHCOL = 1, NHLEN=2) INTEGER NBOSIW PARAMETER (NBOSIW=1000000) INTEGER IW(NBOSIW) REAL RW(NBOSIW) COMMON /BCS/ IW EQUIVALENCE (RW(1),IW(1)) SAVE /BCS/ *KEEP,STFUNCT. * index of element before row number IROW INDR(IND,IROW)=IND+2+IW(IND+1)*(IROW-1) * index of L'th element of row number IROW INDCR(IND,L,IROW)=INDR(IND,IROW) + L * L'th integer element of the IROW'th row of bank with index IND IBTAB(IND,L,IROW)=IW(INDCR(IND,L,IROW)) * L'th real element of the IROW'th row of bank with index IND RBTAB(IND,L,IROW)=RW(INDCR(IND,L,IROW)) *KEND. ********************************************************************** LTRUE = .FALSE. * Find the starting track bank (if it exists) INDFS = NLINK('FS ',0) IF (INDFS.GT.0) THEN * Find the track with the right STR number JTRACK = 0 100 CONTINUE JTRACK = JTRACK + 1 IF (JTRACK.GT.IW(INDFS+2)) THEN * This should be impossible, but ... INDFS = 0 GOTO 150 ENDIF JSTR = IBTAB(INDFS,10,JTRACK) IF (JSTR.NE.JTRUE) GOTO 100 PX = RBTAB(INDFS,1,JTRACK) PY = RBTAB(INDFS,2,JTRACK) PZ = RBTAB(INDFS,3,JTRACK) IPDG = IBTAB(INDFS,4,JTRACK) X = RBTAB(INDFS,5,JTRACK) Y = RBTAB(INDFS,6,JTRACK) Z = RBTAB(INDFS,7,JTRACK) ENDIF 150 CONTINUE IF (INDFS.LE.0) THEN * Find the simulated track and vertex banks INDSTR = NLINK('STR ',0) INDSVX = NLINK('SVX ',0) IF (INDSTR.LE.0 .OR. INDSVX.LE.0) RETURN IF (JTRUE.LE.0 .OR. JTRUE.GT.IW(INDSTR+2)) RETURN * Get the track parameters at the vertex PX = RBTAB(INDSTR,1,JTRUE) PY = RBTAB(INDSTR,2,JTRUE) PZ = RBTAB(INDSTR,3,JTRUE) IPDG = IBTAB(INDSTR,5,JTRUE) JSVX = IBTAB(INDSTR,9,JTRUE) X = RBTAB(INDSVX,1,JSVX) Y = RBTAB(INDSVX,2,JSVX) Z = RBTAB(INDSVX,3,JSVX) ENDIF ICHG = FFCHG(IPDG) * Can be a gamma (if secondaries are stacked), which screws up FKTRAN IF (ICHG.EQ.0) RETURN * Assemble a KF-type state vector P = SQRT(PX*PX + PY*PY + PZ*PZ) PT = SQRT(PX*PX + PY*PY) S(1) = X S(2) = Y S(3) = FLOAT(ICHG)/P S(4) = PT/PZ S(5) = ATAN2(PY,PX) CALL FKNORM(S,IFAIL) IF (IFAIL.GE.100) RETURN * Translate to each plane in succession DO 200 JPL=1,JPLMAX DZ = ZPL(JPL) - Z CALL FKTRAN(DZ,Z,S,TRUE(1,JPL),DTRAN) 200 CONTINUE * Use FRPF/FRRF banks if available CALL FFXTRP(JTRUE,S) LTRUE = .TRUE. RETURN END *