*-- Author : Stephen J. Maxfield 08/03/91
SUBROUTINE FTCORG
*D: FTCORG.......SM. Extension of FRG1 bank to include asymmetry.
*D: FTCORG.......SM. Get effective stagger from new FCR3 bank.
*D: FTCORG.......SM. Extension of FPG1 bank to include asymmetry.
*D: FTCORG.......SM. Get effective stagger from FCP1 bank.
**: FTCORG 30907 RP. Farm changes.
**----------------------------------------------------------------------
* ========== ======
* Build tables of corrected geometry for Radial and Planar
* Drift Chambers.
* *---------------------------------------------*
* * To be Called at beginning of each New Run *
* *---------------------------------------------*
*
* INPUT: Nominal geometry:- FGAR and FGAP Banks
* Corrections :- F1RC, F1PC, FCP1
* Dead wire maps :- FRDW, FPDW
* Later: shifts from 'shift banks'
*
* OUTPUT: FRG1 and FPG1 banks
*
*! BANKname BANKtype ! Comments
* TABLE FRG1 ! Corrected geometry of Radial Chambers
* ! Row number = Cell number + 1
* ! TEMPORARY.
*! ATTributes:
*! -----------
*!COL ATT-name FMT Min Max ! Comments
*!
* 1 IDEAD I ! Dead wire indicator: 0=OK 1=dead
* 2 PHIWP F ! Angle of +wire
* 3 STAGP F ! Stagger of +wire (effective)
* 4 ZWP F ! Z of +wire
* 5 PHIWM F ! Angle of -wire
* 6 STAGM F ! Stagger of -wire (effective)
* 7 ZWM F ! Z of -wire
* 8 STAGEP F ! Stagger of +wire (geometric)
* 9 STAGEM F ! Stagger of -wire (geometric)
*!
* END TABLE
*! BANKname BANKtype ! Comments
* TABLE FPG1 ! Corrected geometry of Planar Chambers
* ! Row number = Cell number
* ! TEMPORARY.
*! ATTributes:
*! -----------
*!COL ATT-name FMT Min Max ! Comments
*!
* 1 IDEAD I ! Dead wire indicator: 0=OK 1=dead
* 2 PHIW F ! Angle of wire
* 3 STAGE F ! Effective Stagger of wire
* 4 ZWP F ! Z of wire
* 5 STAGG F ! Geometric Stagger of wire
*!
* END TABLE
*#**********************************************************************
*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,H1EVDT.
COMMON /H1EVDT/ KEVENT,IDATA,MONTE,LCONF
INTEGER KEVENT,IDATA,LCONF
LOGICAL MONTE
*
* IDATA type of information (HEAD bank word 6) :
*
* 0 - real data H1
* 1 - MC data H1SIM
* 2 - real data CERN tests
* 3 - MC data ARCET
*
* MONTE = .TRUE. if IDATA=1
* KEVENT = event processed counter for H1REC
*
*KEEP,CNSTBF.
INTEGER LW(NBOSIW)
REAL SW(NBOSIW)
EQUIVALENCE (RW(1),IW(1),LW(1),SW(1))
*KEEP,FWINDS.
* Work bank indices...
COMMON/FWINDS/ INFRRE, INFRPE, ILWPG1, ILWRG1
*KEND.
*
*
*
PARAMETER(TWOPI=6.283185)
PARAMETER(NBN=0)
* Locators for geometrical data in F1RC bank...
PARAMETER(ILDPPL=1)
PARAMETER(ILDPMI=2)
PARAMETER(ILDSPL=3)
PARAMETER(ILDSMI=4)
* Locators for geometrical data in F1PC bank...
PARAMETER(ILPPHI=1)
PARAMETER(ILPSTA=2)
* Locators for data in FCP1 bank...
PARAMETER(ILSTEP=21)
* Locators for data in FCR3 bank...
PARAMETER(ILSTER=51)
* dead wire map...
PARAMETER(ILDEAD=1)
PARAMETER(ILENR=9)
PARAMETER(ILENP=5)
* Local arrays
DIMENSION PPSTRT(0:8),PZSTRT(0:8),PSTAGG(0:8)
DIMENSION RPSTRT(0:2),RZSTRT(0:2)
DIMENSION BAR(ILENR), IAR(ILENR)
EQUIVALENCE(BAR(1), IAR(1))
LOGICAL FIRST
DATA FIRST/.TRUE./
*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))
*KEEP,FTFUNCT.
* Statement functions for RADIAL Chamber data access.
* Using Channel Number J
* Module, Wedge-pair and Z-plane numbers...
IRMOD(J) = J/288
IRWDP(J) = (J-IRMOD(J)*288)/12
IRZPL(J) = J-IRMOD(J)*288-IRWDP(J)*12
* Statement function for obtaining WEDGE numbers(0-47) of
* wires at plus and minus ends of Cell numbers
IRWPL(J) = (IRWDP(J)/2)*4 + (MOD(IRWDP(J),2))
IRWMI(J) = MOD(IRWPL(J) + 34,48)
* Statement function for obtaining IOS wire number (1-36)
IRIOSW(J) = IRMOD(J)*12 + IRZPL(J) + 1
* Statement functions for PLANAR Chamber data access.
* Using Channel Number J
* Module, orientation, W-cell and Z-plane numbers...
IPMOD(J) = J/384
IPORI(J) = (J-IPMOD(J)*384)/128
IPWCL(J) = (J-IPMOD(J)*384-IPORI(J)*128)/4
IPZPL(J) = (J-IPMOD(J)*384-IPORI(J)*128-IPWCL(J)*4)
* IPSMD in range 0:8 Planar module number.
IPSMD(J) = IPMOD(J)*3 + IPORI(J)
*
* IOS wire number (runs from 0 to 36)
IPIOSW(J) = IPSMD(J)*4 + IPZPL(J) + 1
* SB plane numbers (1-72) from cell number
IPSBW(J) = 24*IPMOD(J) + 4*IPORI(J) + IPZPL(J) + 1
IRSBW(J) = 24*IRMOD(J) + IRZPL(J) + 13
* Module, orientation, wire and (typical) cell number from plane
* number in the range 1-72 (planars, radials and combined)
IPMSB(J) = (J - 1)/24
IPOSB(J) = (J - 24*IPMSB(J) - 1)/4
IPZSB(J) = J - 24*IPMSB(J) - 4*IPOSB(J) - 1
IPCLSB(J) = 384*IPMSB(J) + 128*IPOSB(J) + IPZSB(J)
IRMSB(J) = (J - 1)/24
IRZSB(J) = J - 24*IRMSB(J) - 13
IRCLSB(J) = 288*IRMSB(J) + IRZSB(J)
IRADSB(J) = (J - 24*((J-1)/24) - 1)/12
ICELSB(J) = IRADSB(J)*IRCLSB(J) + (1 - IRADSB(J))*IPCLSB(J)
*KEND.
*----------------------------------------------------------------------
*----------------------------------------------------------------------
* Access nominal geometry banks FGAR and FGAP
IF(FIRST) THEN
* --------------
FIRST = .FALSE.
CALL BKFMT('FRG1','2I,(6F)')
CALL BKFMT('FPG1','2I,(3F)')
IQFRG1 = NAMIND('FRG1')
IQFPG1 = NAMIND('FPG1')
CALL UGTBNK('FGAR',INFGAR)
IF( INFGAR .EQ. 0) THEN
WRITE(6,*)' ***FTCORG >> FGAR BANK NOT FOUND'
CALL H1STOP
ENDIF
CALL UGTBNK('FGAP',INDP)
IF( INDP .EQ. 0) THEN
WRITE(6,*)' ***FTCORG >> FGAP BANK NOT FOUND'
CALL H1STOP
ENDIF
* Get basic radial parameters...
NMOD = IW(INFGAR+3)
NWED = IW(INFGAR+4)
NZPL = IW(INFGAR+5)
NCHANR = NMOD*NWED*NZPL/2
*
DPHI = TWOPI / FLOAT(NWED)
STAG = RW(INFGAR+6)
ZSEP = RW(INFGAR+7)
KIND = INFGAR + IW(INFGAR+1) + 1
*
DO 1 KMOD = 0, NMOD-1
RZSTRT(KMOD) = RW(KIND+3)
RPSTRT(KMOD) = RW(KIND+4)
KIND = KIND + IW(KIND+1) + 1
1 CONTINUE
*
* Get basic planar parameters...
NMODP = IW(INDP+3)
NWEDP = IW(INDP+4)
NZPLP = IW(INDP+5)
NCHANP = NMODP*NWEDP*NZPLP
*
ZSEPP = RW(INDP+6)
WZERP = RW(INDP+7)
WSEPP = RW(INDP+8)
KIND = INDP + IW(INDP+1) + 1
DO 2 KMOD = 0, NMODP-1
PZSTRT(KMOD) = RW(KIND+3)
PPSTRT(KMOD) = RW(KIND+4) - TWOPI/4.
PSTAGG(KMOD) = RW(KIND+5)
KIND = KIND + IW(KIND+1) + 1
2 CONTINUE
*
ENDIF
* -----
*
* Hit database for bank with corrections to nominal geometry
CALL UGTBNK('F1RC',INDC)
IF( INDC .EQ. 0) THEN
WRITE(6,*)' ***FTCORG >> F1RC BANK NOT FOUND'
CALL H1STOP
ENDIF
* Hit database for effective stagger.
CALL UGTBNK('FCR3',INDCR3)
IF( INDCR3 .EQ. 0) THEN
WRITE(6,*)' ***FTCORG >> FCR3 BANK NOT FOUND'
CALL H1STOP
ENDIF
* Hit database for dead wire map
CALL UGTRUN('FRDW',INDD)
IF( INDD .EQ. 0) THEN
WRITE(6,*)' ***FTCORG >> FRDW BANK NOT FOUND'
CALL H1STOP
ENDIF
* Check if old FRG1 bank exists. If so drop it.
INDDUM = IW(IQFRG1)
IF(INDDUM.NE.0) THEN
CALL BDROP(IW,'FRG1')
ENDIF
*
DO 3 JJ = 0, NCHANR-1
* Get dead wire flag...
IAR(1) = IBTAB(INDD,ILDEAD,JJ+1)
* Phi of wires at plus and minus end. Nominal...
PWP = RPSTRT(IRMOD(JJ)) + DPHI*IRWPL(JJ) + DPHI/2
PWM = RPSTRT(IRMOD(JJ)) + DPHI*IRWMI(JJ) + DPHI/2
* ... add corrections
BAR(2) = PWP + RBTAB(INDC,ILDPPL,JJ+1)
BAR(5) = PWM + RBTAB(INDC,ILDPMI,JJ+1)
* Geometric stagger of wire...
PSTGR = STAG*( (-1)**IRZPL(JJ) )
* Effective Stagger of wire.
PSTEFR = RBTAB(INDCR3,ILSTER,1)
* Attach sign of geometric stagger...
IF(PSTGR .LT. 0.0) PSTEFR = -PSTEFR
* Monte Carlo has no effective stagger...
IF(MONTE)PSTEFR = PSTGR
* Stagger of plus and minus wires (effective) corrected for
* geometric offsets from nominal...
BAR(3) = PSTEFR + RBTAB(INDC,ILDSPL,JJ+1)
BAR(6) = PSTEFR + RBTAB(INDC,ILDSMI,JJ+1)
* Z of wire (nominal only)
BAR(4) = RZSTRT(IRMOD(JJ)) + ZSEP*IRZPL(JJ) + ZSEP/2.0
BAR(7) = BAR(4)
* Stagger of plus and minus wires (geometric) corrected for
* geometric offsets from nominal...
BAR(8) = PSTGR + RBTAB(INDC,ILDSPL,JJ+1)
BAR(9) = PSTGR + RBTAB(INDC,ILDSMI,JJ+1)
*GDP
* WRITE(6,'('' ** FTCORG.R *'',3I4,8(1X,F7.3))') JJ,IRMOD(JJ),
* & IRZPL(JJ),IAR(1),(BAR(II),II=2,9)
*GDP
IFRG1 = IADROW('FRG1',NBN,ILENR,BAR)
3 CONTINUE
IFRG1 = IADFIN('FRG1',NBN)
*
*
*
* ------------------------------------------------------------------
*
* Planar Geometry
*
*
* Hit database for bank with corrections to nominal geometry
CALL UGTBNK('F1PC',INDC)
IF( INDC .EQ. 0) THEN
WRITE(6,*)' ***FTCORG >> F1PC BANK NOT FOUND'
CALL H1STOP
ENDIF
* Hit database for effective stagger.
CALL UGTBNK('FCP1',INDCP1)
IF( INDCP1 .EQ. 0) THEN
WRITE(6,*)' ***FTCORG >> FCP1 BANK NOT FOUND'
CALL H1STOP
ENDIF
* Hit database for dead wire map
CALL UGTRUN('FPDW',INDD)
IF( INDD .EQ. 0) THEN
WRITE(6,*)' ***FTCORG >> FPDW BANK NOT FOUND'
CALL H1STOP
ENDIF
* Check if old FPG1 bank exists. If so drop it.
INDDUM = IW(IQFPG1)
IF(INDDUM.NE.0) THEN
CALL BDROP(IW,'FPG1')
ENDIF
DO 4 JJ = 0, NCHANP-1
* Get dead wire flag...
IAR(1) = IBTAB(INDD,ILDEAD,JJ+1)
KWCL = IPWCL(JJ)
IF(KWCL .GE. 16) KWCL = KWCL - 6
* Phi of the Wires defined st Phi wire = Phi of +w-axis - pi/2
PHIW = PPSTRT(IPSMD(JJ)) + RBTAB(INDC,ILPPHI,JJ+1)
BAR(2) = PHIW
*
* Geometric stagger of wire...
PSTG = PSTAGG(IPSMD(JJ)) * ( (-1)**IPZPL(JJ) )
* Effective Stagger of wire...
PSTEF = RBTAB(INDCP1,ILSTEP,1)
* Attach sign of geometric stagger, convert from microns to cm...
PSTE = PSTEF / 10000.
IF(PSTG .LT. 0.0) PSTE = -PSTE
* Monte Carlo has no effective stagger...
IF(MONTE)PSTE = PSTG
* W of wire (effective)
BAR(3) = WZERP + KWCL*WSEPP + PSTE
+ + RBTAB(INDC,ILPSTA,JJ+1)
* Z of wire in cell...
BAR(4) = PZSTRT(IPSMD(JJ)) + ZSEPP*IPZPL(JJ) + ZSEPP/2.
* W of wire (geometric)
BAR(5) = WZERP + KWCL*WSEPP + PSTG
+ + RBTAB(INDC,ILPSTA,JJ+1)
*GDP
* WRITE(6,'('' ** FTCORG.P *'',6I4,6(1X,F8.3))') JJ,IPSMD(JJ),
* & IPZPL(JJ),IPWCL(JJ),KWCL,IAR(1),(BAR(II),II=2,4)
*GDP
IFPG1 = IADROW('FPG1',NBN,ILENP,BAR)
4 CONTINUE
IFPG1 = IADFIN('FPG1',NBN)
RETURN
END
*