*-- Author : Stephen Burke SUBROUTINE FFXTRP(JTRUE,S) *-----------------------------------------Updates 02/06/92------- **: FFXTRP.......SB. Change loop indices to please farm. *-----------------------------------------Updates 07/02/92------- **: FFXTRP 30205.SB. Initialise IPF and IRF to please UNDEF. *-----------------------------------------Updates---------------- ********************************************************************** * * * Fill the TRUE array from the track JTRUE using the FRPF/FRRF banks * * * ********************************************************************** DOUBLE PRECISION Z,DZ,S(5),DTRAN(5,5),VX,VY DIMENSION IPF(9),IRF(3) *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,FKPIDP. DOUBLE PRECISION PI,TWOPI,PIBY2 PARAMETER (PI=3.141592653589793238) PARAMETER (TWOPI=PI*2.0D0,PIBY2=PI/2.0D0) *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. ********************************************************************** INDPF = NLINK('FRPF',0) INDRF = NLINK('FRRF',0) IF (INDPF.LT.0 .OR. INDRF.LT.0) RETURN * This isn't actually necessary, but it stops UNDEF complaining CALL VZERO(IPF,9) CALL VZERO(IRF,3) NPMOD = 0 ILOOP = IW(INDPF+2) DO 300 JPF=1,ILOOP IF (NPMOD.GE.9) GOTO 300 JTR = IBTAB(INDPF,18,JPF) IF (JTR.EQ.JTRUE) THEN IMOD = 0 DO 100 JMOD=1,NPMOD ZD = RBTAB(INDPF,3,JPF) - RBTAB(INDPF,3,IPF(JMOD)) IF (ABS(ZD).LT.1.) THEN IMOD = -1 ELSEIF (ZD.LT.0.) THEN IMOD = JMOD ENDIF 100 CONTINUE IF (IMOD.GT.0) THEN DO 200 JMOD=NPMOD,IMOD,-1 IPF(JMOD+1) = IPF(JMOD) 200 CONTINUE IPF(IMOD) = JPF NPMOD = NPMOD + 1 ELSEIF (IMOD.EQ.0) THEN NPMOD = NPMOD + 1 IPF(NPMOD) = JPF ENDIF ENDIF 300 CONTINUE NRMOD = 0 ILOOP = IW(INDRF+2) DO 600 JRF=1,ILOOP IF (NRMOD.GE.3) GOTO 600 JTR = IBTAB(INDRF,17,JRF) IF (JTR.EQ.JTRUE) THEN IMOD = 0 DO 400 JMOD=1,NRMOD ZD = RBTAB(INDRF,3,JRF) - RBTAB(INDRF,3,IRF(JMOD)) IF (ABS(ZD).LT.1.) THEN IMOD = -1 ELSEIF (ZD.LT.0.) THEN IMOD = JMOD ENDIF 400 CONTINUE IF (IMOD.GT.0) THEN DO 500 JMOD=NRMOD,IMOD,-1 IRF(JMOD+1) = IRF(JMOD) 500 CONTINUE IRF(IMOD) = JRF NRMOD = NRMOD + 1 ELSEIF (IMOD.EQ.0) THEN NRMOD = NRMOD + 1 IRF(NRMOD) = JRF ENDIF ENDIF 600 CONTINUE JPF = 0 JRF = 0 DO 900 JPL=1,JPLMAX INDF = 0 Z1 = ZPL(JPL) IF (IRP(JPL).EQ.1) THEN IF (JPF.LT.NPMOD) THEN 700 CONTINUE JPF = JPF + 1 Z2 = RBTAB(INDPF,3,IPF(JPF)) IF (Z2.LE.Z1 .AND. JPF.LT.NPMOD) GOTO 700 IF (Z2.GT.Z1) JPF = JPF - 1 ENDIF IF (JPF.GT.0) THEN INDF = INDPF IF = IPF(JPF) ENDIF ELSE IF (JRF.LT.NRMOD) THEN 800 CONTINUE JRF = JRF + 1 Z2 = RBTAB(INDRF,3,IRF(JRF)) IF (Z2.LE.Z1 .AND. JRF.LT.NRMOD) GOTO 800 IF (Z2.GT.Z1) JRF = JRF - 1 ENDIF IF (JRF.GT.0) THEN INDF = INDRF IF = IRF(JRF) ENDIF ENDIF IF (INDF.GT.0) THEN S(1) = RBTAB(INDF,1,IF) S(2) = RBTAB(INDF,2,IF) VX = RBTAB(INDF,4,IF) VY = RBTAB(INDF,5,IF) S(5) = ATAN2(VY,VX) IF (S(5).LT.0.0D0) S(5) = S(5) + TWOPI DZ = ZPL(JPL) - RBTAB(INDF,3,IF) CALL FKTRAN(DZ,Z,S,TRUE(1,JPL),DTRAN) ENDIF 900 CONTINUE RETURN END *