*CMZ : 16/09/99 09.49.24 by Girish D. Patel *CMZU: 3.01/00 28/02/94 07.10.43 by Stephan Egli *CMZU: 2.08/04 16/09/92 15.26.04 by Stephan Egli *CMZU: 2.05/00 01/11/91 16.31.24 by Stephan Egli *CMZ : 2.00/00 10/02/91 09.09.28 by Stephan Egli *CMZ : 1.08/02 06/02/91 17.15.18 by Stephan Egli *-- Author : SUBROUTINE FGEOM * *#********************************************************************** *# * *# SUBROUTINE FGEOM * *# * *# PURPOSE: Define Forward Tracker Materials Media and Geometry * *# * *# CALLED BY : UGEOM * *# * *# INPUT : BOS BANKS FGMX,FGLM,FGME,FGRO,FGDR,FGDP,FGDM,FGAM * *# * *# OUTPUT : COMMON /FTROTM/ NFROT(0:LFROT) filled & GEOMETRY defined * *# * *# AUTHOR : Girish D. Patel * *# * *# CHANGED BY: Girish D. Patel AT: 17/8/89 * *# REASON : CALL TO UDFPAR INSERTED (FGTP bank used) * *# CHANGED BY: Girish D. Patel AT: 14/3/90 * *# REASON : GSORD call for FPSZ commented, not valid in coarse option * *# CHANGED BY: Girish D. Patel AT: 15/09/99 * *# REASON : Changes for forward tracker upgrade * *#********************************************************************** * * *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,H1OSGO. COMMON /H1OSGO/ LCONFG,IGEAND(13),RGEANC(16),IGEANP(12) *KEND. * *KEEP,FROTM. PARAMETER (LFROTM = 10 ) COMMON /FROTM/ NFROT(0:LFROTM) *KEND. * WRITE(6,*) ' FGEOM CALLED LCONFG = ',LCONFG * FORWARD TRACKER IS DETECTOR NUMBER 2 NFDET = 2 * * DEFINE FORWARD TRACKING MATERIAL CONSTANTS FROM FGMA BOS BANK * * CALL UGTBNK( 'FGMA', INDB ) * IF( INDB.LE.0 ) THEN * WRITE(6,*) ' ** SUBR. UGEOFT ** FGMA BANK NOT FOUND ==> STOP ' * STOP * ELSE * CALL UDFMAT( INDB ) * ENDIF * * DEFINE FORWARD TRACKING MATERIAL MIXTURES FROM FGMX BOS BANK * CALL UGTBNK( 'FGMX', INDB ) IF( INDB.LE.0 ) THEN WRITE(6,*) ' ** SUBR. UGEOFT ** FGMX BANK NOT FOUND ==> STOP ' STOP ELSE CALL UDFMIX( INDB ) ENDIF * CALL UGTBNK( 'FGLM', INDB ) IF( INDB.LE.0 ) THEN WRITE(6,*) ' ** SUBR. UGEOFT ** FGLM BANK NOT FOUND ==> STOP ' STOP ELSE CALL UDFLMX( INDB ) ENDIF * * DEFINE FORWARD TRACKING MEDIA PARAMETERS FROM FGME BOS BANK * CALL UGTBNK( 'FGME', INDB ) IF( INDB.LE.0 ) THEN WRITE(6,*) ' ** SUBR. UGEOFT ** FGME BANK NOT FOUND ==> STOP ' STOP ELSE CALL UDFMED( INDB ) ENDIF * * DEFINE SPECIAL TRACKING MEDIA PARAMETERS FROM FGTP BOS BANK * CALL UGTBNK( 'FGTP', INDB ) IF( INDB.LE.0 ) THEN WRITE(6,*) ' ** SUBR. FGEOM ** FGTP BANK NOT FOUND ==> ', + 'Default values will be used' ELSE CALL UDFPAR( INDB ) ENDIF * * DEFINE GEANT ROTATION MATRICES FOR FORWARD TRACKER FROM FGRO BOS BANK * CALL UGTBNK( 'FGRO', INDB ) IF( INDB.LE.0 ) THEN WRITE(6,*) ' ** SUBR. UGEOFT ** FGRO BANK NOT FOUND ==> STOP ' STOP ELSE CALL UDFROT( INDB, NFROT, LFROTM ) ENDIF * *======================================================================= * NOW DEFINE DETECTORS *======================================================================= * IF(LCONFG.LT.10) THEN WRITE(6,*) ' FGEOM CALLED OLD SETUP ',LCONFG * * DEFINE GEOMETRY OF PLANAR SET UP FROM FGDP BOS BANK * CALL UGTBNK( 'FGDP' , INDB ) IF( INDB.LE.0 ) THEN WRITE(6,*) ' ** SUBR. UGEOFT ** FGDP BANK NOT FOUND ==> STOP ' STOP ELSE CALL UDFVOL( INDB, NFROT, LFROTM ) ENDIF * * DEFINE ACTIVE VOLUME STRUCTURE for PLANARS * CALL FPGEOM * * DEFINE GEOMETRY OF MWPC SET UP FROM FGDM BOS BANK * CALL UGTBNK( 'FGDM' , INDB ) IF( INDB.LE.0 ) THEN WRITE(6,*) ' ** SUBR. UGEOFT ** FGDM BANK NOT FOUND ==> STOP ' STOP ELSE CALL UDFVOL( INDB, NFROT, LFROTM ) ENDIF * * DEFINE GEOMETRY OF RADIAL SET UP FROM FGDR BOS BANK * CALL UGTBNK( 'FGDR' , INDB ) IF( INDB.LE.0 ) THEN WRITE(6,*) ' ** SUBR. UGEOFT ** FGDR BANK NOT FOUND ==> STOP ' STOP ELSE CALL UDFVOL( INDB, NFROT, LFROTM ) ENDIF * * DEFINE ACTIVE VOLUME STRUCTURE for RADIALS * CALL FRGEOM * * PERFORM ORDERING OF VOLUMES FOR SPEEDING SEARCH * CALL GSORD('FRAD',3) *GDP CALL GSORD('FPSZ',1) CALL GSORD('FWPC',3) CALL GSORD('FPLN',3) CALL GSORD('FWDT',3) * ELSE WRITE(6,*) ' FGEOM CALLED UPGRADE SETUP',LCONFG * * DEFINE GEOMETRY OF UPGRADED PLANAR SET UP FROM FGDQ BOS BANK * CALL UGTBNK( 'FGDQ' , INDB ) IF( INDB.LE.0 ) THEN WRITE(6,*) ' ** SUBR. UGEOFT ** FGDQ BANK NOT FOUND ==> STOP ' STOP ELSE CALL UDFVOL( INDB, NFROT, LFROTM ) ENDIF * * DEFINE ACTIVE VOLUME STRUCTURE for UPGRADED/OLD PLANARS * CALL FOGEOM CALL FQGEOM ENDIF * * DEFINE SENSITIVE DETECTOR VOLUMES * CALL FDET * * CALL BDROP(IW,'FGMAFGMXFGLMFGMEFGTPFGROFGDPFGDMFGDRFGAMFGAP') * CALL BDROP(IW,'FGARFGATFGDR') 99 RETURN END *CMZ : 15/09/99 16.51.52 by Girish D. Patel *-- Author : Girish D. Patel SUBROUTINE FOGEOM *#********************************************************************** *# * *# VERSION: 02/03/90 Steve Maxfield * *# * *# PURPOSE: Define Active OLD PLANAR Chamber Geometry * *# * *# CALLED BY : FGEOM * *# * *# INPUT : BOS BANK FGAO * *# * *# OUTPUT : * *# * *# AUTHOR : Girish D. Patel * *# * *# CHANGED BY: AT: * *# REASON : * *#********************************************************************** * *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/ *KEND. * *KEEP,FROTM. PARAMETER (LFROTM = 10 ) COMMON /FROTM/ NFROT(0:LFROTM) *KEND. * *KEEP,H1DETC. PARAMETER (NSUBDE=8) COMMON /H1DETC/ NAMSUB(NSUBDE),ISGRAN(NSUBDE),ISRBNK(NSUBDE), 1 ISDSBK(NSUBDE),ISTRKB(NSUBDE),ISTRKM(NSUBDE), 1 SKECUT(NSUBDE+2) *KEND. * DIMENSION PFPSW(3),ALEN(20) DIMENSION PFPSC(3),PFPSB(3) * CALL UGTBNK( 'FGAO', INDB ) IF(INDB.LE.0) THEN WRITE(6,*) ' ** SUBR. FOGEOM ** FGAO BANK NOT FOUND ==> STOP ' STOP ELSE * Number of cells across a planar chamber in w NCELL = IW(INDB+4) * Number of wires in a planar chamber in z NZ = IW(INDB+5) * Halfwidth of a planar cell in w, -0.04 to allow for G10 cathode PFPSW(1) = RW(INDB+8)/2.0 - 0.04 * Halflength of a planar cell in y, defined later since they vary PFPSW(2) = 0.0 * Halfdepth of a planar cell in z, wire spacing*no. wires in z PFPSW(3) = RW(INDB+6)*4.0/2.0 CALL UCOPY(RW(INDB+9),ALEN(1),NCELL/2) ENDIF * Halfwidth of a planar cathode in w PFPSC(1) = 0.04 * Halflength of a planar cathode in y, defined later since they vary PFPSC(2) = 0.0 * Halfdepth of a planar cathode in z, PFPSW(3) + 0.4 (dead area) PFPSC(3) = PFPSW(3) + 0.4 * Halfwidth of a planar pin block in w PFPSB(1) = PFPSW(1) * Halflength of a planar cathode in y PFPSB(2) = 0.5 * Halfdepth of a planar cathode in z, PFPSW(3) + 0.4 (dead area) PFPSB(3) = PFPSW(3) + 0.4 * * DEFINE GEOMETRY FOR PLANAR CHAMBERS * XPOS = RW(INDB+7) - RW(INDB+8) * DO 10 I = 1 , NCELL/2 JJ = I * x,y position of centre of a planar cell XPOS = XPOS + RW(INDB+8) YPOS = 0.0 * central 'broken' cells are displaced about beam hole IF(I.GT.10) YPOS = RW(INDB + 14+I) * Halflength of a planar cell in y PFPSW(2) = ALEN(I)/2.0 * x,y position of centre of a planar cathode XPOSS = XPOS - RW(INDB+8)/2. YPOSS = 0.0 * Halflength of a planar cathode in y PFPSC(2) = ALEN(I)/2.0 + 1.0 IF(I.EQ.11) THEN PFPSC(2) = ALEN(I)/2.0 + RW(INDB +14+I) + 1.0 ELSE IF(I.EQ.12.OR.I.EQ.13) THEN YLEN = ( RW(INDB + 14+I ) + ALEN(I)/2.0 ) - & ( RW(INDB + 14+I-1) - ALEN(I-1)/2.0 ) PFPSC(2) = YLEN/2.0 + 1.0 YPOSS = ( RW(INDB + 14+I-1) - ALEN(I-1)/2.0 ) + YLEN/2.0 ELSE IF(I.EQ.14.OR.I.EQ.15) THEN JJ = I + 1 YLEN = ( RW(INDB + 14+I ) + ALEN(I)/2.0 ) - & ( RW(INDB + 14+I+1) - ALEN(I+1)/2.0 ) PFPSC(2) = YLEN/2.0 + 1.0 XPOSS = XPOS + RW(INDB+8)/2. YPOSS = ( RW(INDB + 14+I+1) - ALEN(I+1)/2.0 ) + YLEN/2.0 ELSE IF(I.EQ.16) THEN JJ = 14 PFPSC(2) = ALEN(13)/2.0 + 1.0 XPOSS = 0.0 YPOSS = RW(INDB + 14+13) ENDIF * position sensitive volumes CALL GSPOSP('FPSW',I,'FPS0',XPOS,YPOS,0.,0,'ONLY',PFPSW,3) CALL GSPOSP('FPSW',33-I,'FPS0',-XPOS,-YPOS,0.,0,'ONLY', & PFPSW,3) * position noryl pin support blocks YPOSU = YPOS + ALEN(I)/2.0 + 0.5 YPOSB = -YPOSU IF(I.GT.10) YPOSB = YPOS - ALEN(I)/2.0 - 0.5 CALL GSPOSP('FPSB',I,'FPS0',XPOS,YPOSU,0.,0,'ONLY', & PFPSB,3) CALL GSPOSP('FPSB',I+32,'FPS0',XPOS,YPOSB,0.,0,'ONLY', & PFPSB,3) CALL GSPOSP('FPSB',33-I,'FPS0',-XPOS,-YPOSU,0.,0,'ONLY', & PFPSB,3) CALL GSPOSP('FPSB',33-I+32,'FPS0',-XPOS,-YPOSB,0.,0,'ONLY', & PFPSB,3) * position cathode planes CALL GSPOSP('FPSC',JJ,'FPS0',XPOSS,YPOSS,0.,0,'ONLY', & PFPSC,3) CALL GSPOSP('FPSC',33-JJ,'FPS0',-XPOSS,-YPOSS,0.,0,'ONLY', & PFPSC,3) * WRITE(6,*) ' ** FPGEOM **',I,XPOS,YPOS,PFPSW,PFPSC 10 CONTINUE * IF(ISGRAN(2) .EQ. 1) THEN * DIVIDE EACH PLANE CELL IN W (FPSW) INTO 4 IN Z (FPSZ) CALL GSDVN('FPSZ','FPSW',NZ,3) * * DEFINE GEOMETRY FOR MEDIUM GRANULARITY OPTION * ELSE IF(ISGRAN(2) .EQ. 3) THEN * NO DIVISION IN Z OF THE CELLS, EACH BOX IS THEREFORE NZ TIMES AS WIDE * ELSE WRITE(6,*) ' ILLEGAL FORWARD TRACKER GRANULARITY, ISGRAN= ', & ISGRAN, ' PROGRAM STOPPED IN FPGEOM ' STOP ENDIF * RETURN END *CMZ : 15/09/99 16.56.13 by Girish D. Patel *-- Author : SUBROUTINE FQGEOM *#********************************************************************** *# * *# VERSION: 21/07/98 Girish D. Patel * *# * *# PURPOSE: Define NEW Active PLANAR Chamber Geometry * *# * *# CALLED BY : FGEOM * *# * *# INPUT : BOS BANK FGAQ * *# * *# OUTPUT : * *# * *# AUTHOR : Girish D. Patel * *# * *#********************************************************************** * *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/ *KEND. * *KEEP,FROTM. PARAMETER (LFROTM = 10 ) COMMON /FROTM/ NFROT(0:LFROTM) *KEND. * *KEEP,H1DETC. PARAMETER (NSUBDE=8) COMMON /H1DETC/ NAMSUB(NSUBDE),ISGRAN(NSUBDE),ISRBNK(NSUBDE), 1 ISDSBK(NSUBDE),ISTRKB(NSUBDE),ISTRKM(NSUBDE), 1 SKECUT(NSUBDE+2) *KEND. * DIMENSION PFQSW(3),ALEN(20) DIMENSION PFQSC(3),PFQSB(3) * CALL UGTBNK( 'FGAQ', INDB ) IF(INDB.LE.0) THEN WRITE(6,*) ' ** SUBR. FQGEOM ** FGAQ BANK NOT FOUND ==> STOP ' STOP ELSE * Number of cells across a planar chamber in w NCELL = IW(INDB+4) * Number of wires in a planar chamber in z NZ = IW(INDB+5) * Halfwidth of a planar cell in w, -0.04 to allow for G10 cathode PFQSW(1) = RW(INDB+8)/2.0 - 0.04 * Halflength of a planar cell in y, defined later since they vary PFQSW(2) = 0.0 * Halfdepth of a planar cell in z, wire spacing*no. wires in z PFQSW(3) = RW(INDB+6)*FLOAT(IW(INDB+5))/2.0 CALL UCOPY(RW(INDB+9),ALEN(1),NCELL/2) ENDIF * Halfwidth of a planar cathode in w PFQSC(1) = 0.04 * Halflength of a planar cathode in y, defined later since they vary PFQSC(2) = 0.0 * Halfdepth of a planar cathode in z, PFQSW(3) + 0.3 (dead area) PFQSC(3) = PFQSW(3) + 0.3 * Halfwidth of a planar pin block in w PFQSB(1) = PFQSW(1) * Halflength of a planar cathode in y PFQSB(2) = 0.5 * Halfdepth of a planar cathode in z, PFQSW(3) + 0.3 (dead area) PFQSB(3) = PFQSW(3) + 0.3 * * DEFINE GEOMETRY FOR PLANAR CHAMBERS * XPOS = RW(INDB+7) - RW(INDB+8) * DO 10 I = 1 , NCELL/2 JJ = I * x,y position of centre of a planar cell XPOS = XPOS + RW(INDB+8) YPOS = 0.0 * central 'broken' cells are displaced about beam hole IF(I.GT.8) YPOS = RW(INDB + 14+I) * Halflength of a planar cell in y PFQSW(2) = ALEN(I)/2.0 * x,y position of centre of a planar cathode XPOSS = XPOS - RW(INDB+8)/2. YPOSS = 0.0 * Halflength of a planar cathode in y PFQSC(2) = ALEN(I)/2.0 + 1.0 IF(I.EQ.9) THEN PFQSC(2) = ALEN(I)/2.0 + RW(INDB +14+I) + 1.0 ELSE IF(I.EQ.10.OR.I.EQ.11) THEN YLEN = ( RW(INDB + 14+I ) + ALEN(I)/2.0 ) - & ( RW(INDB + 14+I-1) - ALEN(I-1)/2.0 ) PFQSC(2) = YLEN/2.0 + 1.0 YPOSS = ( RW(INDB + 14+I-1) - ALEN(I-1)/2.0 ) + YLEN/2.0 ELSE IF(I.EQ.12.OR.I.EQ.13) THEN JJ = I + 1 YLEN = ( RW(INDB + 14+I ) + ALEN(I)/2.0 ) - & ( RW(INDB + 14+I+1) - ALEN(I+1)/2.0 ) PFQSC(2) = YLEN/2.0 + 1.0 XPOSS = XPOS + RW(INDB+8)/2. YPOSS = ( RW(INDB + 14+I+1) - ALEN(I+1)/2.0 ) + YLEN/2.0 ELSE IF(I.EQ.14) THEN JJ = 12 PFQSC(2) = ALEN(11)/2.0 + 1.0 XPOSS = 0.0 YPOSS = RW(INDB + 14+11) ENDIF * position sensitive volumes CALL GSPOSP('FQSW',I,'FQS0',XPOS,YPOS,0.,0,'ONLY',PFQSW,3) CALL GSPOSP('FQSW',29-I,'FQS0',-XPOS,-YPOS,0.,0,'ONLY', & PFQSW,3) * position noryl pin support blocks YPOSU = YPOS + ALEN(I)/2.0 + 0.5 YPOSB = -YPOSU IF(I.GT.8) YPOSB = YPOS - ALEN(I)/2.0 - 0.5 CALL GSPOSP('FQSB',I,'FQS0',XPOS,YPOSU,0.,0,'ONLY', & PFQSB,3) CALL GSPOSP('FQSB',I+28,'FQS0',XPOS,YPOSB,0.,0,'ONLY', & PFQSB,3) CALL GSPOSP('FQSB',29-I,'FQS0',-XPOS,-YPOSU,0.,0,'ONLY', & PFQSB,3) CALL GSPOSP('FQSB',29-I+28,'FQS0',-XPOS,-YPOSB,0.,0,'ONLY', & PFQSB,3) * position cathode planes CALL GSPOSP('FQSC',JJ,'FQS0',XPOSS,YPOSS,0.,0,'ONLY', & PFQSC,3) CALL GSPOSP('FQSC',29-JJ,'FQS0',-XPOSS,-YPOSS,0.,0,'ONLY', & PFQSC,3) c WRITE(6,'(A13,I3,5F8.2)') ' **FQGEOM W**', c & I,XPOS,YPOS,PFQSW c WRITE(6,'(A13,I3,6F8.2)') ' **FQGEOM B**', c & I,XPOS,YPOSU,YPOSB,PFQSB c WRITE(6,'(A13,I3,5F8.2)') ' **FQGEOM C**', c & I,XPOSS,YPOSS,PFQSC 10 CONTINUE * IF(ISGRAN(2) .EQ. 1) THEN * DIVIDE EACH PLANE CELL IN W (FPSW) INTO 4 IN Z (FPSZ) CALL GSDVN('FQSZ','FQSW',NZ,3) * * DEFINE GEOMETRY FOR MEDIUM GRANULARITY OPTION * ELSE IF(ISGRAN(2) .EQ. 3) THEN * NO DIVISION IN Z OF THE CELLS, EACH BOX IS THEREFORE NZ TIMES AS WIDE * ELSE WRITE(6,*) ' ILLEGAL FORWARD TRACKER GRANULARITY, ISGRAN= ', & ISGRAN, ' PROGRAM STOPPED IN FQGEOM ' STOP ENDIF * RETURN END *CMZ : 15/09/99 17.09.26 by Girish D. Patel *CMZU: 2.13/00 09/12/92 16.54.33 by Girish D. Patel *CMZ : 2.00/00 10/02/91 09.09.28 by Stephan Egli *CMZ : 1.08/02 06/02/91 13.38.38 by Stephan Egli *-- Author : SUBROUTINE FDET *#********************************************************************** *# * *# VERSION: 02/03/90 Steve Maxfield * *# * *# PURPOSE: Sensitive Volume and Hit structure definition * *# * *# CALLED BY : FGEOM * *# * *# INPUT : * *# * *# OUTPUT : GEANT Hit and Volume structures * *# * *# AUTHOR : Steve Maxfield, Girish D. Patel * *# * *# CHANGED BY: GDP, PR AT: 9/5/89 * *# REASON : * MODIFIED FOR APOLLO * *# Changed by: S.Egli at 1.4.90: all GSDETH calls removed. * *# CHANGED BY: G. D. Patel AT: 4/12/92 * *# REASON : * Planar geometry structure modified, FPSW => FPSZ * *#********************************************************************** * * *KEEP,GCFLAG. COMMON/GCFLAG/IDEBUG,IDEMIN,IDEMAX,ITEST,IDRUN,IDEVT,IEORUN + ,IEOTRI,IEVENT,ISWIT(10),IFINIT(20),NEVENT,NRNDM(2) COMMON/GCFLAX/BATCH, NOLOG LOGICAL BATCH, NOLOG C INTEGER IDEBUG,IDEMIN,IDEMAX,ITEST,IDRUN,IDEVT,IEORUN + ,IEOTRI,IEVENT,ISWIT,IFINIT,NEVENT,NRNDM C *KEND. * *KEEP,H1DETC. PARAMETER (NSUBDE=8) COMMON /H1DETC/ NAMSUB(NSUBDE),ISGRAN(NSUBDE),ISRBNK(NSUBDE), 1 ISDSBK(NSUBDE),ISTRKB(NSUBDE),ISTRKM(NSUBDE), 1 SKECUT(NSUBDE+2) *KEEP,H1OSGO. COMMON /H1OSGO/ LCONFG,IGEAND(13),RGEANC(16),IGEANP(12) *KEND. * INTEGER NWHI INTEGER NWDI * DATA NWHI /100/ DATA NWDI /0/ * * ALLOCATE SENSITIVE DETECTOR VOLUMES TO SETS AND DEFINE HIT VARIABLES * *----------------------------------------------------------------------- IF(LCONFG.LT.10) THEN * RADIALS.... I2 = 201 IF (ISGRAN(2) .EQ. 1) THEN CALL GSDETV('FRSD','FRSZ',I2,NWHI,NWDI,ISETR,IDETR) ELSE IF(ISGRAN(2) .EQ. 3) THEN CALL GSDETV('FRSD','FRS0',I2,NWHI,NWDI,ISETR,IDETR) ELSE WRITE(6,*)' ** FDET ** ERROR - GRANULARITY UNDEFINED, STOP' STOP ENDIF IF(ISWIT(2).EQ.1) WRITE(6,*) ' ** FDET ** ISETR = ',ISETR &,' IDETR = ',IDETR * * PLANARS.... I2 = 202 IF (ISGRAN(2) .EQ. 1 ) THEN CALL GSDETV('FPSD','FPSZ',I2,NWHI,NWDI,ISETP,IDETP) ELSE IF(ISGRAN(2) .EQ. 3) THEN CALL GSDETV('FPSD','FPSW',I2,NWHI,NWDI,ISETP,IDETP) ELSE WRITE(6,*)' ** FDET ** ERROR - GRANULARITY UNDEFINED, STOP' STOP ENDIF IF(ISWIT(2).EQ.1) WRITE(6,*) ' ** FDET ** ISETP = ',ISETP &,' IDETP = ',IDETP * MWPCS.... I2=203 CALL GSDETV('FMWP','FMAC',I2,NWHI,NWDI,ISETM,IDETM) * CALL GSDETH('FMWP','FMAC',NHITSN,NAMESH,NBITSH,ORIG,FACT) IF(ISWIT(2).EQ.1) WRITE(6,*) ' ** FDET ** ISETM = ',ISETM &,' IDETP = ',IDETP * * TR... I2 = 204 CALL GSDETV('FTSD','FTRD',I2,NWHI,NWDI,ISETT,IDETT) * CALL GSDETH('FTSD','FTRD',NHITSN,NAMESH,NBITSH,ORIG,FACT) IF(ISWIT(2).EQ.1) WRITE(6,*) ' ** FDET ** ISETT = ',ISETT &,' IDETT = ',IDETT * *----------------------------------------------------------------------- ELSE * OLD PLANARS.... I2 = 202 IF (ISGRAN(2) .EQ. 1 ) THEN CALL GSDETV('FPSD','FPSZ',I2,NWHI,NWDI,ISETP,IDETP) ELSE IF(ISGRAN(2) .EQ. 3) THEN CALL GSDETV('FPSD','FPSW',I2,NWHI,NWDI,ISETP,IDETP) ELSE WRITE(6,*)' ** FDET ** ERROR - GRANULARITY UNDEFINED, STOP' STOP ENDIF IF(ISWIT(2).EQ.1) WRITE(6,*) ' ** FDET ** ISETP = ',ISETP &,' IDETP = ',IDETP * NEW PLANARS.... I2 = 203 IF (ISGRAN(2) .EQ. 1 ) THEN CALL GSDETV('FQSD','FQSZ',I2,NWHI,NWDI,ISETP,IDETP) ELSE IF(ISGRAN(2) .EQ. 3) THEN CALL GSDETV('FQSD','FQSW',I2,NWHI,NWDI,ISETP,IDETP) ELSE WRITE(6,*)' ** FDET ** ERROR - GRANULARITY UNDEFINED, STOP' STOP ENDIF IF(ISWIT(2).EQ.1) WRITE(6,*) ' ** FDET ** ISETP = ',ISETP &,' IDETP = ',IDETP *----------------------------------------------------------------------- ENDIF RETURN END *CMZ : 16/09/99 15.28.50 by Girish D. Patel *CMZU: 2.13/00 09/12/92 16.54.33 by Girish D. Patel *CMZ : 2.00/00 10/02/91 09.09.28 by Stephan Egli *CMZ : 1.08/02 06/02/91 13.38.39 by Stephan Egli *-- Author : SUBROUTINE FPHIT *#********************************************************************** *# * *# VERSION: 02/03/90 Steve Maxfield * *# * *# PURPOSE: fill PLANAR CHAMBERS response and GEANT HIT banks * *# * *# CALLED BY : FSTEP * *# * *# INPUT : GEANT track data * *# * *# OUTPUT : FRPF bank OR FRPT bank * *# ==== ==== * *# AUTHOR : Steve Maxfield * *# * *# CHANGED BY: S. J MAXFIELD AT: 26/02/90 * *# REASON : Bank formats completely changed + Coarse Granularity * *# Convert to new reduced format(see below) * *# If Granularity flag = 1 (fine) FRPT bank is produced * *# If granularity is 2 (coarse) reduced format FRPF bank is * *# produced instead. * *# + NB. single FRPT (tabular) bank with fine granularity. * *# + Convert to new cell numbering scheme. * *# CHANGED BY S. EGLI at 10.3.90 * *# Reason: exchanged position of partial cell number and ITRHIS in * *# order to have the ITRHIS word in the "standard" location * *# PDG particle code introduced * *# CHANGED BY: G. D. Patel AT: 4/12/92 * *# REASON : Planar geometry change requires NUMBV change for chan.no. * *#********************************************************************** *# * *# FORMAT OF FRPF BANK 2I,(14F,4I) Bank Number = 0 * *# ====== == ==== ==== * *# BANK FRPF Forward Planar Response (Fast-form) * *# CONTAINS ALL TRACKPOINTS OF ALL TRACKS * *# * *# word# type Content * *# 1 I NCOL = 18 * *# 2 I Number of track points * *# ---------------------------------------------------------------- * *# Col * *# 1 R X in Attrib * *# 2 R Y in Attrib * *# 3 R Z in Attrib * *# 4 R PX/P in Attrib * *# 5 R PY/P in Attrib * *# 6 R PZ/P in Attrib * *# 7 R P in Attrib * *# * *# 8 R X out Attrib * *# 9 R Y out Attrib * *# 10 R Z out Attrib * *# 11 R PX/P out Attrib * *# 12 R PY/P out Attrib * *# 13 R PZ/P out Attrib * *# 14 R P out Attrib * *# * *# 15 I PARTICLE TYPE Attrib * *# 16 I (Partial) Cell Number Attrib * *# 17 I TRACKING HISTORY WORD Attrib * *# 18 I TRACK NUMBER Reln * *# ---------------------------------------------------------------- * *# (GEANT units: cms. GeV) * *#********************************************************************** *# * *# FORMAT OF FRPT BANK 2I,(I,7F,2I) Bank Number = 0 * *# ====== == ==== ==== * *# BANK FRPT Forward Planar Response Track-based * *# Contains all hits in Planars for all tracks * *# * *# word# type Content * *# 1 I NCOLS = 10 * *# 2 I NROWS = Number of hits * *# ---------------------------------------------------------------- * *# Col * *# 1 I Cell Number Attrib * *# 2 R Xin Attrib * *# 3 R Yin Attrib * *# 4 R Zin Attrib * *# 5 R Xout Attrib * *# 6 R Yout Attrib * *# 7 R Zout Attrib * *# 8 R Energy Loss (GeV) Attrib * *# 9 I Tracking History word Attrib * *# 10 I TRACK NUMBER Reln * *# ---------------------------------------------------------------- * *# (GEANT units: cms. GeV) * *#********************************************************************** * *KEEP,GCKINE. COMMON/GCKINE/IKINE,PKINE(10),ITRA,ISTAK,IVERT,IPART,ITRTYP + ,NAPART(5),AMASS,CHARGE,TLIFE,VERT(3),PVERT(4),IPAOLD C INTEGER IKINE,ITRA,ISTAK,IVERT,IPART,ITRTYP,NAPART,IPAOLD REAL PKINE,AMASS,CHARGE,TLIFE,VERT,PVERT C *KEEP,GCTRAK. INTEGER NMEC,LMEC,NAMEC,NSTEP ,MAXNST,IGNEXT,INWVOL,ISTOP,MAXMEC + ,IGAUTO,IEKBIN,ILOSL, IMULL,INGOTO,NLDOWN,NLEVIN,NLVSAV,ISTORY REAL VECT,GETOT,GEKIN,VOUT,DESTEP,DESTEL,SAFETY,SLENG ,STEP + ,SNEXT,SFIELD,TOFG ,GEKRAT,UPWGHT PARAMETER (MAXMEC=30) COMMON/GCTRAK/VECT(7),GETOT,GEKIN,VOUT(7),NMEC,LMEC(MAXMEC) + ,NAMEC(MAXMEC),NSTEP ,MAXNST,DESTEP,DESTEL,SAFETY,SLENG + ,STEP ,SNEXT ,SFIELD,TOFG ,GEKRAT,UPWGHT,IGNEXT,INWVOL + ,ISTOP ,IGAUTO,IEKBIN, ILOSL, IMULL,INGOTO,NLDOWN,NLEVIN + ,NLVSAV,ISTORY C *KEEP,GCSETS. COMMON/GCSETS/IHSET,IHDET,ISET,IDET,IDTYPE,NVNAME,NUMBV(20) C INTEGER IHSET,IHDET,ISET,IDET,IDTYPE,NVNAME,NUMBV C *KEEP,H1DETC. PARAMETER (NSUBDE=8) COMMON /H1DETC/ NAMSUB(NSUBDE),ISGRAN(NSUBDE),ISRBNK(NSUBDE), 1 ISDSBK(NSUBDE),ISTRKB(NSUBDE),ISTRKM(NSUBDE), 1 SKECUT(NSUBDE+2) *KEEP,H1OSGO. COMMON /H1OSGO/ LCONFG,IGEAND(13),RGEANC(16),IGEANP(12) *KEEP,OTRHIS. COMMON/OTRHIS/ITRHIS *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/ *KEND. PARAMETER (NCL=18) PARAMETER (NCL2=10) PARAMETER (NBN=0) DIMENSION IKADD(NCL),BKADD(NCL) EQUIVALENCE (IKADD(1),BKADD(1)) LOGICAL FIRST DATA FIRST/.TRUE./ * Branch according to granularity flag... IF(ISGRAN(2) .EQ. 3) THEN * Coarse detector geometry create FRPF banks IF(FIRST)THEN FIRST=.FALSE. CALL BKFMT ('FRPF','2I,(14F,4I)') ENDIF * IF(INWVOL.EQ.1) THEN * Entrance to volume. Store first 7-vector... DO 10 I=1,7 10 BKADD(I) = VECT(I) ELSEIF(INWVOL.EQ.2.OR.ISTOP.GT.0) THEN * Exit volume at boundary or particle stops... DO 11 I=1,7 11 BKADD(I+7) = VECT(I) IKADD(15) = IGEAPD(IPART) IF(LCONFG.LT.10) THEN * use word 16 to keep the (partial) cell number... * Determine Cell number - drift cells are numbered * as follows:- * * cell number determined by supermodule number (1-3) NUMBV(1) * orientation number (1-3) NUMBV(2) * w-coordinate (1-32) NUMBV(3) * ...the cell number will be completed when the z plane number (0 - * is added in the Digitisation step * IKADD(16) = 384 * (NUMBV(1) -1) . + 128 * (NUMBV(2)-1) . + 4 * (NUMBV(3)-1) ELSE * * cell number determined by orientation number (1-3) NUMBV(1) * w-coordinate (1-32) NUMBV(2) * ...the cell number will be completed when the z plane number (0 - * is added in the Digitisation step * IKADD(16) = 128 * (NUMBV(1)-1) . + 4 * (NUMBV(2)-1) ENDIF IKADD(17) = ITRHIS IKADD(18) = ITRA * Track segment now complete. Add row to table... KND=IADROW('FRPF',NBN,NCL,BKADD) IF(IW(KND+2).EQ.1)CALL BLIST(IW,'E+','FRPF') ENDIF ELSEIF(ISGRAN(2) .EQ. 1) THEN * Fine detector geometry - create FRPT banks... IF(FIRST)THEN FIRST=.FALSE. CALL BKFMT ('FRPT','2I,(I,7F,2I)') ENDIF * IF(INWVOL.EQ.1) THEN XIN = VECT(1) YIN = VECT(2) ZIN = VECT(3) ENLOSS = 0.0 * ELSEIF (INWVOL.EQ.2) THEN XOUT = VECT(1) YOUT = VECT(2) ZOUT = VECT(3) * Add last bit of Energy ENLOSS=ENLOSS+DESTEP * Add information to the bank * Determine Cell number - drift cells are numbered * as follows:- * * cell number determined by supermodule number (1-3) NUMBV(1) * orientation number (1-3) NUMBV(2) * w-coordinate (1-32) NUMBV(3) * z-plane (1-4) NUMBV(4) IKADD( 1) = 384 * (NUMBV(1)-1) . + 128 * (NUMBV(2)-1) . + 4 * (NUMBV(3)-1) . + (NUMBV(4)-1) BKADD( 2) = XIN BKADD( 3) = YIN BKADD( 4) = ZIN BKADD( 5) = XOUT BKADD( 6) = YOUT BKADD( 7) = ZOUT BKADD( 8) = ENLOSS IKADD( 9) = ITRHIS IKADD(10) = ITRA * KND=IADROW('FRPT',NBN,NCL2,BKADD) IF(IW(KND+2).EQ.1)CALL BLIST(IW,'E+','FRPT') ENDIF * * ADD UP ENERGY LOSS * ENLOSS=ENLOSS+DESTEP ELSE * Undefined geometry - STOP WRITE(6,*) ' FPHIT - Undefined FTD geometry!!' STOP ENDIF RETURN END *CMZ : 16/04/99 15.43.49 by Girish D. Patel *-- Author : Girish D. Patel 10/11/98 SUBROUTINE FQHIT *#********************************************************************** *# * *# VERSION: 22/07/98 Steve Maxfield * *# * *# PURPOSE: fill NEW PLANAR CHAMBERS response and GEANT HIT banks * *# * *# CALLED BY : GEDEPO * *# * *# INPUT : GEANT track data * *# * *# OUTPUT : FRQF bank OR FRQT bank * *# ==== ==== * *# AUTHOR : Steve Maxfield * *# * *# CHANGED BY: * *# REASON : * *#********************************************************************** *# * *# FORMAT OF FRQF BANK 2I,(14F,4I) Bank Number = 0 * *# ====== == ==== ==== * *# BANK FRQF Forward New Planar Response (Fast-form) * *# CONTAINS ALL TRACKPOINTS OF ALL TRACKS * *# * *# word# type Content * *# 1 I NCOL = 18 * *# 2 I Number of track points * *# ---------------------------------------------------------------- * *# Col * *# 1 R X in Attrib * *# 2 R Y in Attrib * *# 3 R Z in Attrib * *# 4 R PX/P in Attrib * *# 5 R PY/P in Attrib * *# 6 R PZ/P in Attrib * *# 7 R P in Attrib * *# * *# 8 R X out Attrib * *# 9 R Y out Attrib * *# 10 R Z out Attrib * *# 11 R PX/P out Attrib * *# 12 R PY/P out Attrib * *# 13 R PZ/P out Attrib * *# 14 R P out Attrib * *# * *# 15 I PARTICLE TYPE Attrib * *# 16 I (Partial) Cell Number Attrib * *# 17 I TRACKING HISTORY WORD Attrib * *# 18 I TRACK NUMBER Reln * *# ---------------------------------------------------------------- * *# (GEANT units: cms. GeV) * *#********************************************************************** *# * *# FORMAT OF FRQT BANK 2I,(I,7F,2I) Bank Number = 0 * *# ====== == ==== ==== * *# BANK FRQT Forward New Planar Response Track-based * *# Contains all hits in Planars for all tracks * *# * *# word# type Content * *# 1 I NCOLS = 10 * *# 2 I NROWS = Number of hits * *# ---------------------------------------------------------------- * *# Col * *# 1 I Cell Number Attrib * *# 2 R Xin Attrib * *# 3 R Yin Attrib * *# 4 R Zin Attrib * *# 5 R Xout Attrib * *# 6 R Yout Attrib * *# 7 R Zout Attrib * *# 8 R Energy Loss (GeV) Attrib * *# 9 I Tracking History word Attrib * *# 10 I TRACK NUMBER Reln * *# ---------------------------------------------------------------- * *# (GEANT units: cms. GeV) * *#********************************************************************** * *KEEP,GCKINE. COMMON/GCKINE/IKINE,PKINE(10),ITRA,ISTAK,IVERT,IPART,ITRTYP + ,NAPART(5),AMASS,CHARGE,TLIFE,VERT(3),PVERT(4),IPAOLD C INTEGER IKINE,ITRA,ISTAK,IVERT,IPART,ITRTYP,NAPART,IPAOLD REAL PKINE,AMASS,CHARGE,TLIFE,VERT,PVERT C *KEEP,GCTRAK. INTEGER NMEC,LMEC,NAMEC,NSTEP ,MAXNST,IGNEXT,INWVOL,ISTOP,MAXMEC + ,IGAUTO,IEKBIN,ILOSL, IMULL,INGOTO,NLDOWN,NLEVIN,NLVSAV,ISTORY REAL VECT,GETOT,GEKIN,VOUT,DESTEP,DESTEL,SAFETY,SLENG ,STEP + ,SNEXT,SFIELD,TOFG ,GEKRAT,UPWGHT PARAMETER (MAXMEC=30) COMMON/GCTRAK/VECT(7),GETOT,GEKIN,VOUT(7),NMEC,LMEC(MAXMEC) + ,NAMEC(MAXMEC),NSTEP ,MAXNST,DESTEP,DESTEL,SAFETY,SLENG + ,STEP ,SNEXT ,SFIELD,TOFG ,GEKRAT,UPWGHT,IGNEXT,INWVOL + ,ISTOP ,IGAUTO,IEKBIN, ILOSL, IMULL,INGOTO,NLDOWN,NLEVIN + ,NLVSAV,ISTORY C *KEEP,GCSETS. COMMON/GCSETS/IHSET,IHDET,ISET,IDET,IDTYPE,NVNAME,NUMBV(20) C INTEGER IHSET,IHDET,ISET,IDET,IDTYPE,NVNAME,NUMBV C *KEEP,H1DETC. PARAMETER (NSUBDE=8) COMMON /H1DETC/ NAMSUB(NSUBDE),ISGRAN(NSUBDE),ISRBNK(NSUBDE), 1 ISDSBK(NSUBDE),ISTRKB(NSUBDE),ISTRKM(NSUBDE), 1 SKECUT(NSUBDE+2) *KEEP,OTRHIS. COMMON/OTRHIS/ITRHIS *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/ *KEND. PARAMETER (NCL=18) PARAMETER (NCL2=10) PARAMETER (NBN=0) DIMENSION IKADD(NCL),BKADD(NCL) EQUIVALENCE (IKADD(1),BKADD(1)) LOGICAL FIRST DATA FIRST/.TRUE./ * Branch according to granularity flag... IF(ISGRAN(2) .EQ. 3) THEN * Coarse detector geometry create FRPF banks IF(FIRST)THEN FIRST=.FALSE. CALL BKFMT ('FRQF','2I,(14F,4I)') ENDIF * IF(INWVOL.EQ.1) THEN * Entrance to volume. Store first 7-vector... DO 10 I=1,7 10 BKADD(I) = VECT(I) ELSEIF(INWVOL.EQ.2.OR.ISTOP.GT.0) THEN * Exit volume at boundary or particle stops... DO 11 I=1,7 11 BKADD(I+7) = VECT(I) IKADD(15) = IGEAPD(IPART) * use word 17 to keep the (partial) cell number... * Determine Cell number - drift cells are numbered * as follows:- * * cell number determined by supermodule number (1-3) NUMBV(1) * w-coordinate (1-28) NUMBV(2) * ...the cell number will be completed when the z plane number (0 - * is added in the Digitisation step * c write(6,*) 'FQHIT',(numbv(I),I=1,3) IKADD(16) = 224 * (NUMBV(1)-1) . + 8 * (NUMBV(2)-1) IKADD(17) = ITRHIS IKADD(18) = ITRA * Track segment now complete. Add row to table... KND=IADROW('FRQF',NBN,NCL,BKADD) IF(IW(KND+2).EQ.1)CALL BLIST(IW,'E+','FRQF') ENDIF ELSEIF(ISGRAN(2) .EQ. 1) THEN * Fine detector geometry - create FRPT banks... IF(FIRST)THEN FIRST=.FALSE. CALL BKFMT ('FRQT','2I,(I,7F,2I)') ENDIF * IF(INWVOL.EQ.1) THEN XIN = VECT(1) YIN = VECT(2) ZIN = VECT(3) ENLOSS = 0.0 * ELSEIF (INWVOL.EQ.2) THEN XOUT = VECT(1) YOUT = VECT(2) ZOUT = VECT(3) * Add last bit of Energy ENLOSS=ENLOSS+DESTEP * Add information to the bank * Determine Cell number - drift cells are numbered * as follows:- * * cell number determined by supermodule number (1-3) NUMBV(1) * orientation number (1-1) NUMBV(2) * w-coordinate (1-28) NUMBV(3) * z-plane (1-8) NUMBV(4) IKADD( 1) = 224 * (NUMBV(1)-1) . + 8 * (NUMBV(3)-1) . + (NUMBV(4)-1) BKADD( 2) = XIN BKADD( 3) = YIN BKADD( 4) = ZIN BKADD( 5) = XOUT BKADD( 6) = YOUT BKADD( 7) = ZOUT BKADD( 8) = ENLOSS IKADD( 9) = ITRHIS IKADD(10) = ITRA * KND=IADROW('FRQT',NBN,NCL2,BKADD) IF(IW(KND+2).EQ.1)CALL BLIST(IW,'E+','FRQT') ENDIF * * ADD UP ENERGY LOSS * ENLOSS=ENLOSS+DESTEP ELSE * Undefined geometry - STOP WRITE(6,*) ' FQHIT - Undefined FTD geometry!!' STOP ENDIF RETURN END *CMZU: 03/08/98 13.56.29 by Stephen Burke *-- Author : Stephen Burke 03/08/98 SUBROUTINE FDQSME(DRIFT,IFLAG0,IFLAG1,IFLAG2,DSMEA) *#**************************************************************** *# * *# PURPOSE: Compute Smeared drift length (in new planars) * *# * *# INPUT: DRIFT - drift length to wire in cms * *# end of wire in units of total wire length* *# IFLAG - FLAG containing hit "quality" inf* *# * *# OUTPUT: DSMEA Smeared drift time * *# Depends on IFLAG * *# * *#**************************************************************** *# * *# CHANGED BY: AT: * *# * *# REASON : * *# * *#**************************************************************** *KEEP,FQDGPR. COMMON /FQDGPR/ TTSEP1,TTSEP2,MAXINT,ERRD0,ERRD1,ERRD2,ERRD3 &, DELCHG,DQUANT,FADBIN *KEEP,FQDGST. LOGICAL LSMEAR,LNOISE COMMON /FQDGST/ LSMEAR,LNOISE *KEND. *#**************************************************************** IF (.NOT.LSMEAR) THEN DSMEA = DRIFT RETURN ENDIF * Resolution vs. drift distance curve DELTA = SQRT(ERRD0 + DRIFT*ERRD1 + EXP(-ERRD3*DRIFT)*ERRD2) * Scale up the resolution for close previous hits (arbitrary) ISEPL = IFLAG0/256 IF (ISEPL.LT.10 .AND. ISEPL.GT.0) THEN IPEAK = IFLAG0 - 256*ISEPL IPLAST = IFLAG1/256 * Just in case ... IF (IPEAK.EQ.0) IPEAK = 1 FRAC = 10.*IPLAST/FLOAT(ISEPL*IPEAK) IF (FRAC.GT.1.) DELTA = DELTA*FRAC ENDIF * Error can't be bigger than 2-track resolution IF (DELTA.GT.TTSEP1) DELTA = TTSEP1 * Allow -ve fluctuations (across T0 boundary) CALL H1NORR(GAUSS) DSMEA = DRIFT + DELTA*GAUSS RETURN END *CMZU: 03/08/98 13.56.29 by Stephen Burke *-- Author : Stephen Burke 03/08/98 SUBROUTINE FQDIGI *#***************************************************************** *# * *# PURPOSE: Digitisation of hits in New Forward Planars. * *# * *# CALLED BY: H1DIGI * *# * *#***************************************************************** *KEEP,FQDGDB. COMMON /FQDGDB/ IFQDEB(5) *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,BOSMDL. C ------BOSMDL LOGICAL BEGJOB,ENDRUN,BEGRUN,REVENT,ENDJOB,OTHDAT COMMON/BOSMDL/BEGJOB,ENDRUN,BEGRUN,REVENT,ENDJOB,OTHDAT, + LCCRUN,NCCRUN,NEVENT, + IHA,IBS,IDB,IDATEL,LUP,ISN,JSN SAVE /BOSMDL/ C ------ *KEND. LOGICAL IQDEB *#**************************************************************** * Check debug range IQDEB = IFQDEB(1) .EQ. 1 + .AND. NEVENT .LE. IFQDEB(5) + .AND. NEVENT .GE. IFQDEB(4) * Check for existence of FRQF banks. If they exist then * create FRQH bank from them directly INFRQF = NLINK('FRQF',0) IF (IW(INFRQF).GT.0) THEN * Generate noise bank ... (not used yet) * CALL FRQNCR CALL FRQHCC IF (IQDEB) THEN CALL FPFRQF CALL FPFRQH ENDIF ELSE * Create FRPH bank from FRPT banks ... * Generate noise bank ... (not used yet) * CALL FRQNCR CALL FRQHCR IF (IQDEB) THEN CALL FPFRQT CALL FPFRQH ENDIF ENDIF * Now digitise the hits creating FRQE bank CALL FRQECR CALL FRQXCR IF (IQDEB) CALL FPFRQE IF (IQDEB) CALL FPFRQX * Now drop the intermediate HIT bank CALL BDROP(IW,'FRQH') RETURN END *CMZ : 20/01/99 14.09.57 by Girish D. Patel *-- Author : Stephen Burke 03/08/98 SUBROUTINE FQDRF(XP,YP,ZP,ICELL,FDRIFT,IFSGN) *#********************************************************************** *# * *# PURPOSE: COMPUTE DRIFT DISTANCE OF HIT IN NEW PLANARS AT * *# XP, YP, ZP (mean of track entry and exit points for now ) * *# * *# CALLED BY : FRQHCC, FRQHCR * *# * *# INPUT : BOS BANK FGAQ, XP,YP,ZP (cms) * *# * *# OUTPUT : FDRIFT (cms) if in cell ELSE -2000. * *# IFSGN drift sign 0/1 * *# * *# IFSGN changed so that 0 / 1 = positive / negative drift to agree * *# with the convention used in reconstruction. * *# IFSGN is -1 if the track is outside the sensitive volume * *# * *#********************************************************************** *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/ *KEND. DIMENSION IPKMOD(0:671) DIMENSION IPKWCL(0:671) DIMENSION IPKZPL(0:671) DIMENSION PSTART(0:2), STAGGE(0:2) DIMENSION PAOFF(0:27), PALEN(0:27) PARAMETER(TWOPI=6.283185) LOGICAL FIRST DATA FIRST/.TRUE./ *#********************************************************************** * Initialise drift distance to large negative number FDRIFT = -2000. IFSGN = 0 * Unpack FGAQ bank if first call... IF (FIRST) THEN DO 1 JJ=0,671 KMOD = JJ/224 KWCL = (JJ-KMOD*224)/8 KZPL = (JJ-KMOD*224-KWCL*8) IPKMOD(JJ) = KMOD IPKWCL(JJ) = KWCL IPKZPL(JJ) = KZPL 1 CONTINUE * Access FGAQ bank CALL UGTBNK('FGAQ',INFGAQ) IF (INFGAQ.LE.0) THEN WRITE(6,*)' ***FQDRF >> FGAQ BANK NOT FOUND' RETURN ENDIF * Get basic planar parameters ... NMOD = IW(INFGAQ+3) NPLANE = IW(INFGAQ+5) ZSEP = RW(INFGAQ+6) WZER = RW(INFGAQ+7) WSEP = RW(INFGAQ+8) * Half-lengths of wires ... KIND = INFGAQ + 8 DO 6 JL=1,14 PALEN(JL-1) = RW(KIND+JL)/2.0 PALEN(28-JL)= RW(KIND+JL)/2.0 6 CONTINUE * Offsets of wire centres ... KIND = INFGAQ + 22 DO 7 JO=1,6 PAOFF(7+JO) = RW(KIND+JO) PAOFF(13+JO) = - RW(KIND+JO) 7 CONTINUE DO 8 JO=0,7 PAOFF(JO) = 0.0 8 CONTINUE DO 9 JO=20,27 PAOFF(JO) = 0.0 9 CONTINUE KIND = INFGAQ + IW(INFGAQ+1) + 1 DO 2 KMOD=0,NMOD-1 PSTART(KMOD) = RW(KIND+4) STAGGE(KMOD) = RW(KIND+5) KIND = KIND + IW(KIND+1) + 1 2 CONTINUE CALL UGTRUN('FDQR',INFDQR) IF (INFDQR.LE.0) THEN WRITE(6,*)' ***FQDRF >> FDQR BANK NOT FOUND' RETURN ENDIF * Get TAN of Lorenz angle TLOREN = TAN(RW(INFDQR+23)*TWOPI/360.) FIRST = .FALSE. ENDIF * End unpacking * Unpack the module number and the celnum in W KPMOD = IPKMOD(ICELL) KWCL = IPKWCL(ICELL) KZPL = IPKZPL(ICELL) * Determine the W-coordinate of the wire in this cell IF (KWCL.LE.13) THEN WWIRE = WZER + KWCL *WSEP + STAGGE(KPMOD)*( (-1)**KZPL ) ELSE WWIRE = WZER + (KWCL-6)*WSEP + STAGGE(KPMOD)*( (-1)**KZPL ) ENDIF * Rotate x,y coordinates of hit into W,V frame: * W is the drift coordinate and V the coordinate along the wires. WHIT = XP*COS(PSTART(KPMOD)) + YP*SIN(PSTART(KPMOD)) VTRUE = -XP*SIN(PSTART(KPMOD)) + YP*COS(PSTART(KPMOD)) FDRIFT = WHIT - WWIRE VCORR = VTRUE - FDRIFT*TLOREN IF (FDRIFT.LT.0) IFSGN = 1 * V at 'top' and 'bottom' of cell PVMIN = PAOFF(KWCL) - PALEN(KWCL) PVMAX = PAOFF(KWCL) + PALEN(KWCL) * Check original V (for interpolated hits in coarse granularity, * the track can leave and re-enter the drift volume!!) IF (VTRUE.LT.PVMIN .OR. VTRUE.GT.PVMAX) IFSGN = -1 * Check if electrons reach wire IF (VCORR.LT.PVMIN .OR. VCORR.GT.PVMAX) IFSGN = -1 FDRIFT = ABS(FDRIFT) RETURN END *CMZ : 20/01/99 14.46.40 by Girish D. Patel *-- Author : Stephen Burke 03/08/98 SUBROUTINE FQIDIG ******************************************************************* *# * *# PURPOSE: Initialise COMMONS for Forward Planar digitisation * *# * *#***************************************************************** *# * *# CHANGED BY: AT: * *# * *# REASON : * *# * *#***************************************************************** *KEEP,FQDGPR. COMMON /FQDGPR/ TTSEP1,TTSEP2,MAXINT,ERRD0,ERRD1,ERRD2,ERRD3 &, DELCHG,DQUANT,FADBIN *KEEP,FQDGST. LOGICAL LSMEAR,LNOISE COMMON /FQDGST/ LSMEAR,LNOISE *KEEP,FQDGDB. COMMON /FQDGDB/ IFQDEB(5) *KEEP,FQDGDG. COMMON /FQDGDG/ IDRFAC,QFAC,IQSAT *KEEP,FQDGEF. COMMON /FQDGEF/ EFFQ(0:7,0:2),EFFQ8(0:2),PHMC(6),PWMC1(5) &, PWMC2(5),PWMC3(5),PWMC4(5),PWMC5(5) *KEEP,FQMAXN. * Maximum number of noise hits for new planars PARAMETER (MXNHTQ=5) *KEEP,FQTRNP. * Forward new planar track-related noise + shifted data parameters PARAMETER (MAXSGQ=5) LOGICAL LFDQX COMMON /FQTRNP/ QTRNP1(MXNHTQ),QTRNP2(MXNHTQ),QTRNDD(2,MAXSGQ) &, QPNEGD,LFDQX,SIGSHF,SGNSHF,SIGNOI,SGNNOI &, ANGNOI,PRBNOI,OFFNOI *KEND. *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/ *KEND. DIMENSION P1(MXNHTQ),P2(MXNHTQ),D(MAXSGQ-1),PD(MAXSGQ-2) *------------------------------------------------------------------ * * Initialisation - access parameter banks * CALL UGTRUN('FDQR',INFDQR) IF (INFDQR.LE.0) THEN WRITE(6,*) ' ***FQIDIG >> FDQR BANK NOT FOUND' CALL H1STOP ENDIF IF (IW(INFDQR+3).LT.980801) THEN WRITE(6,*) ' ***FQIDIG >> WRONG VERSION OF FDQR BANK' CALL H1STOP ENDIF LSMEAR = (IW(INFDQR + 4).NE.0) LNOISE = (IW(INFDQR + 5).NE.0) IFQDEB(1) = IW(INFDQR + 6) IFQDEB(2) = IW(INFDQR + 7) IFQDEB(3) = IW(INFDQR + 8) IFQDEB(4) = IW(INFDQR + 9) IFQDEB(5) = IW(INFDQR + 10) QFAC = RW(INFDQR + 11) IQSAT = IW(INFDQR + 12) DRFVEL = RW(INFDQR + 13) TTSEP1 = RW(INFDQR + 14) TTSEP2 = RW(INFDQR + 15) MAXINT = IW(INFDQR + 16) ERRD0 = RW(INFDQR + 17) ERRD1 = RW(INFDQR + 18) ERRD2 = RW(INFDQR + 19) ERRD3 = RW(INFDQR + 20) DELCHG = RW(INFDQR + 21) DQUANT = RW(INFDQR + 22) EFFQ(0,0) = RW(INFDQR + 24) EFFQ(1,0) = RW(INFDQR + 25) EFFQ(2,0) = RW(INFDQR + 26) EFFQ(3,0) = RW(INFDQR + 27) EFFQ(4,0) = RW(INFDQR + 28) EFFQ(5,0) = RW(INFDQR + 29) EFFQ(6,0) = RW(INFDQR + 30) EFFQ(7,0) = RW(INFDQR + 31) EFFQ8(0) = RW(INFDQR + 32) EFFQ8(1) = RW(INFDQR + 33) EFFQ8(2) = RW(INFDQR + 34) P1(1) = RW(INFDQR + 35) P1(2) = RW(INFDQR + 36) P1(3) = RW(INFDQR + 37) P1(4) = RW(INFDQR + 38) P1(5) = RW(INFDQR + 39) P2(1) = RW(INFDQR + 40) P2(2) = RW(INFDQR + 41) P2(3) = RW(INFDQR + 42) P2(4) = RW(INFDQR + 43) P2(5) = RW(INFDQR + 44) D(1) = RW(INFDQR + 45) D(2) = RW(INFDQR + 46) D(3) = RW(INFDQR + 47) D(4) = RW(INFDQR + 48) PD(1) = RW(INFDQR + 49) PD(2) = RW(INFDQR + 50) PD(3) = RW(INFDQR + 51) QPNEGD = RW(INFDQR + 52) * 1/(Size of an FADC bin in cm) FADBIN = 1.0/(0.00096*DRFVEL) * Re-scale resolution parameters ERRD0 = ERRD0*ERRD0 ERRD1 = ERRD1*ERRD1 ERRD2 = ERRD2*ERRD2 ERRD3 = 2./ERRD3 * Cumulate the track-related noise probabilities PCUM1 = 0. PCUM2 = 0. DO 100 J=1,MXNHTQ PCUM1 = PCUM1 + P1(J) PCUM2 = PCUM2 + P2(J) QTRNP1(J) = PCUM1 QTRNP2(J) = PCUM2 100 CONTINUE * Cumulate the track-related noise drift distribution QTRNDD(1,1) = 0. QTRNDD(2,1) = 0. DO 200 JSEG=2,MAXSGQ-1 QTRNDD(1,JSEG) = QTRNDD(1,JSEG-1) + PD(JSEG-1) QTRNDD(2,JSEG) = D(JSEG-1) 200 CONTINUE QTRNDD(1,MAXSGQ) = 1. QTRNDD(2,MAXSGQ) = D(MAXSGQ-1) CALL UGTRUN('FDQH',INFDQH) IF (INFDQH.LE.0) THEN WRITE(6,*) ' ***FQIDIG >> FDQH BANK NOT FOUND' CALL H1STOP ENDIF IF (IW(INFDQH+3).LT.980801) THEN WRITE(6,*) ' ***FQIDIG >> WRONG VERSION OF FDQH BANK' CALL H1STOP ENDIF PHMC(1) = RW(INFDQH + 4) PHMC(2) = RW(INFDQH + 5) PHMC(3) = RW(INFDQH + 6) PHMC(4) = RW(INFDQH + 7) PHMC(5) = RW(INFDQH + 8) PHMC(6) = RW(INFDQH + 9) PWMC1(1) = RW(INFDQH + 10) PWMC1(2) = RW(INFDQH + 11) PWMC1(3) = RW(INFDQH + 12) PWMC1(4) = RW(INFDQH + 13) PWMC1(5) = RW(INFDQH + 14) PWMC2(1) = RW(INFDQH + 15) PWMC2(2) = RW(INFDQH + 16) PWMC2(3) = RW(INFDQH + 17) PWMC2(4) = RW(INFDQH + 18) PWMC2(5) = RW(INFDQH + 19) PWMC3(1) = RW(INFDQH + 20) PWMC3(2) = RW(INFDQH + 21) PWMC3(3) = RW(INFDQH + 22) PWMC3(4) = RW(INFDQH + 23) PWMC3(5) = RW(INFDQH + 24) PWMC4(1) = RW(INFDQH + 25) PWMC4(2) = RW(INFDQH + 26) PWMC4(3) = RW(INFDQH + 27) PWMC4(4) = RW(INFDQH + 28) PWMC4(5) = RW(INFDQH + 29) PWMC5(1) = RW(INFDQH + 30) PWMC5(2) = RW(INFDQH + 31) PWMC5(3) = RW(INFDQH + 32) PWMC5(4) = RW(INFDQH + 33) PWMC5(5) = RW(INFDQH + 34) CALL UGTRUN('FDEF',INFDEF) IF (INFDEF.LE.0) THEN WRITE(6,*) ' ***FQIDIG >> FDEF BANK NOT FOUND' CALL H1STOP ENDIF IF (IW(INFDEF+3).LT.980801) THEN WRITE(6,*) ' ***FQIDIG >> WRONG VERSION OF FDEF BANK' CALL H1STOP ENDIF RDFAC0 = RW(INFDEF + 10) RDFAC1 = RW(INFDEF + 11) RDFAC2 = RW(INFDEF + 12) * Apply run-dependent efficiency factors DO 500 JWIRE=0,5 EFFQ(JWIRE,2) = EFFQ(JWIRE,0)*RDFAC2 EFFQ(JWIRE,1) = EFFQ(JWIRE,0)*RDFAC1 EFFQ(JWIRE,0) = EFFQ(JWIRE,0)*RDFAC0 500 CONTINUE LFDQX = .FALSE. SIGSHF = 0. SGNSHF = 0. SIGNOI = 0. SGNNOI = 0. ANGNOI = 0. PRBNOI = 0. OFFNOI = 0. * Look for FDQX bank - shifted data parameters, may not be present CALL UGTRUN('FDQX',INFDQX) IF (INFDQX.LE.0) RETURN IF (IW(INFDQX+3).LT.980801) THEN WRITE(6,*) ' ***FQIDIG >> WRONG VERSION OF FDQX BANK' CALL H1STOP ENDIF LFDQX = .TRUE. SIGSHF = RW(INFDQX+4) SGNSHF = RW(INFDQX+5) SIGNOI = RW(INFDQX+6) SGNNOI = RW(INFDQX+7) ANGNOI = RW(INFDQX+8) PRBNOI = RW(INFDQX+9) OFFNOI = RW(INFDQX+10) RETURN END *CMZU: 03/08/98 13.56.29 by Stephen Burke *-- Author : Stephen Burke 03/08/98 SUBROUTINE FQQSME(QPLUS,IFLAG0,IFLAG1,IFLAG2,QPSME) *#**************************************************************** *# * *# PURPOSE: Compute Smeared Charge (Energy) * *# * *# INPUT: QPLUS - deposited charge (actually Energy in eV) * *# IFLAG - FLAG containing hit "quality" inf* *# * *# OUTPUT: QPSME Smeared charge * *# Depends on IFLAG * *# * *#**************************************************************** *# * *# CHANGED BY: AT: * *# * *# REASON : * *# * *# * *#**************************************************************** *KEEP,FQDGPR. COMMON /FQDGPR/ TTSEP1,TTSEP2,MAXINT,ERRD0,ERRD1,ERRD2,ERRD3 &, DELCHG,DQUANT,FADBIN *KEEP,FQDGDG. COMMON /FQDGDG/ IDRFAC,QFAC,IQSAT *KEEP,FQDGST. LOGICAL LSMEAR,LNOISE COMMON /FQDGST/ LSMEAR,LNOISE *KEND. *#**************************************************************** QPSME = QPLUS*QFAC * NB There is no adjustment for a preceding pulse IF (LSMEAR) THEN CALL H1NORR(GAUSS1) CALL H1NORR(GAUSS2) QPSME = QPLUS*(1.0 + DELCHG*GAUSS1)*QFAC + DQUANT*GAUSS2 ENDIF IF (QPSME.LT.0.) QPSME = 0. RETURN END *CMZU: 03/08/98 13.56.29 by Stephen Burke *-- Author : Stephen Burke 03/08/98 SUBROUTINE FRQECR *#********************************************************************** *# * *# VERSION: 29/07/98 Steve Burke * *# * *# PURPOSE: Create EVENT response bank FRQE * *# * *# 1) Sort hits from FRQH bank by cell number(wire) * *# 2) Sort hits on one wire by drift distance * *# 3) Simulate QT * *# * *# CALLED BY : FQDIGI * *# * *# CALLS : FQQTSM * *# * *# INPUT : BOS BANK FRQH * *# * *# OUTPUT : FRQE bank * *# * *#********************************************************************** *# * *# AUTHOR : S. BURKE * *# * *# CHANGED BY: AT: * *# REASON : * *# * *#********************************************************************** *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/ *KEND. * Common for work bank index COMMON /CFSORT/ ISORT * Temp common for pointer arrays (extended for FRQX 29/7/98) PARAMETER (MAXHIT=3000) COMMON /H1WORK/ IFRRX(3,MAXHIT),IFRPX(3,MAXHIT),NFRRX,NFRPX &, IFRQX(3,MAXHIT),NFRQX *#********************************************************************** * Zero pointer table CALL VZERO(IFRQX,MAXHIT*3) NFRQX = 0 * Locate FRQH Bank INFRQH = NLINK('FRQH',0) IF (INFRQH.LE.0) THEN C WRITE(6,*) 'FRQH BANK NOT FOUND' RETURN ENDIF * Number of Hits INUM = IW(INFRQH+2) IF (INUM.LE.0) GOTO 100 * Truncate and warn if INUM exceeds MAXHIT IF (INUM.GT.MAXHIT) THEN CALL ERRLOG(205,'W:FRQECR: More than 3000 hits - rest ignored') INUM = MAXHIT ENDIF NFRQX = INUM * Format event response bank CALL BKFMT('FRQE','B16') * Create work bank for indices of channel numbers ISORT = 0 CALL WBANK(IW,ISORT,INUM,*100) * Length of data block ... IB = IW(INFRQH+1) * Position one data block length before first block ... IA = INFRQH + 3 - IB * Loop to insert indices of cell numbers DO 30 I=1,INUM IW(ISORT+I) = IA + I*IB 30 CONTINUE * Sort by cell number ... * RW(IW(ISORT+J)) is now the cell number and, in general, * RW(IW(ISORT+J) + IATTRIB - 1) is now IATTRIB'th attribute of * row JROW = (IW(ISORT+J) - INSTR)/IW(INFRQH+3) + 1 * in the FRQH bank. CALL SORTIL(IW,IW(ISORT+1),INUM) *============================================================== * Initialise digi counter KDIGI = 0 * Loop on all wires I = 0 40 IF (I.EQ.INUM) GOTO 90 * Next wire number I = I + 1 IJ = I 50 CONTINUE IF (IJ.LT.INUM) THEN IF (IW(IW(ISORT+IJ+1)).EQ.IW(IW(ISORT+I))) THEN IJ = IJ + 1 GOTO 50 ENDIF ENDIF * I ... IJ are for same wire IBASE = I - 1 N = IJ - IBASE * Inline sort within one wire * Sort is based on drift distance * Drift distance is 2 words on from celnum in FRQH data blocks ISRT = ISORT + IBASE M = N 51 CONTINUE M = M/2 IF (M.GT.0) THEN DO 53 J=1,N-M L = J * Compare elements with indices 'L' and 'L+M' 52 CONTINUE IF (RW(IW(ISRT+L+M)+2).LT.RW(IW(ISRT+L)+2)) THEN * exchange the two index values LL = IW(ISRT+L+M) IW(ISRT+L+M) = IW(ISRT+L) IW(ISRT+L ) = LL L = L - M IF (L.GT.0) GOTO 52 ENDIF 53 CONTINUE GOTO 51 ENDIF * * Hits on this wire are J=I,IJ, now sorted in order of increasing * drift distance. Now simulate the QT and extend the FRQE bank * CALL FQQTSM(INFRQH,KDIGI,I,IJ) * Make transition to next wire I = IJ GOTO 40 *============================================================== * Finished 90 CONTINUE * Close bank IFRQE = IADFIN('FRQE',0) CALL BLIST(IW,'E+','FRQE') 100 CONTINUE * Drop work bank CALL WDROP(IW,ISORT) RETURN END *CMZ : 20/01/99 14.59.43 by Girish D. Patel *-- Author : Stephen Burke 03/08/98 SUBROUTINE FRQHCC *#********************************************************************** *# * *# VERSION: 30/07/98 Steve Burke * *# * *# PURPOSE: Create FRQH hit bank from FRQF bank * *# * *# CALLED BY : FQDIGI * *# * *# CALLS : FRQHEX * *# * *# INPUT : FRQF banks * *# * *# OUTPUT : FRQH bank * *# ==== * *# AUTHOR : Steve Burke * *# * *#********************************************************************** *# * *# FORMAT OF FRQH BANK 2I,(I,2F,4I) Bank Number = 0 * *# ====== == ==== ==== * *# BANK FRQH Forward Response new planar (Q) Hit bank * *# Contains all hits in chambers * *# IND+1 = NCOLS = 7 * *# IND+2 = NROWS * *# ---------------------------------------------------------------- * *# Col * *# 1 I = CELNUM Attrib * *# 2 R = EDEP Attrib * *# 3 R = DRIFT DISTANCE Attrib * *# 4 I = HITTYP Attrib * *# 5 I = Drift 'sign' 0/1 Attrib * *# 6 I = Trk History word Attrib * *# 7 I = Trk Number Reln * *# ---------------------------------------------------------------- * *# HITTYP = 1 for track; 2 for noise * *# (GEANT units: cms GeV) * *# * *#********************************************************************** *# * *# CHANGED BY: AT: * *# * *# REASON : * *# * *#********************************************************************** *KEEP,FQDGEF. COMMON /FQDGEF/ EFFQ(0:7,0:2),EFFQ8(0:2),PHMC(6),PWMC1(5) &, PWMC2(5),PWMC3(5),PWMC4(5),PWMC5(5) *KEEP,FQDGST. LOGICAL LSMEAR,LNOISE COMMON /FQDGST/ LSMEAR,LNOISE *KEEP,FQMAXN. * Maximum number of noise hits for new planars PARAMETER (MXNHTQ=5) *KEEP,FQTRNP. * Forward new planar track-related noise + shifted data parameters PARAMETER (MAXSGQ=5) LOGICAL LFDQX COMMON /FQTRNP/ QTRNP1(MXNHTQ),QTRNP2(MXNHTQ),QTRNDD(2,MAXSGQ) &, QPNEGD,LFDQX,SIGSHF,SGNSHF,SIGNOI,SGNNOI &, ANGNOI,PRBNOI,OFFNOI *KEND. *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/ *KEND. PARAMETER (IHTTRK=1) PARAMETER (IHTNOI=2) PARAMETER (NCL =7) PARAMETER (NBN =0) DIMENSION IKADD(NCL),BKADD(NCL) EQUIVALENCE (IKADD(1),BKADD(1)) * Cut in Deltap/p between entrance and exit. Ignore hits produced * by stopping and spiralling tracks... PARAMETER (DPRCUT=0.5) * Precision with which cell boundary (in z) is required. This * should be >= the parameter EPSIL for the tracking medium as * in the FGME bank... PARAMETER (SMALL=0.0101) * Minimum energy deposit (50MeV) for a hit (avoids hits with zero * energy loss and hence un-reconstructible radii) PARAMETER(FELMIN= 5.0E-8) DIMENSION ZPLA(24) DIMENSION KQMOD(24) PARAMETER (NWMAX=8) DIMENSION DRIFT(NWMAX),IDSIGN(NWMAX) LOGICAL LMASK LOGICAL LMHIT LOGICAL FIRST LOGICAL DONE DATA FIRST/.TRUE./ *#********************************************************************** * Initialise geometry on first call... IF (FIRST) THEN CALL BKFMT('FRQH','2I,(I,2F,4I)') * Access FGAQ bank CALL UGTBNK('FGAQ',INFGAQ) IF (INFGAQ.LE.0) THEN WRITE(6,*) ' FRQHCC Error - FGAQ Bank not found' RETURN ENDIF * Get basic planar parameters NMODQ = IW(INFGAQ+3) WSEPQ = RW(INFGAQ+6) KIND = INFGAQ + IW(INFGAQ+1) + 1 * N.B. ZPLA(K) gives location of the cell boundary in z * FURTHEST from the interaction point !!! DO 1 KMOD=0,NMODQ-1 ZST = RW(KIND+3) DO 2 KZP=1,8 KK = KZP + KMOD*8 ZPLA (KK) = ZST + KZP*WSEPQ KQMOD(KK) = KMOD 2 CONTINUE KIND = KIND + IW(KIND+1) + 1 1 CONTINUE FIRST = .FALSE. ENDIF *----------------------------------------------------------------------- * Access FRQF bank INFRQF = NLINK('FRQF',0) IF (INFRQF.EQ.0) RETURN * If bank exists access relevant information ... IBLEN = IW(INFRQF+1) IBLKS = IW(INFRQF+2) DO 11 J=1,IBLKS * Pointers to entrance and exit data blocks ... IPT0 = INFRQF + 2 + (J-1)*IBLEN IPT1 = IPT0 + 7 * and to subsidiary data ... IPTD = IPT0 + 14 * Check momentum loss. Stopping tracks, spiraling tracks etc. * cause problems. We can't be bothered with this so skip if * Deltap/p > 50%. RDRP = ABS(RW(IPT0+7) - RW(IPT1+7))/RW(IPT0+7) IF (RDRP.GT.DPRCUT) GOTO 11 * Allow for coherent loss of 8-wire groups ICLNUM = IW(IPTD+2) IF (H1RN(J-1).GT.EFFQ8(ICLNUM/224)) THEN CALL FQHMC(MASK) IF (MASK.EQ.0) GOTO 11 LMASK = .TRUE. ELSE LMASK = .FALSE. ENDIF IF (LFDQX) THEN * Allow for correlated shifts SHIFT = -SIGSHF*LOG(1. - MIN(H1RN(J-17),0.999999)) IF (H1RN(J-18).GT.SGNSHF) SHIFT = -SHIFT ELSE SHIFT = 0. ENDIF * Trouble if track is going backwards? Reverse pointers * if Z1 less than Z0 IF (RW(IPT1+3).LT.RW(IPT0+3)) THEN IPDM = IPT0 IPT0 = IPT1 IPT1 = IPDM ENDIF X0 = RW(IPT0+1) Y0 = RW(IPT0+2) Z0 = RW(IPT0+3) VX0 = RW(IPT0+4) VY0 = RW(IPT0+5) VZ0 = RW(IPT0+6) X1 = RW(IPT1+1) Y1 = RW(IPT1+2) Z1 = RW(IPT1+3) VX1 = RW(IPT1+4) VY1 = RW(IPT1+5) VZ1 = RW(IPT1+6) P0 = RW(IPT0+7) * Ignore vertical tracks IF (VZ0.EQ.0.) GOTO 11 * Particle type, History word, Cell number and track number ... * S.E. PDG code translated to Geant code IR0 = IPDGEA(IW(IPTD+1)) ITRHIS = IW(IPTD+3) ITRK = IW(IPTD+4) VT0 = SQRT(1.0 - VZ0*VZ0) IF (VT0.EQ.0. .OR. (X1.EQ.X0 .AND. Y1.EQ.Y0)) THEN VXT0 = 0. VYT0 = 0. CU = 0. ELSE VXT0 = VX0/VT0 VYT0 = VY0/VT0 * Compute curvature of track ... CU = -2.0*(VYT0*(X1 - X0) - VXT0*(Y1 - Y0))/ + ((X1 - X0)**2 + (Y1 - Y0)**2) ENDIF * P0 needs to be signed by the charge, which (I think) is opposite to * the sign of the curvature *for forward-going tracks* P0 = SIGN(P0,-CU) AFAC = CU*VT0/(2.0*VZ0) * Propagate the track from X0,Y0,Z0 in Steps of z. * The z-step is one cell depth in z, allowing however for * the possibility that the 1st and last point are interior * to a z-cell. * Locate the first z-cell boundary to propagate to ... KZBEG = 24 DO 20 KZ=1,24 DIST = ZPLA(KZ) - Z0 IF (DIST.GT.SMALL) THEN KZBEG = KZ GO TO 21 ENDIF 20 CONTINUE 21 CONTINUE * First plane to go to is at ZPLA(KZBEG) KZP = KZBEG - 1 ZIN = Z0 XIN = X0 YIN = Y0 NWIRE = 0 * Loop over intermediate drift cells ... 100 CONTINUE KZP = MIN(KZP+1,24) ZOUT = ZPLA(KZP) * Last point? IF (ZOUT.GT.Z1 .OR. ABS(ZOUT-Z1).LT.SMALL + .OR. KZP.EQ.24) THEN ZOUT = Z1 DONE = .TRUE. ELSE DONE = .FALSE. ENDIF * Propagate track along helix to exit point of drift cell DIST = ZOUT - Z0 SPSI = SIN(AFAC*DIST) CPSI = COS(AFAC*DIST) * modified by S.E. at 30.3.90 to avoid division by zero IF (CU.EQ.0.)THEN BFAC = VT0*DIST/VZ0 ELSE BFAC = 2.0*SPSI/CU ENDIF XOUT = X0 + BFAC*(VXT0*CPSI - VYT0*SPSI) YOUT = Y0 + BFAC*(VYT0*CPSI + VXT0*SPSI) * Complete CELL number ... ICELNM = ICLNUM + MOD(KZP-1,8) * Compute drift distance ZP = ZPLA(KZP) - 0.5*WSEPQ XP = XIN + (XOUT - XIN)*(ZP - ZIN)/(ZOUT - ZIN) YP = YIN + (YOUT - YIN)*(ZP - ZIN)/(ZOUT - ZIN) CALL FQDRF(XP,YP,ZP,ICELNM,DRIF,IFSGN) DRIF = DRIF + SHIFT IF (IFSGN.GE.0) THEN * Collect drift and sign for each wire IF (NWIRE.LT.NWMAX) THEN NWIRE = NWIRE + 1 IF (NWIRE.EQ.1) ICELL = ICELNM DRIFT(NWIRE) = DRIF IDSIGN(NWIRE) = IFSGN ENDIF * Compute energy loss ... CALL FDEDXL(XIN,YIN,ZIN,XOUT,YOUT,ZOUT,P0,IR0,FELOSS) * Only make hit if sufficient energy loss in drift cell, * and allow for inefficiency IF (FELOSS.GT.FELMIN) THEN IWR = MOD(ICELNM,8) IF (LMASK) THEN LMHIT = JBIT(MASK,IWR+1).EQ.1 ELSE LMHIT = H1RN(J).LE.EFFQ(IWR,ICELNM/224) ENDIF IF (LMHIT) THEN * Add hit to bank ... IKADD(1) = ICELNM BKADD(2) = FELOSS BKADD(3) = DRIF IKADD(4) = IHTTRK IKADD(5) = IFSGN IKADD(6) = ITRHIS IKADD(7) = ITRK KND = IADROW('FRQH',NBN,NCL,BKADD) ENDIF ENDIF ELSEIF (NWIRE.GT.0) THEN * Track went outside cell, so add noise for the wires so far IF (LNOISE) CALL FRQHEX(ICELL,NWIRE,DRIFT,IDSIGN,ITRK) NWIRE = 0 ENDIF * Done with this step - go on to next IF (DONE) THEN * Add track-related noise IF (NWIRE.GT.0 .AND. LNOISE) & CALL FRQHEX(ICELL,NWIRE,DRIFT,IDSIGN,ITRK) GOTO 200 ENDIF XIN = XOUT YIN = YOUT ZIN = ZOUT GOTO 100 200 CONTINUE 11 CONTINUE * Now access NOISE hit banks and fill hits ... * No noise is generated at the moment. We may well generate * different categories of noise kept in FRQN's with different * bank numbers. IFRQN = NAMIND('FRQN') INFRQN = IFRQN + 1 40 CONTINUE INFRQN = IW(INFRQN-1) * If bank exists access relevant information ... IF (INFRQN.NE.0 .AND. LNOISE) THEN * Number of hits in bank INUM = IW(INFRQN+2) * Track number zero for noise? ITRK = 0 * History word zero for noise? ITRHIS = 0 * Loop through hits in this bank INDST = INFRQN + 2 DO 41 JJHIT=1,INUM * Information from noise response bank ... * N.B. Noise bank must contain full CELNUM ICLNUM = IW(INDST + 1) XD = RW(INDST + 2) YD = RW(INDST + 3) ZD = RW(INDST + 4) EDEP = RW(INDST + 5) * Only make hit if sufficient energy loss in drift cell ... IF (EDEP.GT.FELMIN) THEN * Compute drift distance CALL FQDRF(XD,YD,ZD,ICLNUM,DRIF,IFSGN) IF (IFSGN.GE.0) THEN * Extend FRQH bank ... IKADD(1) = ICLNUM BKADD(2) = EDEP BKADD(3) = DRIF IKADD(4) = IHTNOI IKADD(5) = IFSGN IKADD(6) = ITRHIS IKADD(7) = ITRK KND = IADROW('FRQH',NBN,NCL,BKADD) ENDIF ENDIF INDST = INDST + IW(INFRQN+1) 41 CONTINUE * End loop through hits this bank - go to next bank GOTO 40 ENDIF * Close bank KND = IADFIN('FRQH',NBN) RETURN END *CMZ : 20/01/99 15.03.05 by Girish D. Patel *-- Author : Stephen Burke 03/08/98 SUBROUTINE FRQHCR *#********************************************************************** *# * *# VERSION: 30/07/98 Steve Burke * *# * *# Create hit bank FRQH,0 from fine granularity input * *# * *# CALLED BY: FQDIGI * *# * *# INPUTS: * *# FRQT banks * *# FRQN banks (noise) * *# OUTPUT: * *# One bank FRQH,0 containing Hits from above banks * *# * *# CALLS TO: FQDRF * *# * *# NB: There is also an FRQT bank in the database (with radial QT * *# parameters), so beware of clashes! Fine granularity * *# simulation should not be used for standard MC production. * *# * *#********************************************************************** *# * *# FORMAT OF FRQH BANK 2I,(I,2F,4I) Bank Number = 0 * *# ====== == ==== ==== * *# BANK FRQH Forward Response new planar (Q) Hit bank * *# Contains all hits in chambers * *# IND+1 = NCOLS = 7 * *# IND+2 = NROWS * *# ---------------------------------------------------------------- * *# Col * *# 1 I = CELNUM Attrib * *# 2 R = EDEP Attrib * *# 3 R = DRIFT DISTANCE Attrib * *# 4 I = HITTYP Attrib * *# 5 I = Drift 'sign' 0/1 Attrib * *# 6 I = Trk History word Attrib * *# 7 I = Trk Number Reln * *# ---------------------------------------------------------------- * *# HITTYP = 1 for track; 2 for noise * *# (GEANT units: cms GeV) * *# * *#********************************************************************** *# * *# CHANGED BY: AT: * *# * *# REASON : * *# * *#********************************************************************** *KEEP,FQDGEF. COMMON /FQDGEF/ EFFQ(0:7,0:2),EFFQ8(0:2),PHMC(6),PWMC1(5) &, PWMC2(5),PWMC3(5),PWMC4(5),PWMC5(5) *KEEP,FQDGST. LOGICAL LSMEAR,LNOISE COMMON /FQDGST/ LSMEAR,LNOISE *KEND. *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/ *KEND. PARAMETER (IHTTRK=1) PARAMETER (IHTNOI=2) PARAMETER (NCL =7) PARAMETER (NBN =0) * Minimum energy deposit (50eV) for a hit (avoids hits with zero * energy loss and hence un-reconstructible radii) PARAMETER (FELMIN=5.0E-8) DIMENSION IKADD(NCL),BKADD(NCL) EQUIVALENCE (IKADD(1),BKADD(1)) *#********************************************************************** * Locate FRQT bank ... INFRQT = NLINK('FRQT',NBN) * Locate FRQN bank ... (noise in new planars) INFRQN = IW(NAMIND('FRQN')) * Check to see if any information ... IF (INFRQT.LE.0 .AND. INFRQN.LE.0) RETURN * Hits Exist ... CALL BKFMT ('FRQH','2I,(I,2F,4I)') * Now create banks * First search through FRQT bank ... IF (INFRQT.GT.0) THEN * Number of hits in bank INUM = IW(INFRQT+2) * Loop through hits in this bank INDST = INFRQT + 2 DO 11 JJHIT=1,INUM * Information from track response bank ... ICLNUM = IW(INDST + 1) EDEP = RW(INDST + 8) * Only make hit if above minimum energy deposition, and allow * for inefficiency IF (EDEP.GT.FELMIN .AND. & H1RN(JJHIT).LE.EFFQ(MOD(ICLNUM,8),ICLNUM/224)) THEN XIN = RW(INDST + 2) YIN = RW(INDST + 3) ZIN = RW(INDST + 4) XOUT = RW(INDST + 5) YOUT = RW(INDST + 6) ZOUT = RW(INDST + 7) ITRHIS = IW(INDST + 9) ITRK = IW(INDST + 10) * Compute drift distance XP = 0.5*(XIN + XOUT) YP = 0.5*(YIN + YOUT) ZP = 0.5*(ZIN + ZOUT) CALL FQDRF(XP,YP,ZP,ICLNUM,DRIF,IFSGN) IF (IFSGN.GE.0) THEN * Add hit to bank ... IKADD(1) = ICLNUM BKADD(2) = EDEP BKADD(3) = DRIF IKADD(4) = IHTTRK IKADD(5) = IFSGN IKADD(6) = ITRHIS IKADD(7) = ITRK KND = IADROW('FRQH',NBN,NCL,BKADD) ENDIF ENDIF INDST = INDST + IW(INFRQT+1) 11 CONTINUE ENDIF IFRQN = NAMIND('FRQN') INFRQN = IFRQN + 1 40 CONTINUE INFRQN = IW(INFRQN-1) * If bank exists access relevant information ... IF (INFRQN.GT.0 .AND. LNOISE) THEN * Number of hits in bank INUM = IW(INFRQN+2) * Track number zero for noise? ITRK = 0 * History word zero for noise? ITRHIS = 0 * Loop through hits in this bank INDST = INFRQT + 2 DO 41 JJHIT=1,INUM * Information from noise response bank ... * N.B. Noise bank must contain full CELNUM ICLNUM = IW(INDST + 1) XD = RW(INDST + 2) YD = RW(INDST + 3) ZD = RW(INDST + 4) EDEP = RW(INDST + 5) IF (EDEP.GT.FELMIN) THEN * Compute drift distance CALL FQDRF(XD,YD,ZD,ICLNUM,DRIF,IFSGN) IF (IFSGN.GE.0) THEN * Extend FRQH bank ... IKADD(1) = ICLNUM BKADD(2) = EDEP BKADD(3) = DRIF IKADD(4) = IHTNOI IKADD(5) = IFSGN IKADD(6) = ITRHIS IKADD(7) = ITRK KND = IADROW('FRQH',NBN,NCL,BKADD) ENDIF ENDIF INDST = INDST + IW(INFRQN+1) 41 CONTINUE * End loop through hits this bank - go to next bank GOTO 40 ENDIF * Finished IFRQH = IADFIN('FRQH',NBN) RETURN END *CMZU: 03/08/98 13.56.29 by Stephen Burke *-- Author : Stephen Burke 03/08/98 SUBROUTINE FRQXCR *#********************************************************************** *# * *# VERSION: 30/07/98 Steve Burke * *# * *# Create table of pointers, parallel to FRQH hit bank * *# pointing into FRQE * *# * *# CALLED BY: FQDIGI * *# * *#********************************************************************** *# * *# FORMAT OF FRQX BANK B16 Bank Number = 0 * *# ====== == ==== ==== * *# Bank FRQX Forward Response new planar (Q) X-ref bank * *# Contains relations to FRQE and STR banks * *# PARALLEL to FRQH bank * *# * *# word# type Content * *# 1 I = NCOLS = 3 * *# 2 I = NROWS = Number of hits * *# ---------------------------------------------------------------- * *# Col * *# 1 I = IFLAG Attrib * *# 2 I = Trk Number (STR) Reln * *# 3 I = IFRQE Reln * *# ----------------------------------------------------------------- * *# IFLAG = Bit 0 set if drift sign posive * *# Bit 8 set if hit from track * *# Bit 9 set if hit from noise * *# Bit10 set if hit from TR * *# Trk Num Pointer into STR bank * *# IFRQE Pointer into FRQE bank * *# * *#********************************************************************** *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/ *KEND. * Temp common for pointer arrays (extended for FRQX 29/7/98) PARAMETER (MAXHIT=3000) COMMON /H1WORK/ IFRRX(3,MAXHIT),IFRPX(3,MAXHIT),NFRRX,NFRPX &, IFRQX(3,MAXHIT),NFRQX PARAMETER (NBN=0) PARAMETER (NCOL=3) *#********************************************************************** IF (NFRQX.NE.0) THEN CALL BKFMT('FRQX','B16') IND = IADNRW('FRQX',NBN,NCOL,NFRQX,IFRQX) IND = IADFIN('FRQX',NBN) CALL BLIST(IW,'E+','FRQX') ENDIF RETURN END *CMZ : 20/01/99 15.04.09 by Girish D. Patel *-- Author : Stephen Burke 03/08/98 SUBROUTINE FRQHEX(ICLNUM,NWIRE,DRIFT,IDSIGN,ITRK) *#********************************************************************** *# * *# PURPOSE: Extend FRQH hit bank by adding track-related noise hits * *# * *# CALLED BY : FRQHCC, once per track per module * *# * *# INPUT : ICLNUM - cell number (for wire 0) * *# NWIRE - number of wires * *# DRIFT - absolute drift to each wire * *# IDSIGN - drift sign for each wire * *# ITRK - track number * *# * *# OUTPUT : FRQH bank rows * *# ==== * *# * *# AUTHOR : Stephen Burke * *# * *# MODIFICATIONS: * *# * *#********************************************************************** *# * *# FORMAT OF FRQH BANK 2I,(I,2F,4I) Bank Number = 0 * *# ====== == ==== ==== * *# * *# BANK FRQH Forward Response new planar (Q) Hit bank * *# Contains all hits in new Planars * *# * *# IND+1 = NCOLS = 7 * *# IND+2 = NROWS * *# ---------------------------------------------------------------- * *# Col * *# 1 I = CELNUM Attrib * *# 2 R = EDEP Attrib * *# 3 R = DRIFT DISTANCE Attrib * *# 4 I = HITTYP Attrib * *# 5 I = Drift 'sign' 0/1 Attrib * *# 6 I = Trk History word Attrib * *# 7 I = Trk Number Reln * *# ---------------------------------------------------------------- * *# HITTYP = 2 for noise * *# (GEANT units: cms GeV) * *# * *# Word 6 is set to zero, and word 7 to the 'parent' track number * *# * *#********************************************************************** *KEEP,FQMAXN. * Maximum number of noise hits for new planars PARAMETER (MXNHTQ=5) *KEND. PARAMETER (NWMAX=8) DIMENSION DRIFT(NWMAX),IDSIGN(NWMAX),DRIFTN(MXNHTQ,NWMAX) PARAMETER (IHTNOI=2,ITRHIS=0,NCL=7,NBN=0) DIMENSION IKADD(NCL),BKADD(NCL) EQUIVALENCE (IKADD(1),BKADD(1)) * Minimum energy deposit (50MeV) for a hit (avoids hits with zero * energy loss and hence un-reconstructible radii) PARAMETER (FELMIN=5.0E-8) * Parameters for noise pseudo-track (6 mm, 100 MeV electron) PARAMETER (DIST=0.6,PMOM=-0.1,IPDG=11) *#********************************************************************** * Just in case ... IF (NWIRE.GT.NWMAX) NWIRE = NWMAX * Generate noise hits CALL FQGTRN(NWIRE,DRIFT,DRIFTN) DO 200 JWIRE=1,NWIRE DO 100 JHIT=1,MXNHTQ * Negative drift means no hit IF (DRIFTN(JHIT,JWIRE).LT.0.) GOTO 100 * Compute energy loss (totally arbitrary) CALL FDEDXL(DIST,0.,0.,0.,0.,0.,PMOM,IPDGEA(IPDG),FELOSS) IF (FELOSS.LE.FELMIN) GOTO 100 * Add row to FRQH bank IKADD(1) = ICLNUM + JWIRE - 1 BKADD(2) = FELOSS BKADD(3) = DRIFTN(JHIT,JWIRE) IKADD(4) = IHTNOI IKADD(5) = IDSIGN(JWIRE) IKADD(6) = ITRHIS IKADD(7) = ITRK KND = IADROW('FRQH',NBN,NCL,BKADD) 100 CONTINUE 200 CONTINUE RETURN END *CMZ : 20/01/99 15.05.03 by Girish D. Patel *-- Author : Stephen Burke 03/08/98 SUBROUTINE FQGTRN(NWIRE,DD,DDN) *#********************************************************************** *# * *# PURPOSE: Generate track-related noise for the new planars * *# * *# CALLED BY : FRQHEX * *# * *# INPUT : NWIRE - number of wires * *# DD - absolute drifts to each of the wires * *# * *# OUTPUT : DDN - drifts for noise hits * *# * *# AUTHOR : Steve Burke * *# * *# CHANGED BY: AT: * *# * *# REASON : * *# * *#********************************************************************** *KEEP,FQMAXN. * Maximum number of noise hits for new planars PARAMETER (MXNHTQ=5) *KEEP,FQTRNP. * Forward new planar track-related noise + shifted data parameters PARAMETER (MAXSGQ=5) LOGICAL LFDQX COMMON /FQTRNP/ QTRNP1(MXNHTQ),QTRNP2(MXNHTQ),QTRNDD(2,MAXSGQ) &, QPNEGD,LFDQX,SIGSHF,SGNSHF,SIGNOI,SGNNOI &, ANGNOI,PRBNOI,OFFNOI *KEND. * Maximum drift for noise hits - slightly unphysical PARAMETER (DMAX=3.2,NWMAX=8) DIMENSION DD(NWMAX),DDN(MXNHTQ,NWMAX) INTEGER FCBDD LOGICAL LFIRST *#********************************************************************** * Just in case ... IF (NWIRE.GT.NWMAX) NWIRE = NWMAX SHIFT = 0. NSHFT = 0 IF (LFDQX .AND. H1RN(NWIRE+2).LE.PRBNOI) THEN SHIFT = -SIGNOI*LOG(1. - MIN(H1RN(NWIRE),0.999999)) * Choose a drift sign IF (H1RN(NWIRE+1).LE.SGNNOI) SHIFT = -SHIFT CALL H1NORR(GAUSS) ANGLE = ANGNOI*GAUSS NSHFT = 1 ENDIF LFIRST = .TRUE. DO 200 JWIRE=1,NWIRE IF (LFIRST) THEN * QTRNP1 is the probability distribution for the first wire with hits ... NHIT = FCBDD(QTRNP1,MXNHTQ) IF (NHIT.GT.0) LFIRST = .FALSE. ELSE * ... and QTRNP2 for subsequent wires NHIT = FCBDD(QTRNP2,MXNHTQ) ENDIF DO 100 JHIT=1,MXNHTQ * Negative drift means no hit DDN(JHIT,JWIRE) = -1.0 IF (JHIT.GT.NHIT+NSHFT) THEN GOTO 100 ELSEIF (JHIT.GT.NSHFT) THEN * Choose a drift from the distribution in QTRNDD DN = FCVPWL(QTRNDD,MAXSGQ) IF (LFDQX) DN = DN + OFFNOI * Choose a drift sign IF (H1RN(JHIT).LE.QPNEGD) DN = -DN ELSE DN = SHIFT + ANGLE*FLOAT(JWIRE-1) ENDIF * Disallow unphysical drifts TEST = DD(JWIRE) + DN IF (TEST.LT.0. .OR. TEST.GT.DMAX) TEST = DD(JWIRE) - DN IF (TEST.GE.0. .AND. TEST.LE.DMAX) DDN(JHIT,JWIRE) = TEST 100 CONTINUE 200 CONTINUE RETURN END *CMZU: 03/08/98 13.56.29 by Stephen Burke *-- Author : Stephen Burke 03/08/98 SUBROUTINE FQQTSM(INFRQH,KDIGI,JFIRST,JLAST) *#********************************************************************** *# * *# PURPOSE: Simulate the new planar QT code, and fill the EVENT * *# response bank FRQE * *# * *# CALLED BY : FRQECR * *# * *# INPUT: INFRQH - index of FRQH bank * *# KDIGI - last digi number * *# JFIRST - pointer to first hit on wire * *# JLAST - pointer to last hit on wire * *# ISORT - pointer to work bank with sorted FRQH indices * *# (in /CFSORT/) * *# * *# OUTPUT : FRQE bank rows for this wire * *# IFRQX - array holding FRQX bank rows (in /H1WORK/) * *# * *#********************************************************************** *# * *# FORMAT OF FRQE BANK B16 Bank Number = 0 * *# ====== == ==== ==== * *# * *# Bank FRQE Forward Response new planar (Q) Event bank * *# Contains digitisations for new planar drift chambers* *# * *# word# type Content * *# 1 I NCOLS = 6 (= Number of attrributes) * *# 2 I NROWS (= Num of digis) * *# ---------------------------------------------------------------- * *# Col * *# 1 I Cell Number Attrib * *# 2 I Drift Attrib * *# 3 I Q Attrib * *# 4 I FLAG0 Attrib * *# 5 I FLAG1 Attrib * *# 6 I FLAG2 Attrib * *# ---------------------------------------------------------------- * *# * *# NOTES: * Digitisations consist of more than one hit in general * *# * Drift times refer to the first hit to arrive at the wire * *# and are given in 10 micron units * *# * Q is evaluated from energy deposition in the cell. * *# The default unit is eV. In FRQH the energy is * *# given in GeV. The conversion to eV is done in two * *# steps. GeV -> keV is 'hard-wired' in this routine and * *# an additional scale factor, QFAC, is then applied. * *# QFAC is taken from the FDQR bank and so can be * *# steered. Its default value is 1000. * *# * *# * IFLAG0 Bits 0-7 Peak height (non-linear) * *# Bits 8-15 Separation in FADC bins from * *# previous digi in cluster (measured * *# between the centres of the hits) * *# * IFLAG1 Bits 0-7 Re-linearised pedestal (set to 100) * *# Bits 8-15 Peak height of previous hit * *# * IFLAG2 Bits 0-6 Number of FADC bins from start of * *# cluster to end of this hit * *# Bits 7-10 Length of the leading edge in FADC * *# bins * *# Bits 11-14 Number of previous hits in this * *# cluster * *# Bit 15 Raw data kept flag (always zero) * *# * *#********************************************************************** *KEEP,FQDGPR. COMMON /FQDGPR/ TTSEP1,TTSEP2,MAXINT,ERRD0,ERRD1,ERRD2,ERRD3 &, DELCHG,DQUANT,FADBIN *KEEP,FQDGDG. COMMON /FQDGDG/ IDRFAC,QFAC,IQSAT *KEND. *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/ *KEND. * Temp common for pointer arrays (extended for FRQX 29/7/98) PARAMETER (MAXHIT=3000) COMMON /H1WORK/ IFRRX(3,MAXHIT),IFRPX(3,MAXHIT),NFRRX,NFRPX &, IFRQX(3,MAXHIT),NFRQX COMMON /CFSORT/ ISORT PARAMETER (NBN=0,NCL=6) INTEGER IKADD(NCL) * Max of 64 hits per cluster (previous hit stops at 15) PARAMETER (MAXQT=64) DIMENSION JDIGI(0:MAXQT) * Minimum allowed Q (arbitrary) PARAMETER (QMIN=10.) * Nominal length of the leading edge is 3 bins PARAMETER (LLEDGE=3) * Q for a maximum count of 1024: 1024*12/2 = 6144 (highly arbitrary!) PARAMETER (QMAX=6144.) PARAMETER (GVTOKV=1000000.) *#********************************************************************** * Main loop over clusters - set cell number, first drift and previous drift ICELL = IW(IW(ISORT+JFIRST)) DCLUS = RW(IW(ISORT+JFIRST)+2) DLAST = -1. JCLUS = JFIRST 100 CONTINUE * Find hit cluster (from JDIGI(0) to JCLUS-1) and collect into digis NHIT = 0 JDIGI(0) = JCLUS 200 CONTINUE JCLUS = JCLUS + 1 * Have we fallen off the end of the wire? IF (JCLUS.LE.JLAST) THEN DPREV = DCLUS DCLUS = RW(IW(ISORT+JCLUS)+2) * The minimum cluster separation is taken as being the same as * the integration interval IF ((DCLUS-DPREV)*FADBIN.LE.MAXINT) THEN * The two-track separation should probably depend on Q; this is a bodge * Model is a linear rise from TTSEP1 to TTSEP2 PROB = (DCLUS - DPREV - TTSEP1)/(TTSEP2 - TTSEP1) IF (H1RN(JCLUS).LT.PROB) THEN * Start a new digi (else merged with the previous one) NHIT = NHIT + 1 * The QT has a maximum number of hits per cluster IF (NHIT.LE.MAXQT) JDIGI(NHIT) = JCLUS ENDIF GOTO 200 ENDIF ENDIF IF (NHIT.LT.MAXQT) THEN * We need a pointer to the next hit after this cluster JDIGI(NHIT+1) = JCLUS ELSE * We got more than the allowed number of hits NHIT = MAXQT - 1 ENDIF * Loop over digis in cluster - initialise last DOS sum and first drift IPLAST = 0 DSTART = RW(IW(ISORT+JDIGI(0))+2) DO 500 IHIT=0,NHIT * Increment digi counter KDIGI = KDIGI + 1 * Add up the charges in this digi, and fill the FRQX rows DRIFT = 0. QPLUS = 0. DO 300 JHIT=JDIGI(IHIT),JDIGI(IHIT+1)-1 CHARGE = GVTOKV*RW(IW(ISORT+JHIT)+1) DRIFT = DRIFT + CHARGE*RW(IW(ISORT+JHIT)+2) QPLUS = QPLUS + CHARGE * Type of hit + drift sign IHTTYP = IW(IW(ISORT+JHIT)+3) ISGN = IW(IW(ISORT+JHIT)+4) * Row number in FRQH JROW = (IW(ISORT+JHIT) - INFRQH - 2)/IW(INFRQH+1) + 1 IFRQX(1,JROW) = IBSET(IFRQX(1,JROW),IHTTYP+7) + ISGN IFRQX(2,JROW) = IW(IW(ISORT+JHIT)+6) IFRQX(3,JROW) = KDIGI 300 CONTINUE * Drift is charge-weighted average (rough guess) DRIFT = DRIFT/QPLUS * Now for the QT flags: DOS sum (peak height) (rather arbitrary) IPEAK = 255.*QPLUS*QFAC/QMAX IF (IPEAK.GT.255) IPEAK = 255 * Distance to previous hit - set to zero for first hit (?) IF (DLAST.LT.0.) THEN ISEPL = 0 ELSE ISEPL = (DRIFT - DLAST)*FADBIN + 0.499 IF (ISEPL.GT.255) ISEPL = 255 ENDIF DLAST = DRIFT * Relinearised pedestal - arbitrary IPED = 100 * Number of bins from start of cluster to end of leading edge of this hit DSTOP = RW(IW(ISORT+JDIGI(IHIT+1)-1)+2) LHIT = LLEDGE + ((DSTOP - DSTART)*FADBIN + 0.499) IF (LHIT.GT.127) LHIT = 127 * Number of adjacent bins above threshold * Set to 2 + number of hits in digi (a bit silly, but what else?) * Should just be length of leading edge? NADJ = LLEDGE + JDIGI(IHIT+1) - JDIGI(IHIT) - 1 IF (NADJ.GT.15) LHIT = 15 * Hit counter sticks at 15 IIHIT = MIN(IHIT,15) * Pack pulse shape info IFLAG0 = 0 IFLAG1 = 0 IFLAG2 = 0 CALL MVBITS(IPEAK,0,7,IFLAG0,0) CALL MVBITS(ISEPL,0,7,IFLAG0,8) CALL MVBITS(IPED,0,7,IFLAG1,0) CALL MVBITS(IPLAST,0,7,IFLAG1,8) CALL MVBITS(LHIT,0,6,IFLAG2,0) CALL MVBITS(NADJ,0,3,IFLAG2,7) CALL MVBITS(IIHIT,0,3,IFLAG2,11) * No raw data kept! * CALL SBIT0(IFLAG2,16) * Remember last peak height IPLAST = IPEAK * Compute smeared drift (first hit) CALL FDQSME(DRIFT,IFLAG0,IFLAG1,IFLAG2,DSMEA) * Compute smeared charge CALL FQQSME(QPLUS,IFLAG0,IFLAG1,IFLAG2,QPSME) IF (QPSME.LT.QMIN) THEN * Abandon digi KDIGI = KDIGI - 1 DO 400 JHIT=JDIGI(IHIT),JDIGI(IHIT+1)-1 JROW = (IW(ISORT+JHIT) - INFRQH - 2)/IW(INFRQH+1) + 1 IFRQX(3,JROW) = 0 400 CONTINUE ELSE * Prepare input array of FRQE bank (NB T0 = 1000) IKADD(1) = ICELL IKADD(2) = ABS(1000. + DSMEA*FADBIN*50.0) IKADD(3) = MIN(IFIX(QPSME),IQSAT) IKADD(4) = IFLAG0 IKADD(5) = IFLAG1 IKADD(6) = IFLAG2 * Extend FRQE bank INFRQE = IADROW('FRQE',NBN,NCL,IKADD) ENDIF 500 CONTINUE * Allow for hits with no digi! DO 600 JHIT=JDIGI(NHIT+1),JCLUS-1 IHTTYP = IW(IW(ISORT+JHIT)+3) ISGN = IW(IW(ISORT+JHIT)+4) JROW = (IW(ISORT+JHIT) - INFRQH - 2)/IW(INFRQH+1) + 1 IFRQX(1,JROW) = IBSET(IFRQX(1,JROW),IHTTYP+7) + ISGN IFRQX(2,JROW) = IW(IW(ISORT+JHIT)+6) IFRQX(3,JROW) = 0 600 CONTINUE * Go on to next cluster, if any IF (JCLUS.LE.JLAST) GOTO 100 RETURN END *CMZU: 03/08/98 13.56.29 by Stephen Burke *-- Author : Stephen Burke 03/08/98 SUBROUTINE FQHMC(MASK) *#********************************************************************** *# * *# PURPOSE: Choose which hits are present in a "missing" new planar * *# cluster. * *# * *# CALLED BY : FRQHCC * *# * *# CALLS : FCBDD * *# * *# INPUT : Hit probabilities from FQDGEF * *# * *# OUTPUT : Hit mask (one bit per wire) * *# * *# AUTHOR : Steve Burke * *# * *#********************************************************************** *# * *# CHANGED BY: * *# * *# REASON : * *# * *#********************************************************************** INTEGER FCBDD *KEEP,FQDGEF. COMMON /FQDGEF/ EFFQ(0:7,0:2),EFFQ8(0:2),PHMC(6),PWMC1(5) &, PWMC2(5),PWMC3(5),PWMC4(5),PWMC5(5) *KEND. *#********************************************************************** * How many hits are there? NHIT = FCBDD(PHMC,6) IF (NHIT.LE.0) THEN * Zero hits MASK = 0 ELSEIF (NHIT.EQ.1) THEN * One hit MASK = 0 CALL SBIT1(MASK,FCBDD(PWMC1,5)+1) ELSEIF (NHIT.EQ.2) THEN * Two hits MASK = 0 IWR1 = FCBDD(PWMC1,5) 10 CONTINUE IWR2 = FCBDD(PWMC2,5) IF (IWR2.EQ.IWR1) GOTO 10 CALL SBIT1(MASK,IWR1+1) CALL SBIT1(MASK,IWR2+1) ELSEIF (NHIT.EQ.3) THEN * Three hits MASK = 0 IWR1 = FCBDD(PWMC1,5) 20 CONTINUE IWR2 = FCBDD(PWMC2,5) IF (IWR2.EQ.IWR1) GOTO 20 30 CONTINUE IWR3 = FCBDD(PWMC3,5) IF (IWR3.EQ.IWR1 .OR. IWR3.EQ.IWR2) GOTO 30 CALL SBIT1(MASK,IWR1+1) CALL SBIT1(MASK,IWR2+1) CALL SBIT1(MASK,IWR3+1) ELSEIF (NHIT.EQ.4) THEN * Four hits MASK = 63 IWR5 = FCBDD(PWMC5,5) 40 CONTINUE IWR4 = FCBDD(PWMC4,5) IF (IWR4.EQ.IWR5) GOTO 40 CALL SBIT0(MASK,IWR5+1) CALL SBIT0(MASK,IWR4+1) ELSEIF (NHIT.EQ.5) THEN * Five hits MASK = 63 CALL SBIT0(MASK,FCBDD(PWMC5,5)+1) ELSE * Six hits MASK = 63 ENDIF RETURN END *CMZ : 15/09/99 17.28.21 by Girish D. Patel *CMZ : 3.06/24 12/09/95 21.46.24 by Vladimir Shekelyan *CMZU: 3.01/00 09/03/94 15.02.36 by Stephan Egli *CMZU: 3.00/05 08/02/94 15.48.15 by Stephan Egli *CMZU: 2.13/00 20/05/93 18.23.11 by Stephan Egli *CMZU: 2.10/00 07/12/92 19.26.58 by Stephan Egli *CMZU: 2.00/01 19/02/91 15.00.52 by Stephan Egli *-- Author : Stephan Egli 19/02/91 SUBROUTINE FDIGI ************************************************************************ * Digitize hit data for forward tracker. * ************************************************************************ *KEEP,BOSMDL. C ------BOSMDL LOGICAL BEGJOB,ENDRUN,BEGRUN,REVENT,ENDJOB,OTHDAT COMMON/BOSMDL/BEGJOB,ENDRUN,BEGRUN,REVENT,ENDJOB,OTHDAT, + LCCRUN,NCCRUN,NEVENT, + IHA,IBS,IDB,IDATEL,LUP,ISN,JSN SAVE /BOSMDL/ C ------ *KEEP,H1OSGO. COMMON /H1OSGO/ LCONFG,IGEAND(13),RGEANC(16),IGEANP(12) *KEND. CHARACTER*8 VERSQQ *KEEP,VERSQQ. VERSQQ = ' 3.09/10' IVERSQ = 30910 *KEND. IF(LCONFG.LT.10) THEN CALL MODULS('FDIGI',IVERSQ,'FRPTFRPFFRRTFRRFFRMTFRTT') CALL MODDEF(30433) IF(BEGRUN)THEN CALL FRIDIG CALL FPIDIG ENDIF IF(REVENT)THEN CALL FRDIGI CALL FPDIGI CALL FMDIGI CALL FMPME ENDIF ELSE CALL MODULS('FDIGI',IVERSQ,'FRPTFRPFFRQTFRQF') CALL MODDEF(30433) IF(BEGRUN)THEN CALL FQIDIG CALL FPIDIG ENDIF IF(REVENT)THEN CALL FQDIGI CALL FPDIGI ENDIF ENDIF CALL MODULF CALL MODDEF(0) RETURN END *------------- end upgrade.f --------------------- *------------- start newftsim.f ------------------ *CMZU: 3.06/00 28/12/94 17.39.21 by Matthias Korn *CMZ : 3.05/02 08/11/94 15.07.49 by Vladimir Shekelyan *CMZ : 3.04/01 01/10/94 21.10.29 by Stephan Egli *CMZU: 3.01/02 23/03/94 17.59.14 by Stephan Egli *CMZ : 3.01/01 22/03/94 17.24.46 by Stephan Egli *CMZU: 3.01/00 05/03/94 20.57.42 by Stephan Egli *CMZU: 3.00/01 12/11/93 16.44.27 by Stephan Egli *-- Author : Stephan Egli PROGRAM SIMH1 ************************************************************************ * Main program for purely simulation jobs. Use the following flags * * to extract the proper version: * * * * Flag H1GEAONLY: only the H1GEA module is run (e.g. for external * * productions. * * no flags: H1GEA + digi + trigger modules * ************************************************************************ * *KEEP,CJOBNR. COMMON/CJOBNR/JOBNR,LAB SAVE /CJOBNR/ *KEND. *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/ *KEND. CHARACTER*8 INBOS * * initialize BOS * CALL BNAMES(2000) CALL BOS(IW,NBOSIW) * * * read i/o commands and steering banks CALL FPARMR(5) CALL BREADC * * check for input file: * 35 IF(IFRST('BOSINPUT',0).NE.0)THEN INBOS='BOSINPUT' ELSE INBOS=' ' ENDIF * initialize random number generator * get next job number JOBNR=MDB('/JOB') CALL H1RNIN(JOBNR+1) * ---- event processing loop ------------------------------------------ * 10 CALL FSEQR(INBOS,IRET) IF(IRET.LT.0) GOTO 100 IF(INBOS.EQ.' ')CALL INLGEN * ----------- tracking module ---------------- CALL H1GEA * select run number (call has no effect, if no RUNR bank available) CALL NEWRUN(IEND) IF(IEND.EQ.1)CALL FSEQE * ----------- digi modules ------------------- c CALL CDIGI CALL FDIGI c CALL ADIGI c CALL PDIGI c CALL BDIGI c CALL SDIGI c CALL IDIGI c CALL MDIGI c CALL JHITS c CALL JDIGI c CALL LDIGI * -------------- trigger modules ----------------- c CALL MWTRES c CALL ARTRES c CALL DCTRES c CALL BCTRES c CALL SPTRES c CALL MUTRES c CALL LUTRES * trigger elements c CALL CTCELE * central trigger logic c CALL CTCLOG CALL FSEQW('BOSOUTPUT') GOTO 10 * * perform final book keeping 100 IND=MDB('/END') CALL FPARM('CLOSE ALL') STOP END *CMZ : 10/11/98 14.49.49 by Girish D. Patel *CMZU: 3.07/18 31/01/98 18.13.53 by V.Solochenko *CMZ : 3.07/00 20/02/97 15.16.06 by Hanna Mahlke-Krueger *CMZU: 3.06/37 27/02/96 16.26.57 by Olaf Duenger *CMZU: 3.06/35 28/12/95 08.47.04 by Vladimir Andreev *CMZ : 3.06/25 28/09/95 20.48.57 by Vladimir Shekelyan *CMZU: 3.05/02 01/11/94 13.15.55 by Benno List *CMZU: 3.00/03 06/12/93 15.35.51 by Vladimir Shekelyan *CMZU: 2.14/02 10/08/93 20.45.44 by Vladimir Shekelyan *CMZU: 2.10/13 15/12/92 17.27.25 by Alexander Fedotov *CMZU: 2.08/04 11/06/92 11.58.39 by Christian Pichler *CMZU: 2.06/04 10/01/92 10.37.08 by Jozef Ferencei *CMZU: 2.04/00 11/07/91 19.26.42 by Joerg Gayler *CMZ : 2.01/00 08/07/91 19.01.14 by Pavel Staroba *CMZU: 2.00/06 15/05/91 17.39.03 by Stephan Egli *CMZU: 2.00/03 25/04/91 12.34.03 by Stephan Egli *CMZ : 2.00/02 05/04/91 11.39.35 by Stephan Egli *CMZ : 2.00/00 10/02/91 09.08.52 by Stephan Egli *CMZ : 1.08/02 06/02/91 14.35.14 by Stephan Egli *-- Author : SUBROUTINE GEDEPO ************************************************************************ * Main steering routine for hit production. Depending on the current * * subdetector,IDTYPE and granularity the necessary hit routine is * * selected. * * Input: IDTYPE: COMMON/GCSETS/ * * ISGRAN(1..8): COMMON/H1DETC/ * * CHARGE: COMMON/GCKINE/ * * DESTEP: COMMON/GCTRAK/ * * ICURSU: COMMON/CCURSU/ * * * * The array EN has the following meaning: * * EN(1) visible had energy + fluctation * * EN(2) visible em energy + fluctation * * EN(3) invisible energy no fluctuation (break-up) * * EN(4) total em energy no fluctuation * * EN(5) total had energy no fluctuation * * EN(6) visible had energy no fluctuation * * * * Author: Stephan Egli 10.3.90 * * Changed by: P.Staroba 28.1.91 Reason : Adaption for ARCET * * Changed by: W. Hildesheim 7.4.91 Reason : no calib. ene's in IRHT * * H1DEDX stuff obsoleted, use IFLASH(1,I)=0 instead * * Changed by: W.H./S.E. passive E not in visible E, only in Eemtot * * CHANGED BY: H.KAUFMANN AT: 30/1/91 * * REASON : VERTEX- AND BACKWARD SILICON DETECTORS IMPLEMENTED * * Changed by: J.Gayler 11.7.91 Reason : allow for M>7 in ARCET * * Changed by: J.Ferencei at: 10/01/92 * * Reason : ACSOFT part (as determined by P.Reimer) of the energy * * inside the BEMC WLS stored for detailed granularity * * Changed by: C.Pichler at: 27/05/92 * * Reason : ACSOFT correction removed and put to subroutine BDEPO * * Changed by: A.Fedotov 13.12.92 Reason: call JHIT for proton tagger * * Changed by: V.Shekelyan at: 29.07.93 * * Reason : upgrade 1995 * * Changed by: P.Biddulph 27.10.94 Reason: call JHIT for FToF * * Changed by: O.Duenger 27.02.96 Reason: call JHIT for Neutron Counter* * Changed by: H. Mahlke-Krueger 01.08.96 * * Reason: call JHIT for interior of Roman Pots * * Changed by: V.Solochenko 31.01.98 Reason: call JHIT for FTS * ************************************************************************ *KEEP,GCKINE. COMMON/GCKINE/IKINE,PKINE(10),ITRA,ISTAK,IVERT,IPART,ITRTYP + ,NAPART(5),AMASS,CHARGE,TLIFE,VERT(3),PVERT(4),IPAOLD C INTEGER IKINE,ITRA,ISTAK,IVERT,IPART,ITRTYP,NAPART,IPAOLD REAL PKINE,AMASS,CHARGE,TLIFE,VERT,PVERT C *KEEP,GCTRAK. INTEGER NMEC,LMEC,NAMEC,NSTEP ,MAXNST,IGNEXT,INWVOL,ISTOP,MAXMEC + ,IGAUTO,IEKBIN,ILOSL, IMULL,INGOTO,NLDOWN,NLEVIN,NLVSAV,ISTORY REAL VECT,GETOT,GEKIN,VOUT,DESTEP,DESTEL,SAFETY,SLENG ,STEP + ,SNEXT,SFIELD,TOFG ,GEKRAT,UPWGHT PARAMETER (MAXMEC=30) COMMON/GCTRAK/VECT(7),GETOT,GEKIN,VOUT(7),NMEC,LMEC(MAXMEC) + ,NAMEC(MAXMEC),NSTEP ,MAXNST,DESTEP,DESTEL,SAFETY,SLENG + ,STEP ,SNEXT ,SFIELD,TOFG ,GEKRAT,UPWGHT,IGNEXT,INWVOL + ,ISTOP ,IGAUTO,IEKBIN, ILOSL, IMULL,INGOTO,NLDOWN,NLEVIN + ,NLVSAV,ISTORY C *KEEP,GCSETS. COMMON/GCSETS/IHSET,IHDET,ISET,IDET,IDTYPE,NVNAME,NUMBV(20) C INTEGER IHSET,IHDET,ISET,IDET,IDTYPE,NVNAME,NUMBV C *KEEP,H1DETC. PARAMETER (NSUBDE=8) COMMON /H1DETC/ NAMSUB(NSUBDE),ISGRAN(NSUBDE),ISRBNK(NSUBDE), 1 ISDSBK(NSUBDE),ISTRKB(NSUBDE),ISTRKM(NSUBDE), 1 SKECUT(NSUBDE+2) *KEEP,CCURSU. COMMON/CCURSU/ICURSU,IPRESU,ISGRAC,ISRBNC,ISDSBC,ISTRBC,ISTRKC, 1 SKECUC *KEEP,GCFLAG. COMMON/GCFLAG/IDEBUG,IDEMIN,IDEMAX,ITEST,IDRUN,IDEVT,IEORUN + ,IEOTRI,IEVENT,ISWIT(10),IFINIT(20),NEVENT,NRNDM(2) COMMON/GCFLAX/BATCH, NOLOG LOGICAL BATCH, NOLOG C INTEGER IDEBUG,IDEMIN,IDEMAX,ITEST,IDRUN,IDEVT,IEORUN + ,IEOTRI,IEVENT,ISWIT,IFINIT,NEVENT,NRNDM C *KEEP,GCTMED. COMMON/GCTMED/NUMED,NATMED(5),ISVOL,IFIELD,FIELDM,TMAXFD,STEMAX + ,DEEMAX,EPSIL,STMIN,CFIELD,PREC,IUPD,ISTPAR,NUMOLD C INTEGER NUMED,NATMED,ISVOL,IFIELD,IUPD,ISTPAR,NUMOLD REAL FIELDM,TMAXFD,STEMAX,DEEMAX,EPSIL,STMIN,CFIELD,PREC C *KEEP,GCMATE. COMMON/GCMATE/NMAT,NAMATE(5),A,Z,DENS,RADL,ABSL C INTEGER NMAT,NAMATE REAL A,Z,DENS,RADL,ABSL C *KEEP,GCBANK. INTEGER IQ,LQ,NZEBRA,IXSTOR,IXDIV,IXCONS,LMAIN,LR1,JCG INTEGER KWBANK,KWWORK,IWS REAL GVERSN,ZVERSN,FENDQ,WS,Q C PARAMETER (KWBANK=1300000,KWWORK=5200) COMMON/GCBANK/NZEBRA,GVERSN,ZVERSN,IXSTOR,IXDIV,IXCONS,FENDQ(16) + ,LMAIN,LR1,WS(KWBANK-24) DIMENSION IQ(KWBANK-30),Q(KWBANK-30),LQ(KWBANK-22),IWS(KWBANK-24) EQUIVALENCE (Q(1),IQ(1),LQ(9)),(LQ(1),LMAIN),(IWS(1),WS(1)) EQUIVALENCE (JCG,JGSTAT) INTEGER JDIGI ,JDRAW ,JHEAD ,JHITS ,JKINE ,JMATE ,JPART + ,JROTM ,JRUNG ,JSET ,JSTAK ,JGSTAT,JTMED ,JTRACK,JVERTX + ,JVOLUM,JXYZ ,JGPAR ,JGPAR2,JSKLT C COMMON/GCLINK/JDIGI ,JDRAW ,JHEAD ,JHITS ,JKINE ,JMATE ,JPART + ,JROTM ,JRUNG ,JSET ,JSTAK ,JGSTAT,JTMED ,JTRACK,JVERTX + ,JVOLUM,JXYZ ,JGPAR ,JGPAR2,JSKLT C *KEEP,GCJLOC. COMMON/GCJLOC/NJLOC(2),JTM,JMA,JLOSS,JPROB,JMIXT,JPHOT,JANNI + ,JCOMP,JBREM,JPAIR,JDRAY,JPFIS,JMUNU,JRAYL + ,JMULOF,JCOEF,JRANG C INTEGER NJLOC ,JTM,JMA,JLOSS,JPROB,JMIXT,JPHOT,JANNI + ,JCOMP,JBREM,JPAIR,JDRAY,JPFIS,JMUNU,JRAYL + ,JMULOF,JCOEF,JRANG C *KEEP,H1OSGO. COMMON /H1OSGO/ LCONFG,IGEAND(13),RGEANC(16),IGEANP(12) *KEND. LOGICAL BTEST DIMENSION MNLIJK(6),EN(6),VSPOT(6) * ============================================== * sum of DESTEP (calorimeters and dead material) * ============================================== IF(DESTEP.EQ.0.) GO TO 5 * for particles leaving iron (ICURSU=9) dE/dx is not defined IF(ICURSU.EQ.9) GO TO 5 * map to channel number CALL GENMAP(1,VECT,MNLIJK,ISGRAC) * apply Birk's law for BEMC SCSN-38 scintillator and for LAr * if requested by steering DESVIS=DESTEP IF(BTEST(ISWIT(9),8))THEN IF (ABS(CHARGE) .GT. 0.1)THEN IF(NUMED.EQ.503.OR.(NUMED.GE.511.AND.NUMED.LE.516))THEN RKB=Q(LQ(JTM)+28)/DENS IF (ABS(CHARGE).GE.2.) RKB=RKB*7.2/12.6 DEDXCM=1000.*Q(JLOSS+IEKBIN) DESVIS=DESTEP/(1.+RKB*DEDXCM) ELSE IF(NMAT.EQ.310)THEN RKB=Q(LQ(LQ(JTMED-310))+28)/DENS IF (ABS(CHARGE).GE.2.) RKB=RKB*7.2/12.6 DEDXCM=1000.*Q(JLOSS+IEKBIN) DESVIS=DESTEP/(1.+RKB*DEDXCM) ENDIF ENDIF ENDIF * distinguish between absorber material and sensitive material in detailled * tracking (no Evis for passive) and distinction of em and had energies N=MNLIJK(2) IF(ITRTYP.LT.3)THEN * electromagnetic energy EN(1)=0. IF(N.GE.4) THEN EN(2)=0. ELSE EN(2)=DESVIS ENDIF EN(3)=0. EN(4)=DESTEP EN(5)=0. EN(6)=0. ELSE * hadronic energy IF(N.GE.4) THEN EN(1)=0. EN(6)=0. ELSE EN(1)=DESVIS EN(6)=DESVIS ENDIF EN(2)=0. EN(3)=0. EN(4)=0. EN(5)=DESTEP ENDIF * reset to "active" number except for IRON IF(N.GE.4.AND.MNLIJK(1).NE.10)MNLIJK(2)=N-4 * deposit dE/dx in bank CALL SPODEP(1,VECT,EN,MNLIJK) * ======================== * other cases (tracks,...) * ======================== 5 CONTINUE * IF(IDTYPE.EQ.0) RETURN * tracker hits after 100 ns are ignored IF(ICURSU.LE.2)THEN IF(TOFG.GT.1.E-7)RETURN ENDIF GOTO(10,20,30,40,50,60,70,80),ICURSU WRITE(6,*)' ***GEDEPO***: invalid subdetector:',ICURSU STOP * ******************** CENT ****************** 10 IF(CHARGE.EQ.0.)RETURN GOTO(11,12,13,14,14,14,14,15,16),IDTYPE-100 WRITE(6,900)IDTYPE STOP 11 IF(ISGRAN(1).EQ.3)THEN CALL CJHITF ELSE CALL CJHITS ENDIF RETURN 12 CALL USRHIT('CRYT') RETURN 13 CALL USRHIT('CRZT') RETURN 14 CALL USRHIC('CRMT',IDTYPE-104) RETURN 15 CALL USRHIT('CRVT') RETURN 16 CALL USRHIT('BRST') RETURN * ******************** FWDT ****************** 20 IF(CHARGE.EQ.0.)RETURN GOTO(21,22,23),IDTYPE-200 WRITE(6,900)IDTYPE STOP 21 CALL FRHIT RETURN 22 CALL FPHIT RETURN 23 CALL FQHIT RETURN * ******************** CALO ****************** 30 CONTINUE RETURN * ******************** PLUG ****************** 40 CONTINUE RETURN * ******************** BEMC ****************** 50 CONTINUE IF(LCONFG.LE.1) THEN *......................................... configuration of 1992 GOTO (51,52,53,51)IDTYPE-500 WRITE(6,900)IDTYPE 51 CONTINUE RETURN 52 IF(CHARGE.NE.0..AND.INWVOL.EQ.1)CALL BTHIT RETURN 53 IF(CHARGE.NE.0.)CALL USRHIC('BRMT',NUMBV(NVNAME)-1) RETURN ELSE *......................................... upgrade 1995 *>> GOTO (151,151,151,151,154)IDTYPE-500 *>> add BToF for 1995 GOTO (151,70,151,151,154)IDTYPE-500 WRITE(6,900)IDTYPE 151 CONTINUE RETURN 154 IF(CHARGE.NE.0.)CALL HDHIT RETURN ENDIF * ******************** IRON ****************** 60 IF(CHARGE.EQ.0.)RETURN IF(INWVOL.EQ.1)THEN VSPOT(1)=VECT(1) VSPOT(2)=VECT(2) VSPOT(3)=VECT(3) ELSE IF(INWVOL.EQ.2.OR.ISTOP.NE.0)THEN VSPOT(4)=VECT(1) VSPOT(5)=VECT(2) VSPOT(6)=VECT(3) IF(ISRBNK(6).EQ.1) THEN CALL IDEPO(VSPOT,VECT(7)) ENDIF ENDIF RETURN * ******************** FWFE ****************** 70 IF(IDTYPE.EQ.1001 + .OR.IDTYPE.EQ.1101.OR.IDTYPE.EQ.1102 + .OR.IDTYPE.EQ.1005.OR.IDTYPE.EQ.1009 + .OR.IDTYPE.EQ.502.OR.IDTYPE.EQ.1221) THEN * proton tagger or FToF (P.Biddulph) * or Roman pots (H. Mahlke-Krueger) * or BToF for 1995 (V.Shekelyan) * or neutron counter (O.Duenger) * or FTS (V.Solochenko) CALL JHIT RETURN ELSE * forward muon spectrometer IF(CHARGE.EQ.0.) RETURN GOTO(71,72),IDTYPE-700 WRITE(6,900)IDTYPE STOP 71 CALL MTPHIT('MRTT') RETURN 72 CALL MTPHIT('MRPT') RETURN ENDIF * ******************** LUMI ****************** 80 GOTO(81,82,83,84),IDTYPE-800 WRITE(6,900)IDTYPE STOP 81 IFOK=-200 CALL LEHIT(VECT(7),-VECT(1),VECT(2),IFOK) RETURN 82 CALL LPHIT(VECT(7),-VECT(1),VECT(2)) RETURN 83 CALL LVHIT RETURN 84 IFOK=0 c************************************************************ c please note I commented this to get rid of an unresolved to c test the new code. This is NOT for export back into CMZ!! c Girish. c************************************************************ c CALL LE1HIT(VECT(7),-VECT(1),VECT(2),IFOK) RETURN 900 FORMAT(' ***GEDEPO*** illegal IDTYPE:',I5) END *CMZ : 17/11/98 13.07.59 by Girish D. Patel *CMZU: 2.14/02 10/08/93 20.45.43 by Vladimir Shekelyan *CMZU: 2.10/13 13/12/92 20.40.54 by Alexander Fedotov *CMZU: 2.08/04 16/09/92 15.23.26 by Stephan Egli *CMZ : 2.07/00 26/03/92 08.10.40 by Stephan Egli *CMZU: 2.05/02 11/12/91 18.18.49 by Stephan Egli *CMZU: 2.05/00 01/11/91 16.31.18 by Stephan Egli *CMZU: 2.03/00 26/06/91 18.56.01 by Stephan Egli *CMZ : 2.00/00 10/02/91 09.08.52 by Stephan Egli *CMZ : 1.08/02 06/02/91 17.24.01 by Stephan Egli *-- Author : SUBROUTINE GUGEOM *#********************************************************************** *# * *# SUBROUTINE GUGEOM * *# * *# PURPOSE: Define H1 detector geometry and constants * *# * *# CALLED BY : GUINIT * *# * *# AUTHOR : Girish D. Patel * *# * *# CHANGED BY: GIRISH D. PATEL AT: 5/8/89 * *# REASON : CALL TO UDFPAR INSERTED * *# * *# CHANGED BY: S.EGLI AT: 14/12/89 * *# REASON : ORDER THE BEAM PIPE VOLUMES WITH A GSORD CALL * *# * *# CHANGED BY: S.EGLI AT: 09/03/90 * *# REASON : draw stuff removed * *# CHANGED BY: A.Fedotov AT: 01/12/92 (14/07/92) * *# REASON : Geometry definition from OGDJ added * *# CHANGED BY: A.Fedotov AT: 13/12/92 (07/09/92) * *# REASON : Call of JGEOM in muon branch added * * changed by V.Shekelyan at 28.07.93 * * reason: For upgrade 1995 (LCONFG=2) use OGVM,OGVB instead of OGDM,OGDB *#********************************************************************** * *KEEP,H1DETC. PARAMETER (NSUBDE=8) COMMON /H1DETC/ NAMSUB(NSUBDE),ISGRAN(NSUBDE),ISRBNK(NSUBDE), 1 ISDSBK(NSUBDE),ISTRKB(NSUBDE),ISTRKM(NSUBDE), 1 SKECUT(NSUBDE+2) *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,GCFLAG. COMMON/GCFLAG/IDEBUG,IDEMIN,IDEMAX,ITEST,IDRUN,IDEVT,IEORUN + ,IEOTRI,IEVENT,ISWIT(10),IFINIT(20),NEVENT,NRNDM(2) COMMON/GCFLAX/BATCH, NOLOG LOGICAL BATCH, NOLOG C INTEGER IDEBUG,IDEMIN,IDEMAX,ITEST,IDRUN,IDEVT,IEORUN + ,IEOTRI,IEVENT,ISWIT,IFINIT,NEVENT,NRNDM C *KEEP,H1OSGO. COMMON /H1OSGO/ LCONFG,IGEAND(13),RGEANC(16),IGEANP(12) *KEND. * *KEEP,HROTM. PARAMETER ( LHROTM = 17 ) COMMON /HROTM/ NHROT(0:LHROTM) *KEND. * * DEFINE H1 GENERAL MATERIAL CONSTANTS FROM OGMA BOS BANK * CALL UGTBNK( 'OGMA', INDB ) IF( INDB.LE.0 ) THEN WRITE(6,*) ' ** SUBR. GUGEOM ** OGMA BANK NOT FOUND ==> STOP ' STOP ELSE CALL UDFMAT( INDB ) ENDIF * * DEFINE H1 GENERAL TRACKING MEDIA PARAMETERS FROM OGME BOS BANK * CALL UGTBNK( 'OGME', INDB ) IF( INDB.LE.0 ) THEN WRITE(6,*) ' ** SUBR. GUGEOM ** OGME BANK NOT FOUND ==> STOP ' STOP ELSE CALL UDFMED( INDB ) ENDIF * * DEFINE H1 SPECIAL TRACKING MEDIA PARAMETERS FROM OGTP BOS BANK * * CALL UGTBNK( 'OGTP', INDB ) * IF( INDB.LE.0 ) THEN * WRITE(6,*) ' ** SUBR. GUGEOM ** OGTP BANK NOT FOUND ==> ', * + 'Default values will be used' * ELSE * CALL UDFPAR( INDB ) * ENDIF * * * DEFINE GEANT ROTATION MATRICES FROM OGRO BOS BANK * CALL UGTBNK( 'OGRO', INDB ) IF( INDB.LE.0 ) THEN WRITE(6,*) ' ** SUBR. GUGEOM ** OGRO BANK NOT FOUND ==> STOP ' STOP ELSE CALL UDFROT( INDB, NHROT, LHROTM ) ENDIF * * DEFINE GEOMETRY OF THE SET UP FROM OGDM BOS BANK * for upgrade 1995 OGVM bank is used * IF(LCONFG.LE.1)THEN CALL UGTBNK( 'OGDM' , INDB ) ELSE CALL UGTBNK( 'OGVM' , INDB ) ENDIF IF( INDB.LE.0 ) THEN STOP ELSE CALL UDFVOL( INDB, NHROT, LHROTM ) ENDIF * * DEFINE GEOMETRY OF BEAM PIPE SET UP FROM OGDB BOS BANK * for upgrade 1995 OGVB bank is used * IF(LCONFG.LE.1)THEN CALL UGTBNK( 'OGDB' , INDB ) ELSE CALL UGTBNK( 'OGVB' , INDB ) ENDIF IF( INDB.LE.0 ) THEN WRITE(6,*)' ** SUBR.GUGEOM ** OGDB(OGVB) BANK NOT FOUND => STOP' STOP ELSE CALL UDFVOL( INDB, NHROT, LHROTM ) ENDIF * * ORDER THE VOLUMES OF THE BEAM * CALL GSORD('BEAM',3) * * DEFINE GEOMETRY OF FORW. BEAMLINE (IN PLUG,FWFE) FROM OGDJ BOS BANK * c CALL UGTBNK( 'OGDJ' , INDB ) c IF( INDB.LE.0 ) THEN c WRITE(6,*) ' ** SUBR. GUGEOM ** OGDJ BANK NOT FOUND ==> STOP ' c STOP c ELSE c CALL UDFVOL( INDB, NHROT, LHROTM ) c ENDIF * * DEFINE GEOMETRY OF COIL SET UP FROM OGDC BOS BANK * CALL UGTBNK( 'OGDC' , INDB ) IF( INDB.LE.0 ) THEN WRITE(6,*) ' ** SUBR. GUGEOM ** OGDC BANK NOT FOUND ==> STOP ' STOP ELSE IF(ISGRAN(3).NE.0) CALL UDFVOL( INDB, NHROT, LHROTM ) ENDIF * * Central Tracking * IF (ISGRAN(1).NE.0)THEN WRITE(6,900)'CENT',ISGRAN(1) CALL CGEOM ENDIF * * Forward Tracking * IF (ISGRAN(2).NE.0)THEN WRITE(6,900)'FWDT',ISGRAN(2) CALL FGEOM ENDIF * * Liquid Argon Calorimeter * IF (ISGRAN(3).NE.0)THEN WRITE(6,900)'CALO',ISGRAN(3) CALL AGEOM ENDIF * * Plug Calorimeter * IF (ISGRAN(4).NE.0)THEN WRITE(6,900)'PLUG',ISGRAN(4) CALL PGEOM ENDIF * * Backward Electromagnetic Calorimeter * IF (ISGRAN(5).NE.0)THEN IF(LCONFG.LE.1) THEN WRITE(6,900)'BEMC',ISGRAN(5) CALL BGEOM ELSE *.........upgrade 1995 (SPACal,BDC) WRITE(6,900)'SPAC',ISGRAN(5) CALL SGEOM ENDIF ENDIF * * Instrumented Iron * IF (ISGRAN(6).NE.0)THEN WRITE(6,900)'IRON',ISGRAN(6) CALL IGEOM ENDIF * * Forward Muons * and the rest of Forward beam line with p tagger (z = 1177-2442) * IF (ISGRAN(7).NE.0)THEN WRITE(6,900)'MUON',ISGRAN(7) CALL MGEOM CALL JGEOM ENDIF * * Luminosity (proton beam line to -50 meters) * IF (ISGRAN(8).NE.0)THEN WRITE(6,900)'LUMI',ISGRAN(8) CALL LGEOM ENDIF * * Optimisation of geometry definition * * * Close geometry banks. Mandatory system routine. * CALL GGCLOS * CALL BDROP(IW,'OGMAOGMEOGTPOGROOGDMOGDBOGDJOGDC') * 900 FORMAT(' Creating geometry for subdetector ',A4, + ' with granularity flag ',I1) RETURN END *CMZU: 03/08/98 14.03.51 by Stephen Burke *CMZ : 4.06/28 06/12/96 13.44.27 by Vladimir Shekelyan *CMZU: 4.05/02 26/01/95 15.18.17 by Martine Charlet *CMZ : 4.04/05 10/11/94 20.59.30 by Vladimir Shekelyan *CMZU: 4.04/04 01/11/94 13.40.07 by Benno List *CMZU: 4.02/02 23/03/94 12.58.49 by Stephan Egli *CMZU: 4.00/08 08/12/93 16.31.48 by Stephan Egli *CMZU: 4.00/05 22/11/93 14.12.19 by Stephan Egli *CMZU: 3.04/06 13/08/93 09.34.07 by Vladimir Shekelyan *CMZ : 3.01/06 16/09/92 15.57.31 by Stephan Egli *CMZ : 2.09/01 30/03/92 15.11.43 by Michael Colombo *CMZ : 2.08/01 26/03/92 12.05.10 by Stephan Egli *CMZ : 2.07/00 17/12/91 11.29.18 by Stephan Egli *CMZ : 2.03/05 09/09/91 19.19.48 by Stephan Egli *CMZU: 2.03/00 13/06/91 14.04.01 by Michael Kuhlen *CMZU: 2.02/00 07/06/91 14.17.54 by M. Erdmann *CMZ : 2.00/00 10/02/91 09.25.00 by Stephan Egli *CMZ : 1.08/02 05/02/91 11.03.13 by Stephan Egli *-- Author : SUBROUTINE H1PRNT(NAME,NR) ********************************************************************* * * PRINTOUT OF H1 SIMULATION BANK * ============================== * * BANKS INCLUDED UP TO NOW ARE: * * ARHT, AEHT, ARDT, AEDT, ARWT, AEWT, AS , ARCE, AECE, ARCX * * BRMT, BRCT, BRTT, BS , BRME, BRCE, BRTE, BRCX * * CRJT, CRJF, CRYT, CRZT, CRMT, CS , CRJE, CRME, CRYE, CRZE, * CRYX, CRZX * * FRPT, FRPF, FRRT, FRRF, FRMT, FRTT, FS , FRME, FRPE, FRRE, * FRPN, FRRN, FRPH, FRRH, FRPX, FRRX, * FRQT, FRQF, FRQE, FRQN, FRQH, FRQX * * GTR , GVX , GEVC * * IRHT, IS , IL , IRSE, IRTE, IRWE * * JSPT, JSRP, JSFT, JRHT, JRDT, JRDE * * LRET, LRPT, LRVT, LS , LREE, LRPE * * MS , ML * * PRDT, PS , PRDE, PRDX * * SHD , STR , SVX * * MODS, MODI, MODO * * ExEG, ExSG, ExNG, ExFR, ExFX (x=A,B,P,I,W) * * RCLX, ECLX, ECLC * * SRCT, SRCE, SRCX * * 04.04.1990 RALF GERHARDS * * CHANGED 05.04.1990 RG ADD BANKS GHD AND GKI * CHANGED 12.04.1990 RG ADD BANK LRTE * CHANGED 26.04.1990 RG ADD BANKS TRIP, TRAK, CACE, CCEG, * MUON, LTL1, TTSE * CHANGED 02.05.1990 RG ADD BANK HEAD * CALL P.SCHLEPER'S MYPRNT IF BANK * IS NOT KNOWN TO CURRENT BANK LIST * CHANGED 01.07.1990 SE FORWARD MUON BANKS ADDED * MRPE, MRTE, MRPX, MRTX * MRPN, MRPT, MRTN, MRTT * CHANGED 05.07.1990 RG BUG FIXED IN FUNCTION PDGNAM, GOT * SOMETIMES WRONG PARTICLE NAMES * FOR L.AR. BANKS SCALE AND GAIN * FACTORS TAKEN INTO ACCOUNT * CHANGED 05.09.1990 SE MODUL STEERING BANKS MODS/I/O ADDED * CHANGED 16.05.1991 MK perf. energ. (ARHT,PRDT,BRCT,ARWT) * CHANGED 07.06.1991 ME ADD PRINT GEVC BANK * CHANGED 11.06.1991 MK protection against old bank formats * CHANGED 13.06.1991 MK print more bits in ITRHIS * CHANGED 20.08.1991 MK add calibr. energy and cluster banks * CHANGED 12.12.1991 PL new format GTR, GKI, GHD * CHANGED 28.02.1992 PL new printout GTR and GHD * CHANGED 30.03.1992 MCo both parents in GTR * CHANGED 12.08.1993 VSh upgrade 1995: SRCT (Spacal) * CHANGED 24.10.1994 VSh add SRCE,SRCX banks * BL print GHD bank with >1 row, * add JSPT,JSRP,JRHT,JRDT,JRDE banks * CHANGED 1.11.1994 BL add JSFT bank * CHANGED 29.12.1995 GG new printout GKI * CHANGED 29.07.1998 SB add FxQx banks for new planar chambers ********************************************************************* *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/ *KEND. PARAMETER (ISCALA=50,ISCALD=500,NBMAX=124) CHARACTER*4 NAME, BKNAME(NBMAX), CHAINT CHARACTER*10 PTYP(8), PDGNAM*13, VTYP(5) INTEGER BKFORM(NBMAX), ID1(10) COMMON /COTEMP/ID, ID2, ID1 INTEGER IBIT(14) C C.... OUTPUT UNIT C DATA LUN/6/ C DATA BKNAME/'SHD ','STR ','SVX ','GTR ','GVX ','GKI ','GHD ', * 'HEAD','GEVC', * 'CRJT','CRJF','CRYT','CRZT','CRMT','CS ', * 'CRJE','CRME','CRYE','CRZE','CRYX','CRZX','CRJX','CRMX', * 'FRPT','FRPF','FRRT','FRRF','FRMT','FRTT','FS ', * 'FRME','FRPE','FRRE','FRPN','FRRN','FRPH','FRRH', * 'FRPX','FRRX','FRMX', * 'FRQT','FRQF','FRQE','FRQN','FRQH','FRQX', * 'ARHT','AEHT','ARDT','AEDT','ARWT','AEWT','AS ', * 'AECE','AEDE','ARCE','ARDE','ARCX','ATES','ATBE', * 'BRMT','BRCT','BRTT','BS ', * 'BRME','BRCE','BRTE','BRMX','BRCX','BRTX', * 'IRHT','IS ','IL ', * 'IRSE','IRTE','IRWE','IRSX','IRTX','IRWX', * 'JSPT','JSRP','JSFT','JRHT','JRDT','JRDE', * 'LRET','LRPT','LRVT','LS ', * 'LREE','LRPE','LRTE','LREX','LRPX','LRVX', * 'MS ','ML ','MRPE','MRTE','MRPX','MRTX', * 'MRPN','MRPT','MRTN','MRTT', * 'PRDT','PS ','PRDE','PRDX', * 'TRIP','TRAK','CACE','CCEG','MUON', * 'TTSE','LTL1','TEL1', * 'MODS','MODI','MODO','MODC', * 'SRCT','SRCE','SRCX'/ DATA BKFORM/ 1 , 2 , 3 , 4 , 5 ,100 ,100 , * 100 ,100 , * 6 , 7 , 8 , 8 , 9 , 19 , * -23 ,-24 ,-25 ,-23 ,-32 ,-32 ,-32 ,-32 , * 10 , 11 , 6 , 7 , 9 , 10 , 19 , * -24 ,-25 ,-25 , 26 , 26 , 27 , 28 , * -29 ,-29 ,-99 , * 10 , 11 ,-25 , 26 , 27 ,-29 , * -12 ,-12 ,-12 ,-12 ,-12 ,-12 , 19 , * -20 ,-99 ,-20 ,-99 ,-32 ,-43 , -45 , * 9 ,-14 , 15 , 19 , * -24 ,-21 ,-22 ,-99 ,-32 ,-99 , * -16 , 19 , 19 , * -30 ,-31 ,-30 ,-99 ,-99 ,-99 , * 19 , 46 , 46 ,-47 ,-47 ,-48 , * -17 ,-17 ,-18 , 19 , * -21 ,-21 ,-34 ,-99 ,-99 ,-99 , * 19 , 19 ,-25 ,-25 ,-29 ,-29 , * 26 , 10 , 26 , 10 , * -13 , 19 ,-21 ,-32 , * 35 , 35 , 36 , 36 , 37 , * 38 ,-34 , 44 , * 39 , 40 , 40 ,41 , * -42 ,-20 ,-32/ C DATA PTYP /' undecayed',' reserved','decay/frag',' document.', * ' reserved',' undefined','beam part.','rad. gamma'/ C DATA VTYP /' primary',' decay',' bremsstr.', * 'conversion',' else'/ C C.... STATEMENT FUNCTIONS C C.... INDEX OF ELEMENT BEFORE ROW NUMBER IROW INDR(IND,IROW)=IND+2+IW(IND+1)*(IROW-1) C.... INDEX OF L-TH ELEMENT OF ROW NUMBER IROW INDCR(IND,L,IROW)=INDR(IND,IROW)+L C.... L-TH INTEGER ELEMENT OF THE IROW-TH ROW IN BANK WITH INDEX IND IBTAB(IND,L,IROW)=IW(INDCR(IND,L,IROW)) C.... L-TH REAL ELEMENT OF THE IROW-TH ROW IN BANK WITH INDEX IND RBTAB(IND,L,IROW)=RW(INDCR(IND,L,IROW)) C C.... STATEMENT FUNCTIONS FOR IRON HIT BANK DECODING C FX(I)=FLOAT(I)/20.-600. FY(I)=FLOAT(I)/20.-600. FZ(I)=FLOAT(I)/20.-500. C C.... STATEMENT FUNCTIONS FOR LUMI HIT BANK DECODING C FL(I)=FLOAT(I)*0.001-10. C C.... INITIALIZE LUND COMMONS WITH PARTICLE NAMES C C.... END OF INITIALISATION C C first deal with calibrated energy banks etc. IF( NAME.EQ.'EAEG' .OR. NAME.EQ.'EASG' .OR. NAME.EQ.'EANG' .OR. & NAME.EQ.'EAFR' .OR. NAME.EQ.'EAFX' .OR. & NAME.EQ.'EBEG' .OR. NAME.EQ.'EBSG' .OR. NAME.EQ.'EBNG' .OR. & NAME.EQ.'EBFR' .OR. NAME.EQ.'EBFX' .OR. & NAME.EQ.'EPEG' .OR. NAME.EQ.'EPSG' .OR. NAME.EQ.'EPNG' .OR. & NAME.EQ.'EPFR' .OR. NAME.EQ.'EPFX' .OR. & NAME.EQ.'EIEG' .OR. NAME.EQ.'EISG' .OR. NAME.EQ.'EING' .OR. & NAME.EQ.'EIFR' .OR. NAME.EQ.'EIFX' .OR. & NAME.EQ.'EWEG' .OR. NAME.EQ.'EWSG' .OR. NAME.EQ.'EWNG' .OR. & NAME.EQ.'EWFR' .OR. NAME.EQ.'EWFX') THEN CALL PREXEG(NAME,NR) RETURN ELSEIF( NAME.EQ.'RCLX' .OR. NAME.EQ.'ECLX' ) THEN CALL PRRCLX(NAME,NR) RETURN ELSEIF( NAME.EQ.'ECLC' ) THEN CALL PRECLC(NAME,NR) RETURN ENDIF C.... SEARCH FOR REQUIRED BANK C IBKFMT = 0 DO 10 I = 1, NBMAX IF(NAME.NE.BKNAME(I)) GOTO 10 IBKFMT = BKFORM(I) GOTO 20 10 CONTINUE GOTO 9010 C 20 CONTINUE C C.... FETCH REQUIRED BANK C.... COPY TO WORK BANK IF FORMAT 'B16' C IND = NLINK(NAME,NR) IF(IND.EQ.0) GOTO 9000 C IF(IBKFMT.LT.0) THEN ID=0 CALL BKTOW(IW,NAME,NR,IW,ID,*9000) NROW = IW(ID+2) NCOL = IW(ID+1) NLEN = IW(ID) WRITE(LUN,1300) NAME, NR, NLEN, NCOL, NROW ELSE C C....... SPECIAL FORMATS (WITHOUT MINIHEADER) C IF(IBKFMT.GE.100) THEN WRITE(LUN,1900) NAME, NR GOTO 500 ELSE NCOL = IW(IND+1) NROW = IW(IND+2) NLEN = IW(IND) WRITE(LUN,1300) NAME, NR, NLEN, NCOL, NROW END IF END IF C C.... CHECK ON BANK LENGTH C NTEST=NCOL*NROW+2 IF(NTEST.NE.NLEN .AND. NTEST.NE.NLEN-1) THEN WRITE(LUN,1500) WRITE(LUN,1400) END IF C C.... PRINTOUT C GOTO (101,102,103,104,105,106,107,108,109,110,111,112,113, * 114,115,116,117,118,119,120,121,122,123,124,125,126, * 127,128,129,130,131,132,133,134,135,136,137,138,139, * 140,141,142,143,144,145,146,147,148) * IABS(IBKFMT) C WRITE(LUN,1200) NAME WRITE(LUN,1400) RETURN C C.... 'SHD ' C 101 WRITE(LUN,1400) WRITE(LUN,10101) (CHAINT(IBTAB(IND,1,I)), * RBTAB(IND,2,I), I=1,NROW) 10101 FORMAT(/,((7X,'MODULE NAME ',A4,' VERSION NUMBER ', * F6.4,/)),1H+) GOTO 200 C C.... 'STR ' C 102 WRITE(LUN,1400) WRITE(LUN,10201) WRITE(LUN,10202) (I,RBTAB(IND,1,I), RBTAB(IND,2,I), * RBTAB(IND,3,I), RBTAB(IND,4,I), * PDGNAM(IBTAB(IND,5,I)), IDUAL(IBTAB(IND,6,I),7), * IBTAB(IND,7,I), IBTAB(IND,8,I), IBTAB(IND,9,I), * I=1, NROW) 10201 FORMAT(9X,' MOMENTUM (GEV) ENERGY ', * ' PARTICLE TYPE ITRHIS LINK TO LINK TO ', * ' LINK TO ',/, * 9X,' PX PY PZ (GEV) ', * ' LMIBPAFC PARENT,STR PARENT,GTR ', * ' VERTEX,SVX',/,1X,130('-'),/) 10202 FORMAT((3X,I3,2X,4(1X,F10.3),2X,A13,2X,I8,3(I10,2X))) GOTO 200 C C.... 'SVX ' C 103 WRITE(LUN,1400) WRITE(LUN,10301) WRITE(LUN,10302) (I,RBTAB(IND,1,I), RBTAB(IND,2,I), * RBTAB(IND,3,I), * VTYP(IBTAB(IND,4,I)), (1.0E+09*RBTAB(IND,5,I)), * IDUAL(IBTAB(IND,6,I),7), IBTAB(IND,7,I), I=1 ,NROW) 10301 FORMAT(9X,' VERTEX COORDINATES (CM) VERTEX', * ' TIME OF ITRHIS LINK TO ',/, * 9X,' X Y Z TYPE ', * ' FLIGHT (NS) LMIBPAFC PARENT,STR',/, * 1X,130('-'),/) 10302 FORMAT((3X,I3,2X,3(1X,F10.3),1X,A,1X,F10.3,5X,I8,5X,I6)) GOTO 200 C C.... 'GTR ' C 104 WRITE(LUN,1400) WRITE(LUN,10401) DO 10410 I = 1, NROW IPATYP = ABS( 1+IBTAB(IND,8,I) ) IF( IPATYP-1 .GT. 3 .AND. IPATYP .LE. 10 ) IPATYP = 5 IF( IPATYP-1 .GT. 10 .AND. IPATYP .LE. 200 ) IPATYP = 6 IF( IPATYP-1 .EQ. 201 ) IPATYP = 7 IF( IPATYP-1 .EQ. 202 ) IPATYP = 8 IMOTH1 = IBTAB(IND,9,I)-(IBTAB(IND,9,I)/10000)*10000 IMOTH2 = IBTAB(IND,9,I)/10000 WRITE(LUN,10402) I, PDGNAM(IBTAB(IND,7,I)), PTYP(IPATYP), * IMOTH1, IMOTH2, RBTAB(IND,1,I), RBTAB(IND,2,I), * RBTAB(IND,3,I), RBTAB(IND,4,I), RBTAB(IND,5,I), * RBTAB(IND,6,I), IBTAB(IND,10,I) 10410 CONTINUE 10401 FORMAT(2X,' PARTICLE PARTICLE PARENT ', * ' MOMENTUM (GEV) ENERGY ', * ' MASS CHARGE LINK TO ',/, * 2X,' TYPE FLAG PARTICLE ', * ' PX PY PZ (GEV) ', * ' (GEV) VERTEX,GVX ',/,1X,130('-'),/) 10402 FORMAT((1X, I3, 2X, A12, A10, 2(1X,I3), 4(1X,F9.3), * 2(1X,F10.4), 2X, I5)) GOTO 200 C C.... 'GVX ' C 105 WRITE(LUN,1400) WRITE(LUN,10501) WRITE(LUN,10502) (I,RBTAB(IND,1,I), RBTAB(IND,2,I), * RBTAB(IND,3,I), VTYP(IBTAB(IND,4,I)), * (1.0E+09*RBTAB(IND, 5,I)), I=1, NROW) 10501 FORMAT(9X,' VERTEX COORDINATES (CM) VERTEX', * ' TIME OF ',/, * 9X,' X Y Z TYPE', * ' FLIGHT (NS)',/,1X,130('-'),/) 10502 FORMAT((3X,I3,2X,3(1X,F10.3),1X,A10,1X,F10.3)) GOTO 200 C C.... 'CRJT', 'FRRT' C 106 WRITE(LUN,1400) WRITE(LUN,10601) WRITE(LUN,10602) (I,IBTAB(IND,1,I), RBTAB(IND,2,I), * RBTAB(IND,3,I), * RBTAB(IND,4,I), RBTAB(IND,5,I), RBTAB(IND,6,I), * RBTAB(IND,7,I), RBTAB(IND,8,I), IDUAL(IBTAB(IND,9,I),7), * IBTAB(IND,10,I), I=1, NROW) 10601 FORMAT(1H0,8X,' CHANNEL ENTRY POINT (CM) ', * ' EXIT POINT (CM) DRIFT ', * ' ITRHIS TRACK ',/, * 9X,' NUMBER X Y Z ', * ' X Y Z LENGTH (CM)', * ' LMIBPAFC NUMBER,STR',/,1X,130('-'),/) 10602 FORMAT((2X,I4,3X,I7,3X,7(1X,F10.3),4X,I8,2X,I8)) GOTO 200 C C.... 'CRJF', 'FRRF' C 107 WRITE(LUN,1400) WRITE(LUN,10701) WRITE(LUN,10702) (I,RBTAB(IND,1,I), RBTAB(IND,2,I), * RBTAB(IND,3,I), * RBTAB(IND,4,I), RBTAB(IND,5,I), RBTAB(IND,6,I), * RBTAB(IND,7,I), RBTAB(IND,8,I), RBTAB(IND,9,I), * RBTAB(IND,10,I), RBTAB(IND,11,I), RBTAB(IND,12,I), * RBTAB(IND,13,I), RBTAB(IND,14,I), * PDGNAM(IBTAB(IND,15,I)), * IDUAL(IBTAB(IND,16,I),7), IBTAB(IND,17,I), I=1, NROW) 10701 FORMAT(7X,' ENTRY POINT (CM) ', * ' ENTRY MOMENTUM (GEV) ', * ' EXIT POINT (CM) ', * ' EXIT MOMENTUM (GEV) ', * ' PARTICLE ITRHIS TRACK',/, * 7X,' X Y Z ', * ' PX/P PY/P PZ/P P ', * ' X Y Z ', * ' PX/P PY/P PZ/P P ', * ' type LMIBPAFC NO.',/,1X,130('-'),/) 10702 FORMAT((2X,I4,14(F7.2),1X,A13,I8,I5)) GOTO 200 C C.... 'CRYT', 'CRZT' C 108 WRITE(LUN,1400) WRITE(LUN,10801) WRITE(LUN,10802) (I,RBTAB(IND,1,I), RBTAB(IND,2,I), * RBTAB(IND,3,I), * RBTAB(IND,4,I), RBTAB(IND,5,I), RBTAB(IND,6,I), * IDUAL(IBTAB(IND,7,I),7), IBTAB(IND,8,I), I=1, NROW) 10801 FORMAT(9X,' ENTRY POINT (CM) ', * ' EXIT POINT (CM) ', * ' ITRHIS TRACK ',/, * 9X,' X Y Z ', * ' X Y Z ', * ' LMIBPAFC NUMBER,STR',/,1X,130('-'),/) 10802 FORMAT((2X,I4,2X,6(1X,F10.3),2X,I8,6X,I5)) GOTO 200 C C.... 'CRMT', 'FRMT', 'BRMT' C 109 WRITE(LUN,1400) WRITE(LUN,10901) WRITE(LUN,10902) (I,IBTAB(IND,1,I), RBTAB(IND,2,I), * RBTAB(IND,3,I), * RBTAB(IND,4,I), RBTAB(IND,5,I), RBTAB(IND,6,I), * RBTAB(IND,7,I), IDUAL(IBTAB(IND,8,I),7), IBTAB(IND,9,I), * I=1, NROW) 10901 FORMAT(9X,' CHAMBER ENTRY POINT (CM) ', * ' EXIT POINT (CM) ', * ' ITRHIS TRACK ',/, * 9X,' NUMBER X Y Z ', * ' X Y Z ', * ' LMIBPAFC NUMBER,STR',/,1X,130('-'),/) 10902 FORMAT((2X,I4,3X,I7,3X,6(1X,F10.3),1X,I8,5X,I5)) GOTO 200 C C.... 'FRPT', 'FRTT', 'MRPT', 'MRTT' C 110 WRITE(LUN,1400) WRITE(LUN,11001) WRITE(LUN,11002) (I, IBTAB(IND,1,I), RBTAB(IND,2,I), * RBTAB(IND,3,I), * RBTAB(IND,4,I), RBTAB(IND,5,I),RBTAB(IND,6,I), * RBTAB(IND,7,I), (RBTAB(IND,8,I)*1000.), * IDUAL(IBTAB(IND,9,I),7), * IBTAB(IND,10,I), I=1, NROW) 11001 FORMAT(9X,' CELL ENTRY POINT (CM) ', * ' EXIT POINT (CM) ENERGY ', * ' ITRHIS TRACK ',/, * 9X,' NUMBER X Y Z ', * ' X Y Z LOSS (MEV) ', * ' LMIBPAFC NUMBER,STR',/,1X,130('-'),/) 11002 FORMAT((2X,I4,3X,I8,2X,6(1X,F10.3),1X,F10.5,5X,I8,2X,I8)) GOTO 200 C C.... 'FRPF' C 111 WRITE(LUN,1400) WRITE(LUN,11101) WRITE(LUN,11102) (I, RBTAB(IND,1,I), RBTAB(IND,2,I), * RBTAB(IND,3,I), * RBTAB(IND,4,I), RBTAB(IND,5,I), RBTAB(IND,6,I), * RBTAB(IND,7,I), RBTAB(IND,8,I), RBTAB(IND,9,I), * RBTAB(IND,10,I), RBTAB(IND,11,I), RBTAB(IND,12,I), * RBTAB(IND,13,I), RBTAB(IND,14,I), * PDGNAM(IBTAB(IND,15,I)), * IBTAB(IND,16,I), IDUAL(IBTAB(IND,17,I),7), IBTAB(IND,18,I), * I=1, NROW) 11101 FORMAT(7X,' ENTRY POINT (CM) ', * ' ENTRY MOMENTUM (GEV) ', * ' EXIT POINT (CM) ', * ' EXIT MOMENTUM (GEV) ', * ' PARTICLE CELL ITRHIS TRACK',/, * 7X,' X Y Z ', * ' PX/P PY/P PZ/P P ', * ' X Y Z ', * ' PX/P PY/P PZ/P P ', * ' TYPE NUMB LMIBPAFC NO.',/, * 1X,130('-'),/) 11102 FORMAT((2X,I4,3F7.2,3F6.2,4F7.2,3F6.2,F7.2,1X,A13,I5,1X,I8,I5)) GOTO 200 C C.... 'ARHT' ('AEHT'), 'ARDT' ('AEDT'), 'ARWT' ('AEWT') C FETCH PARALLEL BANKS C 112 CONTINUE ID2=0 IF(NAME.EQ.'ARHT')THEN CALL BKTOW(IW,'AEHT',0,IW,ID2,*9020) WRITE(LUN,1800) 'AEHT' ELSE IF(NAME.EQ.'ARDT') THEN CALL BKTOW(IW,'AEDT',0,IW,ID2,*9020) WRITE(LUN,1800) 'AEDT' ELSE IF(NAME.EQ.'ARWT') THEN CALL BKTOW(IW,'AEWT',0,IW,ID2,*9020) WRITE(LUN,1800) 'AEWT' ENDIF C IF(NAME.EQ.'AEHT') THEN WRITE(LUN,1800) 'AEHT' GOTO 200 ELSE IF(NAME.EQ.'AEDT') THEN WRITE(LUN,1800) 'AEDT' GOTO 200 ELSE IF(NAME.EQ.'AEWT') THEN WRITE(LUN,1800) 'AEWT' GOTO 200 ENDIF C WRITE(LUN,1400) WRITE(LUN,11201) DO 11200 I = 1, NROW ITRHIS = IBTAB(ID,3,I) CALL IDUAL1( ITRHIS, 14, 1, IBIT ) IENER = IFRB16(IBTAB(ID,2,I)) IENERE = IFRB16(IBTAB(ID2,1,I)) IF( NCOL.GE.6 ) THEN IEINV = IFRB16(IBTAB(ID,5,I))*ISCALD IEEM = IFRB16(IBTAB(ID,6,I))*ISCALD ELSE IEINV = 0 IEEM = 0 ENDIF IF(NAME.EQ.'ARWT') THEN IENER = IENER*ISCALD IENERE = IENERE*ISCALD CALL NWSOFT(IBTAB(ID,1,I),MM,NN,LL,II,JJ,KK,IFL) WRITE(LUN,11202) I, IBTAB(ID,1,I), MM, NN, LL, II, * JJ, KK, FLOAT(IENER)/1.E3, * IBIT,IBTAB(ID,4,I),FLOAT(IENERE)/1.E3, * FLOAT(IEINV)/1.E3, FLOAT(IEEM)/1.E3 ELSE IENER = IENER*ISCALA IENERE = IENERE*ISCALA IF( NCOL.GE.8 ) THEN IEHAD = IFRB16(IBTAB(ID,7,I))*ISCALD IEHVIS = IFRB16(IBTAB(ID,8,I))*ISCALD ELSE IEHAD = 0 IEHVIS= 0 ENDIF CALL NBSOFT(IBTAB(ID,1,I),MM,NN,LL,II,JJ,KK,IFL) WRITE(LUN,11202) I, IBTAB(ID,1,I), MM, NN, LL, II, * JJ, KK, FLOAT(IENER)/1.E3, * IBIT,IBTAB(ID,4,I),FLOAT(IENERE)/1.E3, * FLOAT(IEINV)/1.E3, FLOAT(IEEM)/1.E3, * FLOAT(IEHAD)/1.E3, FLOAT(IEHVIS)/1.E3 END IF 11200 CONTINUE 11201 FORMAT(6X,' CHANNEL NUMBER ENERGY', * ' ITRHIS TRACK ', * 'ELECTROMAGNETIC PERFECT ENERGIES (MeV)',/, * 6X,' CONT MM NN LL II JJ KK (MEV) ', * ' LMIBPAFC NUMBER ', * 'ENERGY (MEV) ', * ' Einv',' Eem',' Ehad',' Ehavis' * /,1X,130('-'),/) 11202 FORMAT((2X,I4,I7,1X,6I4,3X,F7.2,1X,3X,14I1,I7,3X,F10.2,6x,4F9.1)) C C.... DROP WORK BANK C CALL WDROP(IW,ID2) GOTO 200 C C.... 'PRDT' C 113 WRITE(LUN,1400) WRITE(LUN,11301) DO 1023 I = 1, NROW ITRHIS = IBTAB(ID,3,I) CALL IDUAL1( ITRHIS, 14, 1, IBIT ) IF( NCOL.GE.8 ) THEN IEINV = IFRB16(IBTAB(ID,5,I))*ISCALD IEEM = IFRB16(IBTAB(ID,6,I))*ISCALD IEHAD = IFRB16(IBTAB(ID,7,I))*ISCALD IEHVIS= IFRB16(IBTAB(ID,8,I))*ISCALD ELSE IEINV = 0 IEEM = 0 IEHAD = 0 IEHVIS= 0 ENDIF WRITE(LUN,11302) I,IBTAB(ID,1,I), IFRB16(IBTAB(ID,2,I)), * IBIT, IBTAB(ID,4,I), * FLOAT( IEINV )/1000., * FLOAT( IEEM )/1000., * FLOAT( IEHAD )/1000., * FLOAT( IEHVIS)/1000. 1023 CONTINUE 11301 FORMAT(1H0,8X,' CHAMBER ENERGY', * ' ITRHIS TRACK ', * ' perfect energies (MeV) ',/, * 9X,' NUMBER LMIBPAFC NUMBER ', * ' Einv',' Eem',' Ehad',' Ehavis',/, * 1X,130('-'),/) 11302 FORMAT((2X,I4,3X,I7,4X,I7,3X,3X,14I1,3X,I7,3X,4F9.1)) GOTO 200 C C.... 'BRCT' C 114 WRITE(LUN,1400) WRITE(LUN,11401) DO 1024 I = 1, NROW ITRHIS = IBTAB(ID,16,I) CALL IDUAL1( ITRHIS, 14, 1, IBIT ) WRITE(LUN,11402) I, IBTAB(ID,1,I), IFRB16(IBTAB(ID,2,I)), * IFRB16(IBTAB(ID,3,I)),IFRB16(IBTAB(ID,4,I)), * IFRB16(IBTAB(ID,5,I)),IFRB16(IBTAB(ID,6,I)), * IFRB16(IBTAB(ID,7,I)),IFRB16(IBTAB(ID,8,I)), * IFRB16(IBTAB(ID,9,I)), * IBTAB(ID,10,I)-1000, IBTAB(ID,11,I)-1000, * IBTAB(ID,12,I)-3000, IBTAB(ID,13,I)-1000, * IBTAB(ID,14,I)-1000, IBTAB(ID,15,I)-3000, * IBIT, IBTAB(ID,17,I) 1024 CONTINUE 11401 FORMAT(6X,' STACK ', * ' ENERG. FR. 6 WAVEL SHIFT (MEV)', * ' ENERGIES CENT. OF GRAV. (MM)', * ' C.O.G. HADRONS ', * ' ITRHIS TRACK',/, * 6X,'NUMBER ', * ' 1 2 3 4 5 6 ', * ' TOTAL HADR. X+XOFF Y+YOFF Z+ZOFF', * ' X+XOFF Y+YOFF Z+ZOFF', * ' LMIBPAFC NO.',/, * 1X,130('-'),/) 11402 FORMAT((1X,I4,I5,1X,6I5,3X,I5,I6,3X,6I7,3X,14I1,I4)) IF( NCOL.GE.21 ) THEN WRITE(LUN,11403) WRITE(LUN,11404)(I, * FLOAT( IFRB16(IBTAB(ID,18,I))*ISCALD )/1000., * FLOAT( IFRB16(IBTAB(ID,19,I))*ISCALD )/1000., * FLOAT( IFRB16(IBTAB(ID,20,I))*ISCALD )/1000., * FLOAT( IFRB16(IBTAB(ID,21,I))*ISCALD )/1000., * I=1,NROW ) ENDIF 11403 FORMAT(1H0,4X, * ' perfect energies (MeV) ',/, * 5X,' Einv',' Eem',' Ehad',' Ehavis',/, * 1X,130('-'),/) 11404 FORMAT((1X,I4,4F9.1)) GOTO 200 C C.... 'BRTT' C 115 WRITE(LUN,1400) WRITE(LUN,11501) WRITE(LUN,11502) (I, RBTAB(IND,1,I), RBTAB(IND,2,I), * RBTAB(IND,3,I), * RBTAB(IND,4,I), RBTAB(IND,5,I), RBTAB(IND,6,I), * RBTAB(IND,7,I), (1.0E+09*RBTAB(IND,8,I)), * IDUAL(IBTAB(IND,9,I),7), * IBTAB(IND,10,I), I=1, NROW) 11501 FORMAT(9X,' COORDINATES (CM) ', * ' MOMENTUM (GEV) ', * ' TIME OF ITRHIS TRACK ',/, * 9X,' X Y Z ', * ' PX/P PY/P PZ/P P ', * ' FLIGHT (NS) LMIBPAFC NUMBER ',/,1X,130('-'),/) 11502 FORMAT((2X,I4,3X,8(F10.3,1X),4X,2I8)) GOTO 200 C C.... 'IRHT' C 116 WRITE(LUN,1400) WRITE(LUN,11601) 11601 FORMAT(9X,' ENTRY POINT ( CM ) ', * ' EXIT POINT ( CM ) MOMENTUM ', * 'PARTICLE TYPE ITRHIS TRACK ',/, * 9X,' X Y Z ', * ' X Y Z (MEV) ', * ' LMIBPAFC NUMBER ',/,1X,130('-'),/) WRITE(LUN,11602) (I, FX(IBTAB(ID,1,I)), FY(IBTAB(ID,2,I)), * FZ(IBTAB(ID,3,I)), FX(IBTAB(ID,4,I)), FY(IBTAB(ID,5,I)), * FZ(IBTAB(ID,6,I)), IBTAB(ID,7,I), * PDGNAM(IBTAB(ID,8,I)-10000), IDUAL(IBTAB(ID,9,I),7), * IBTAB(ID,10,I), I=1, NROW) 11602 FORMAT((2X,I4,3X,6(F10.2,1X),I10,2X,A13,2X,2I8)) GOTO 200 C C.... 'LRET', 'LRPT' C 117 WRITE(LUN,1400) WRITE(LUN,11701) WRITE(LUN,11702) (I, FL(IBTAB(ID,1,I)), FL(IBTAB(ID,2,I)), * IBTAB(ID,3,I), PDGNAM(IBTAB(ID,4,I)-10000), * IDUAL(IBTAB(ID, 5,I),7), IBTAB(ID, 6,I), I=1, NROW) 11701 FORMAT(9X,' ENTRY POINT ( CM ) MOMENTUM ', * ' PARTICLE TYPE ITRHIS TRACK ',/, * 9X,' X Y (MEV) ', * ' LMIBPAFC NUMBER ',/,1X,130('-'),/) 11702 FORMAT((2X,I4,3X,2(F10.3,1X),I10,4X,A13,2X,2I8)) GOTO 200 C C.... 'LRVT' C 118 WRITE(LUN,1400) WRITE(LUN,11801) WRITE(LUN,11802) (I, IBTAB(ID,1,I), IBTAB(ID,2,I), * IDUAL(IBTAB(ID,3,I),7), IBTAB(ID,4,I), I=1, NROW) 11801 FORMAT(9X,' NUMBER OF RANGE ', * ' ITRHIS TRACK ',/, * 9X,' MINIHITS (MM) ', * ' LMIBPAFC NUMBER ',/,1X,130('-'),/) 11802 FORMAT((2X,I4,3X,I6,5X,I8,5X,2I8)) GOTO 200 C C.... STARTING AND LEAVING BANKS AT SUBDETECTOR BOUNDARIES C 119 WRITE(LUN,1400) WRITE(LUN,11901) WRITE(LUN,11902) (I, RBTAB(IND,1,I), RBTAB(IND,2,I), * RBTAB(IND,3,I), PDGNAM(IBTAB(IND,4,I)), RBTAB(IND,5,I), * RBTAB(IND,6,I), RBTAB(IND,7,I), (1.0E+09*RBTAB(IND,8,I)), * IDUAL(IBTAB(IND,9,I),7), IBTAB(IND,10,I), I=1, NROW) 11901 FORMAT(9X,' MOMENTUM (GEV) PARTICLE ', * 'TYPE COORD. AT ENTRY/EXIT POINT (CM) TIME OF ', * ' ITRHIS TRACK ',/, * 9X,' PX PY PZ ', * ' X Y Z FLIGHT (NS)', * ' LMIBPAFC NUMBER ',/,1X,130('-'),/) 11902 FORMAT((2X,I4,2X,3(1X,F10.3),1X,A13,3(1X,F10.3), * 3X,F10.3,5X,2I8)) GOTO 200 C C.... 'ARCE' ('AECE', 'ARDE', 'AEDE'), 'SRCE' C FETCH PARALLEL BANKS C 120 CONTINUE CALL VZERO(ID1,10) IF(NAME.EQ.'ARCE') THEN CALL BKTOW(IW,'AECE',0,IW,ID1(1),*12006) WRITE(LUN,1800) 'AECE' C DO 12000 I = 1, 4 C CALL BKTOW(IW,'ARDE',I,IW,ID1(I+1),*9020) C CALL BKTOW(IW,'AEDE',I,IW,ID1(I+5),*9020) 12000 CONTINUE C WRITE(LUN,1800) 'ARDE' C WRITE(LUN,1800) 'AEDE' ELSE IF(NAME.NE.'SRCE') THEN WRITE(LUN,1800) NAME GOTO 200 ENDIF C WRITE(LUN,1400) WRITE(LUN,12002) ISUM1 = 0 ISUM2 = 0 DO 12001 I = 1, NROW IENER = IFRB16(IBTAB(ID,2,I)) IENERE = IFRB16(IBTAB(ID1(1),1,I)) IENER = IENER*ISCALA IENERE = IENERE*ISCALA IF(NAME.EQ.'SRCE') THEN IENER = IFRB16(IBTAB(ID,2,I)) IENERE = 0. IENER = IENER*ISCALA IENERE = 0. CALL NSSOFT(IBTAB(ID,1,I),NN,LL,II,JJ,IFL) MM = 9 KK = 0 ENDIF ISUM1 = ISUM1 + IENER ISUM2 = ISUM2 + IENERE WRITE(LUN,12003) I, IBTAB(ID,1,I), MM, NN, LL, II, * JJ, KK, FLOAT(IENER)*1.E-3, FLOAT(IENERE)*1.E-3 12001 CONTINUE WRITE(LUN,12004) FLOAT(ISUM1)*1.E-3, FLOAT(ISUM2)*1.E-3 12002 FORMAT(9X,' CHANNEL NUMBER ENERGY ', * 10X,'ELECTROMAGNETIC ',/, * 9X,' CONT MM NN LL II JJ KK (MEV) ', * 10X,'ENERGY (MEV) ',/,1X,130('-'),/) 12003 FORMAT((2X,I4,3X,I7,1X,6I4,2X,F10.2,12X,F10.2)) 12004 FORMAT(1H0,'TOTAL ENERGY',30X,F10.2,12X,F10.2) C C.... DROP WORK BANK C DO 12005 I = 1, 1 CALL WDROP(IW,ID1(I)) 12005 CONTINUE GOTO 200 C 12006 CONTINUE WRITE(LUN,1400) WRITE(LUN,12007) WRITE(LUN,12008) (I,IBTAB(ID,1,I), IBTAB(ID,2,I), * I=1, NROW) 12007 FORMAT(9X,' CHANNEL ENERGY ',18X,' CHANNEL ENERGY ', * 18X,' CHANNEL ENERGY ',/, * 9X,' NUMBER DEPOSIT ',18X,' NUMBER DEPOSIT ', * 18X,' NUMBER DEPOSIT ',/, * 1X,130('-'),/) 12008 FORMAT((1X,3(I6,2X,2(I8,2X),10X))) GOTO 200 C C.... 'BRCE' 'PRDE', 'LREE', 'LRPE' C 121 CONTINUE IF(NAME.EQ.'PRDE')THEN ISFAC=10 ELSE ISFAC=1000 ENDIF WRITE(LUN,1400) WRITE(LUN,12101) WRITE(LUN,12102) (I, IBTAB(ID,1,I), IFRB16(IBTAB(ID,2,I))*ISFAC, * I=1, NROW) 12101 FORMAT(9X,' CHANNEL ENERGY ',18X,' CHANNEL ENERGY ', * 18X,' CHANNEL ENERGY ',/, * 9X,' NUMBER (KEV) ',18X,' NUMBER (KEV) ', * 18X,' NUMBER (KEV) ',/, * 1X,130('-'),/) 12102 FORMAT((1X,3(I6,2X,2(I8,2X),10X))) GOTO 200 C C.... 'BRTE' C 122 CONTINUE WRITE(LUN,1400) WRITE(LUN,12201) WRITE(LUN,12202) (I, IBTAB(ID,1,I), IBTAB(ID,2,I), I=1, NROW) 12201 FORMAT(9X,' CHANNEL TOF HIT ',18X,' CHANNEL TOF HIT ', * 18X,' CHANNEL TOF HIT ',/, * 9X,' NUMBER ',18X,' NUMBER ', * 18X,' NUMBER ',/, * 1X,130('-'),/) 12202 FORMAT((1X,3(I6,2X,2(I8,2X),10X))) GOTO 200 C C.... 'CRJE', 'CRZE' C 123 CONTINUE WRITE(LUN,1400) WRITE(LUN,12301) WRITE(LUN,12302) (I, IBTAB(ID,1,I), FLOAT(IBTAB(ID,2,I))/100., * IBTAB(ID,3,I), IBTAB(ID,4,I), IBTAB(ID,5,I), * IBTAB(ID,6,I), I=1, NROW) 12301 FORMAT(9X,' WIRE DRIFT CHARGE ', * ' FLAG 1 FLAG 2 ',/, * 9X,' NUMBER LENGTH (MM) + SIDE - SIDE ', * ' ',/,1X,130('-'),/) 12302 FORMAT((2X,I4,3X,I8,3X,F8.2,2X,4(I8,2X))) GOTO 200 C C.... 'CRME', 'FRME', 'BRME' C 124 CONTINUE WRITE(LUN,1400) WRITE(LUN,12401) WRITE(LUN,12402) (I, IBTAB(ID,1,I), I=1, NROW) 12401 FORMAT(9X,' CHANNEL ',18X,' CHANNEL ',18X,' CHANNEL ', * 18X,' CHANNEL ',/, * 9X,' NUMBER ',18X,' NUMBER ',18X,' NUMBER ', * 18X,' NUMBER ',/,1X,130('-'),/) 12402 FORMAT((1X,4(I6,2X,I8,12X))) GOTO 200 C C.... 'CRYE', 'FRPE', 'FRRE', 'MRPE', 'MRTE' C 125 CONTINUE ICONV = 40 IF(NAME.EQ.'CRYE') ICONV = 200 WRITE(LUN,1400) WRITE(LUN,12501) WRITE(LUN,12502) (I, IBTAB(ID,1,I), IBTAB(ID,2,I)*ICONV, * IBTAB(ID,3,I), IBTAB(ID,4,I), IBTAB(ID,5,I), * IBTAB(ID,6,I), I=1, NROW) 12501 FORMAT(9X,' WIRE DRIFT TIME CHARGE ', * ' FLAG 1 FLAG 2 ',/, * 9X,' NUMBER (PS) + SIDE - SIDE ', * ' ',/,1X,130('-'),/) 12502 FORMAT((2X,I4,3X,6(I8,2X))) GOTO 200 C C.... 'FRPN', 'FRRN', 'MRPN', 'MRTN' C 126 CONTINUE WRITE(LUN,1400) WRITE(LUN,12601) WRITE(LUN,12602) (I, IBTAB(IND,1,I), RBTAB(ID,2,I), * IBTAB(IND,3,I), IBTAB(IND,4,I), * RBTAB(IND,5,I), I=1, NROW) 12601 FORMAT(1H0,8X,' CELL ', * ' COORDINATES OF NOISE HITS ENERGY ',/, * 9X,' NUMBER ', * ' X Y Z DEPOSIT ',/, * 1X,130('-'),/) 12602 FORMAT((2X,I4,3X,I8,4F10.3)) GOTO 200 C C.... 'FRPH' C 127 CONTINUE WRITE(LUN,1400) WRITE(LUN,12701) WRITE(LUN,12702) (I, IBTAB(IND,1,I), RBTAB(IND,2,I), * RBTAB(IND,3,I), IBTAB(IND,4,I), IBTAB(IND,5,I), * IDUAL(IBTAB(IND,6,I),7), IBTAB(IND,7,I), I=1, NROW) 12701 FORMAT(1H0,8X,' CELL ENERGY DRIFT TYPE OF ', * ' DRIFT ITRHIS LINK TO ',/, * 9X,' NUMBER DEPOSIT DISTANCE HIT ', * ' SIGN LMIBPAFC PARENT,STR',/, * 1X,130('-'),/) 12702 FORMAT((2X,I4,3X,I8,2F10.3,2X,4(I8,2X))) GOTO 200 C C.... 'FRRH' C 128 CONTINUE WRITE(LUN,1400) WRITE(LUN,12801) WRITE(LUN,12802) (I, IBTAB(IND,1,I), RBTAB(IND,2,I), * RBTAB(IND,3,I), RBTAB(IND,4,I), IBTAB(IND,5,I), * IBTAB(IND,6,I), IDUAL(IBTAB(IND,7,I),7), * IBTAB(IND,8,1), I=1, NROW) 12801 FORMAT(1H0,8X,' CELL ENERGY DRIFT TYPE OF ', * ' DRIFT ITRHIS LINK TO ',/, * 9X,' NUMBER DEPOSIT DISTANCE HIT ', * ' SIGN LMIBPAFC PARENT,STR',/, * 1X,130('-'),/) 12802 FORMAT((2X,I4,3X,I8,3F10.3,2X,4(I8,2X))) GOTO 200 C C.... 'FRPX', 'FRRX', 'MRPX', 'MRTX' C 129 CONTINUE WRITE(LUN,1400) WRITE(LUN,12901) WRITE(LUN,12902) (I, IDUAL(IBTAB(ID,1,I),9), IBTAB(ID,2,I), * IBTAB(ID,3,I), I=1, NROW) 12901 FORMAT(9X,' FLAG LINK TO LINK TO ', * 18X,' FLAG LINK TO LINK TO ',/, * 9X,' STR BANK FR_E BANK ', * 18X,' STR BANK FR_E BANK ',/, * 1X,130('-'),/) 12902 FORMAT((1X,2(I6,3X,I10,I8,3X,I8,13X))) GOTO 200 C C.... 'IRSE', 'IRWE' C 130 CONTINUE WRITE(LUN,1400) WRITE(LUN,13001) WRITE(LUN,13002) (I, IBTAB(ID,1,I), IBTAB(ID,2,I), I=1, NROW) 13001 FORMAT(9X,' MODULE CHANNEL ',18X,' MODULE CHANNEL ', * 18X,' MODULE CHANNEL ',/, * 9X,' NUMBER NUMBER ',18X,' NUMBER NUMBER ', * 18X,' NUMBER NUMBER ',/, * 1X,130('-'),/) 13002 FORMAT((1X,3(I6,2X,2(I8,3X),9X))) GOTO 200 C C.... 'IRTE' C 131 CONTINUE WRITE(LUN,1400) WRITE(LUN,13101) WRITE(LUN,13102) (I, IBTAB(ID,1,I), IBTAB(ID,2,I), I=1, NROW) 13101 FORMAT(9X,' CHANNEL CHARGE ',18X,' CHANNEL CHARGE ', * 18X,' CHANNEL CHARGE ',/, * 9X,' (TOWER) STREAMERS ',18X,' (TOWER) STREAMERS ', * 18X,' (TOWER) STREAMERS ',/, * 1X,130('-'),/) 13102 FORMAT((1X,3(I6,2X,2(I8,3X),9X))) GOTO 200 C C.... 'ARCX', 'BRCX', 'CRYX', 'CRZX', 'PRDX', 'SRCX' C 132 CONTINUE WRITE(LUN,1400) WRITE(LUN,13201) WRITE(LUN,13202) (I, IBTAB(ID,1,I), IBTAB(ID,2,I), I=1, NROW) 13201 FORMAT(9X,' LINK TO LINK TO ', * 18X,' LINK TO LINK TO ', * 18X,' LINK TO LINK TO ',/, * 9X,' STR BANK _R_E BANK ', * 18X,' STR BANK _R_E BANK ', * 18X,' STR BANK _R_E BANK ',/, * 1X,130('-'),/) 13202 FORMAT((1X,3(I6,2X,2(I8,3X),9X))) GOTO 200 C C....no longer used C 133 CONTINUE GOTO 200 C C.... 'LRTE', 'LTL1' C 134 CONTINUE WRITE(LUN,1400) WRITE(LUN,13401) WRITE(LUN,13402) (I, IBTAB(ID,1,I), IBTAB(ID,2,I), I=1, NROW) 13401 FORMAT(9X,' DETECTOR VETO CODE ',18X,' DETECTOR VETO CODE ', * 18X,' DETECTOR VETO CODE ',/, * 9X,' NUMBER ',18X,' NUMBER ', * 18X,' NUMBER ',/, * 1X,130('-'),/) 13402 FORMAT((1X,3(I6,2X,2(I8,2X),9X))) GOTO 200 C C.... 'TRAK' ('TRIP') C FETCH PARALLEL BANKS C 135 CONTINUE IF(NAME.EQ.'TRAK') THEN IND1 = NLINK('TRIP',NR) IF(IND1.EQ.0) GOTO 9020 WRITE(LUN,1800) 'TRIP' ELSE WRITE(LUN,1800) NAME GOTO 200 ENDIF C WRITE(LUN,1400) WRITE(LUN,13502) WRITE(LUN,13503) (I, RBTAB(IND,1,I), RBTAB(IND,2,I), * RBTAB(IND,3,I), RBTAB(IND,4,I), RBTAB(IND,5,I), * RBTAB(IND,6,I), RBTAB(IND,7,I), IBTAB(IND,8,I), * IBTAB(IND,9,I), IBTAB(IND,10,I), IBTAB(IND,11,I), * IBTAB(IND1,1,I), I=1, NROW) 13502 FORMAT(9X,' MOMENTUM (GEV) ENERGY ', * ' CHARGE CLOSEST DISTANCE ', * ' PARTICLE VERTEX POINTERS LINK TO ', * 9X,' PX PY PZ (GEV) ', * ' R-PHI Z ', * ' TYPE NUMBER STR BANK ',/, * 1X,130('-'),/) 13503 FORMAT((3X,I3,2X,4(1X,F10.3),3(1X,F10.4),2X,I6,4X,I6, * 3X,2I4,1X,I8)) GOTO 200 C C.... 'CACE' ('CCEG') C FETCH PARALLEL BANKS C 136 CONTINUE IF(NAME.EQ.'CACE') THEN IND1 = NLINK('CCEG',0) IF(IND1.EQ.0) GOTO 13603 WRITE(LUN,1800) 'CCEG' ELSE WRITE(LUN,1800) NAME GOTO 200 ENDIF C WRITE(LUN,1400) WRITE(LUN,13601) WRITE(LUN,13602) (I, IBTAB(IND,1,I), RBTAB(IND,2,I), * RBTAB(IND1,1,I), RBTAB(IND1,2,I), RBTAB(IND1,3,I), * RBTAB(IND1,4,I), I=1, NROW) 13601 FORMAT(9X,' TOWER ENERGY ', * ' CENTROID CENTROID CENTROID CENTROID ',/, * 9X,' NUMBER DEPOSIT ', * ' X Y Z VOLUME ',/, * 1X,130('-'),/) 13602 FORMAT((2X,I4,3X,I8,5F10.3)) GOTO 200 C 13603 CONTINUE WRITE(LUN,1400) WRITE(LUN,13604) WRITE(LUN,13605) (I, IBTAB(IND,1,I), RBTAB(IND,2,I), I=1, NROW) 13604 FORMAT(9X,' TOWER ENERGY ',18X,' TOWER ENERGY ', * 10X,' TOWER ENERGY ',/, * 9X,' NUMBER DEPOSIT ',18X,' NUMBER DEPOSIT ', * 10X,' NUMBER DEPOSIT ',/, * 1X,130('-'),/) 13605 FORMAT((1X,3(I6,2X,I8,1X,F10.3,12X))) GOTO 200 C C.... 'MUON' C 137 CONTINUE WRITE(LUN,1400) WRITE(LUN,13701) WRITE(LUN,13702) (I, RBTAB(IND,1,I), RBTAB(IND,2,I), * IBTAB(IND,3,I), IBTAB(IND,4,I), IBTAB(IND,5,I), * I=1, NROW) 13701 FORMAT(9X,' SMEARED SIGMA ', * ' NUMBER NUMBER LINK TO ',/, * 9X,' MOMENTUM (1/P) ', * ' OF WIRES OF STRIPS STR BANK ',/, * 1X,130('-'),/) 13702 FORMAT((2X,I4,1X,2F10.3,3I10)) GOTO 200 C C.... 'TTSE' C 138 CONTINUE WRITE(LUN,1400) WRITE(LUN,13801) WRITE(LUN,13802) (RBTAB(IND,1,I),I=1, NROW) 13801 FORMAT(9X,'ENERGIES IN DIFFERENT CALORIMETERS (GEV) ',/, * 9X,'TRANSVERSE MISSING FORWARD FORWARD ', * ' CENTRAL BEMC PLUG FORWARD ', * ' BARREL BACKWARD TOTAL',/, * 9X,' LAR BARREL LAR ', * 'BARREL LAR ', * ' ',/, * 1X,130('-'),/) 13802 FORMAT((8X,11(F10.3,1X))) GOTO 200 C C.... 'MODS' C 139 CONTINUE WRITE(LUN,1400) WRITE(LUN,13901) WRITE(LUN,13902) (CHAINT(IBTAB(IND,1,I)),CHAINT(IBTAB(IND,2,I)), * IBTAB(IND,3,I)/1.E4,IBTAB(IND,4,I),I=1, NROW) 13901 FORMAT(9X,'MODULE NAME VERSION NR JOB NR',/, * 1X,130('-'),/) 13902 FORMAT((9X,2A4,6X,F7.4,4X,I8)) GOTO 200 C C.... 'MODI', 'MODO' C 140 CONTINUE WRITE(LUN,1400) WRITE(LUN,14001) WRITE(LUN,14002) (CHAINT(IBTAB(IND,1,I)),IBTAB(IND,2,I),I=1, NROW) 14001 FORMAT(9X,4('NAME LINK TO MODULE '),/, * 1X,130('-'),/) 14002 FORMAT((9X,4(A4,8X,I2,9X))) GOTO 200 C C.... 'MODC' C 141 CONTINUE WRITE(LUN,1400) WRITE(LUN,14101) WRITE(LUN,14102) (CHAINT(IBTAB(IND,1,I)),IBTAB(IND,2,I), 1 IBTAB(IND,3,I),I=1, NROW) 14101 FORMAT(9X,4('NAME VERSION LINK TO MODULE '),/, * 1X,130('-'),/) 14102 FORMAT((9X,4(A4,3X,I9,2X,I2,11X))) GOTO 200 C C.... 'SRCT' (Spacal hit bank) C 142 WRITE(LUN,1400) WRITE(LUN,14201) DO 14200 I = 1, NROW ITRHIS = 0 CALL IDUAL1( ITRHIS, 14, 1, IBIT ) IENER = IFRB16(IBTAB(ID,2,I))*ISCALA IEINV = IFRB16(IBTAB(ID,3,I))*ISCALD IEEM = IFRB16(IBTAB(ID,4,I))*ISCALD IEHAD = IFRB16(IBTAB(ID,5,I))*ISCALD IEHVIS = IFRB16(IBTAB(ID,6,I))*ISCALD WRITE(LUN,14202) I, IBTAB(ID,1,I), * FLOAT(IENER)/1.E3, * IBIT,IBTAB(ID,7,I), * FLOAT(IEINV)/1.E3, FLOAT(IEEM)/1.E3, * FLOAT(IEHAD)/1.E3, FLOAT(IEHVIS)/1.E3 14200 CONTINUE 14201 FORMAT(6X,' CHAN E(MeV) ITRHIS TRACK', * ' Einv Eem Ehad Ehavis' * /,1X,130('-'),/) 14202 FORMAT((2X,I4,I6,F9.1,2X,14I1,I7,4F9.1)) GOTO 200 143 CONTINUE WRITE(LUN,1400) CALL PRATES(ID) GOTO 200 144 CONTINUE WRITE(LUN,1400) write(6,*)'to print the TEL1 banks, please call directly' write(6,*)'PRTEL1(ITYPE), ITYPE=0 for online version' write(6,*)' ITYPE=1 for offline version' * next call works differently now... * CALL PRTEL1(IND) GOTO 200 145 CONTINUE WRITE(LUN,1400) * look for ATBX bank for combined printout of banks INXX=NLINK('ATBX',NR) ID2=0 IF(INXX.NE.0)THEN CALL BKTOW(IW,'ATBX',NR,IW,ID2,*9000) ENDIF CALL PRATBE(ID,ID2) IF(ID2.NE.0)CALL WDROP(IW,ID2) GOTO 200 C C.... 'JSRP', 'JSFT' C 146 WRITE(LUN,1400) WRITE(LUN,14601) WRITE(LUN,14602) (I, RBTAB(IND,1,I), RBTAB(IND,2,I), * RBTAB(IND,3,I), PDGNAM(IBTAB(IND,4,I)), RBTAB(IND,5,I), * RBTAB(IND,6,I), RBTAB(IND,7,I), (1.0E+09*RBTAB(IND,8,I)), * IBTAB(IND,9,I), I=1, NROW) 14601 FORMAT(9X,' MOMENTUM (GEV) PARTICLE ', * 'TYPE COORD. AT ENTRY/EXIT POINT (CM) TIME OF ', * ' TRACK ',/, * 9X,' PX PY PZ ', * ' X Y Z FLIGHT (NS)', * ' NUMBER ',/,1X,130('-'),/) 14602 FORMAT((2X,I4,2X,3(1X,F10.3),1X,A13,3(1X,F10.3), * 3X,F10.3,5X,I8)) GOTO 200 C C.... 'JRHT' ('JRDT') C FETCH PARALLEL BANKS C 147 CONTINUE IF(NAME.EQ.'JRHT') THEN IND1 = NLINK('JRDT',NR) IF(IND1.EQ.0) GOTO 14703 CALL BKTOW(IW,'JRDT',NR,IW,ID2,*9000) WRITE(LUN,1800) 'JRDT' ELSE WRITE(LUN,1800) NAME GOTO 200 ENDIF C WRITE(LUN,1400) WRITE(LUN,14701) WRITE(LUN,14702) (I,IDUAL(IBTAB(ID,1,I),6), * IDUAL(IBTAB(ID2,1,I),6), IBTAB(ID,2,I), I=1, NROW) WRITE(LUN,1400) CALL WDROP(IW,ID2) 14701 FORMAT(9X,' CHANNELS CHANNELS PARTICLE '/, * 9X,' HIT SIGNAL IN JSPT',/, * 1X,130('-'),/) 14702 FORMAT((I5,6X,I7,3X,I7,4X,I8)) GOTO 200 C 14703 CONTINUE WRITE(LUN,1400) WRITE(LUN,14704) WRITE(LUN,14705) (I, IDUAL(IBTAB(ID,1,I),6), * IBTAB(ID,2,I), I=1, NROW) WRITE(LUN,1400) 14704 FORMAT(9X,' CHANNELS PARTICLE '/, * 9X,' HIT IN JSPT',/, * 1X,130('-'),/) 14705 FORMAT((I5,6X,I7,4X,I8)) GOTO 200 C C.... 'JRDE' C 148 CONTINUE WRITE(LUN,1400) WRITE(LUN,14801) WRITE(LUN,14802) (I, IBTAB(ID,1,I), IBTAB(ID,2,I), I=1, NROW) 14801 FORMAT(9X,' CHANNEL HITS ',/,1X,130('-'),/) 14802 FORMAT(2X,I4,3X,I8,3X,I8) GOTO 200 C C.... PRINT BANKS WITHOUT MINIHEADER C C.... 'GKI ', 'GHD ', 'HEAD' C 500 CONTINUE IF(NAME.EQ.'GKI ') THEN WRITE(LUN,1400) IF( IW(IND) .GE. 29 ) THEN WRITE(LUN,511) IW(IND+1) 511 FORMAT(9X,' IRAD = ',I13,' initial/final radiation') WRITE(LUN,512) RW(IND+3), RW(IND+4) 512 FORMAT(9X,' GENPL = ',E13.6,' incident lepton momentum',/, * 9X,' GENPP = ',E13.6,' incident proton momentum') WRITE(LUN,513) RW(IND+5), RW(IND+6), RW(IND+7) 513 FORMAT(9X,' GENX = ',E13.6,' Bjorken X value ',/, * 9X,' GENY = ',E13.6,' Bjorken Y value ',/, * 9X,' GENQ2 = ',E13.6,' Q**2 value ') WRITE(LUN,514) RW(IND+8), RW(IND+9) 514 FORMAT(9X,' GENNU = ',E13.6,' nu = P.q/m_proton ',/, * 9X,' GENW = ',E13.6,' W value ') WRITE(LUN,515) RW(IND+10), RW(IND+11) 515 FORMAT(9X,' X1 = ',E13.6,' x in PDF lepton side',/, * 9X,' X2 = ',E13.6,' x in PDF proton side') WRITE(LUN,516) RW(IND+12), RW(IND+13) 516 FORMAT(9X,' SCALE1 = ',E13.6,' Q2 in PDF lepton side',/, * 9X,' SCALE2 = ',E13.6,' Q2 in PDF proton side') WRITE(LUN,517) IW(IND+14), IW(IND+15) 517 FORMAT(9X,' PDFID1 = ',I13,' PDF id. lepton side',/, * 9X,' PDFID2 = ',I13,' PDF id. proton side') WRITE(LUN,518) RW(IND+16), RW(IND+17) 518 FORMAT(9X,' XPDF1 = ',E13.6,' value of PDF lepton side',/, * 9X,' XPDF2 = ',E13.6,' value of PDF proton side') WRITE(LUN,519) RW(IND+18), RW(IND+19) 519 FORMAT(9X,' KTI1 = ',E13.6,' intr. k_t lepton side',/, * 9X,' KTI2 = ',E13.6,' intr. k_t proton side') WRITE(LUN,520) RW(IND+20), RW(IND+21) 520 FORMAT(9X,' WTX1 = ',E13.6,' event weight 1. variable',/, * 9X,' WTX2 = ',E13.6,' event weight 2. variable') WRITE(LUN,521) RW(IND+22), RW(IND+23) 521 FORMAT(9X,' SIGMT = ',E13.6,' total cross section',/, * 9X,' DSIGMT = ',E13.6,' error of cross section') WRITE(LUN,522) RW(IND+24), RW(IND+25) 522 FORMAT(9X,' SIGMS = ',E13.6,' subpr. cross section',/, * 9X,' DSIGMS = ',E13.6,' error of cross section') WRITE(LUN,523) RW(IND+26) 523 FORMAT(9X,' WTX3 = ',E13.6,' event weight mixing ') IF( IW(IND) .GE. 31 ) THEN WRITE(LUN,524) RW(IND+30), RW(IND+31) 524 FORMAT(9X,' PT2HAT = ',E13.6,' DIS + photoprod. ',/, * 9X,' SHAT = ',E13.6,' DIS + photoprod. ') ENDIF IF( IW(IND) .GE. 34 ) THEN WRITE(LUN,525) RW(IND+32), RW(IND+33), RW(IND+34) 525 FORMAT(9X,' XP = ',E13.6,' DIS + photoprod. ',/, * 9X,' ZP = ',E13.6,' DIS + photoprod. ',/, * 9X,' PHI = ',E13.6,' DIS + photoprod. ') ENDIF ELSE WRITE(LUN,501) 501 FORMAT(9X,' PHYSICS HARD GAMMA BEAM MOMENTA (GEV/C) ', * ' X Y Q**2 NU ', * ' W ',/, * 9X,' FLAG RADIATION LEPTON PROTON ', * ' (GEV/C)**2 (GEV) ', * ' (GEV) ',/,1X,130('-'),/) WRITE(LUN,502) IW(IND+1), IW(IND+2), (RW(IND+I), I=3, 9) 502 FORMAT(9X,I5,5X,' IRAD =',I2,1X,7(1X,E11.4)) END IF WRITE(LUN,1400) ELSE IF(NAME.EQ.'GHD ') THEN WRITE(LUN,1400) J = IND DO 180, I = 1, IW (IND) / 6 WRITE(LUN,503) CHAINT(IW(J+1)), CHAINT(IW(J+2)), * CHAINT(IW(J+3)), CHAINT(IW(J+4)), * CHAINT(IW(J+5)), CHAINT(IW(J+6)) J = J + 6 180 CONTINUE 503 FORMAT(/,6X,'GENERATOR NAME ',2A4,' VERSION NUMBER ', * 2A4,' CMZ Version ',2A4) WRITE(LUN,1400) ELSE IF(NAME.EQ.'GEVC') THEN CALL PRGEVC ELSE IF(NAME.EQ.'HEAD') THEN WRITE(LUN,1400) WRITE(LUN,504) WRITE(LUN,505) (IW(IND+I), I=1, 13) 504 FORMAT(9X,'VERS NRUN NEVT WEIGHT ', * ' U-TIME RUNTYPE BRERROR DETSTAT ', * ' L1-CLASS L2-CLASS L3-CLASS L4-CLASS L5-CLASS', * /,1X,130('-'),/) 505 FORMAT(9X,I4,I7,I7,I4,9I10) WRITE(LUN,1400) END IF RETURN C C.... CONTINUE HERE WITH NEW BANKS C 200 CONTINUE IF(IBKFMT.LT.0) CALL WDROP(IW,ID) WRITE(LUN,1400) RETURN C 9000 CONTINUE WRITE(LUN,1100) NAME, NR GOTO 200 9010 CONTINUE WRITE(LUN,1600) NAME WRITE(LUN,1400) IDUMMY = MYPRNT(NAME,NR,0) RETURN 9020 CONTINUE WRITE(LUN,1700) GOTO 200 1100 FORMAT(//,' +++++ H1PRNT. BANK ++ ',A,',',I2,' ++ DOES NOT ', * 'EXIST ON INPUT FILE. ') 1200 FORMAT('0+++++ H1PRNT. PRINT FORMAT FOR BANK ++ ',A,' ++ ', * 'IS NOT YET SPECIFIED. ') 1300 FORMAT(//,' +++++ ',A,',',I2, * ' BANK LENGTH ',I5, * ' NUMBER OF COLUMNS ',I5, * ' NUMBER OF ROWS ',I5) 1400 FORMAT(1H0,130('-')) 1500 FORMAT('0+++++ H1PRNT. BANK LENGTH DOES NOT MATCH ', * 'MINI HEADER.',/) 1600 FORMAT(//,' +++++ H1PRNT. BANK ++ ',A,' ++ NOT FOUND IN ', * 'CURRENT BANK LIST.',/, * ' +++++ H1PRNT. CALL MYPRNT INSTEAD.',//) 1700 FORMAT('0+++++ H1PRNT. NO PARALLEL BANK FOUND.') 1800 FORMAT('0+++++ ',A4,', 0 IS A PARALLEL BANK.') 1900 FORMAT(//,' +++++ ',A,',',I2,' NO MINIHEADER.') END *CMZU: 03/08/98 14.41.58 by Stephen Burke *-- Author : Stephen Burke 03/08/98 SUBROUTINE FPFRQE *#********************************************************************** *# * *# VERSION: 30/07/98 Steve Burke * *# * *# Print FRQE BANK * *# Created BY SJM 02/03/90 * *# * *#********************************************************************** *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/ *KEND. COMMON/FPF3WW/IND * Locate FRQE Banks.. IBK = 0 IND = NLINK('FRQE',IBK) IF (IND .EQ. 0) THEN WRITE(6,*) 'FRQE', IBK,' BANK NOT FOUND ' RETURN ENDIF IND=0 CALL BKTOW(IW,'FRQE',IBK,IW,IND,*900) * Compute number of responses... INUM = IW(IND+2) IF(INUM.LE.0) GOTO 999 WRITE(6,100) IBK,INUM WRITE(6,110) INDST = IND+2 DO 11 JJHIT = 1,INUM * Information from FRQE response bank... ICLNUM= IW(INDST + 1) IDRF = IW(INDST + 2) IQPL = IW(INDST + 3) IQMI = IW(INDST + 4) IFRFLA= IW(INDST + 5) IFRFLB= IW(INDST + 6) ISEPR = 0 ISEPL = 0 IHITS = 0 ILEN = 0 CALL MVBITS(IFRFLB, 0,4,ISEPL,0) CALL MVBITS(IFRFLB, 4,4,ISEPR,0) CALL MVBITS(IFRFLB, 8,4,ILEN,0) CALL MVBITS(IFRFLB,12,4,IHITS,0) INDST = INDST + IW(IND+1) WRITE(6,200)JJHIT,ICLNUM,IDRF,IQPL,IQMI, + IFRFLA,IFRFLB, + ISEPL,ISEPR,ILEN,IHITS 11 CONTINUE 100 FORMAT(' ',72('-'),/,5X, 'FRQE ',I2,' WITH',I5,' HITS') 110 FORMAT(' Row Cell Drift Qplus', + ' Qminus Flag1 Flag2', + ' ? ? ? ?') 200 FORMAT(2I6,3I10,2(3X,I8),4I4) 999 CONTINUE CALL WDROP(IW,IND) RETURN 900 CONTINUE WRITE(6,*) ' *****ERROR IN W BANK CREATION FPFRQE' RETURN END *CMZU: 03/08/98 14.41.58 by Stephen Burke *-- Author : Stephen Burke 03/08/98 SUBROUTINE FPFRQF *#********************************************************************** *# * *# VERSION: 30/07/98 Steve Burke * *# * *# Print FRQF BANK * *# Created BY SJM 02/03/90 * *# * *#********************************************************************** *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/ *KEND. * Locate FRQF Bank... IND = NLINK('FRQF',0) IF (IND .EQ. 0) THEN WRITE(6,*) ' **FPFRQF>> FRQF BANK NOT FOUND ' RETURN ENDIF * Compute number of responses... INUM = IW(IND+2) IF(INUM.LE.0) GOTO 999 WRITE(6,100) INUM WRITE(6,110) INDST = IND+2 DO 11 JJHIT = 1,INUM * XIN = RW(INDST + 1) YIN = RW(INDST + 2) ZIN = RW(INDST + 3) PXIN = RW(INDST + 4) PYIN = RW(INDST + 5) PZIN = RW(INDST + 6) PPIN = RW(INDST + 7) XOUT = RW(INDST + 8) YOUT = RW(INDST + 9) ZOUT = RW(INDST +10) PXOUT = RW(INDST +11) PYOUT = RW(INDST +12) PZOUT = RW(INDST +13) PPOUT = RW(INDST +14) IPART = IW(INDST +15) ITRHIS = IW(INDST +16) ICELL = IW(INDST +17) ITRKNM = IW(INDST +18) WRITE(6,200)JJHIT,XIN ,YIN ,ZIN ,PXIN ,PYIN ,PZIN ,PPIN, + XOUT,YOUT,ZOUT,PXOUT,PYOUT,PZOUT,PPOUT, + IPART,ITRHIS,ICELL,ITRKNM INDST = INDST + IW(IND+1) 11 CONTINUE 100 FORMAT(' ',72('-'),/,5X, 'FRQF WITH',I5,' HITS') 110 FORMAT(' ',' Row',' x',' y',' z',' Px/P', + ' Py/P',' Pz/P',' P',' Typ', + ' His',' Cell',' Trk') 200 FORMAT(1X,I4,7(1X,F6.2),/,5X,7(1X,F6.2),2I4,I6,I4) 999 CONTINUE RETURN END *CMZU: 03/08/98 14.41.58 by Stephen Burke *-- Author : Stephen Burke 03/08/98 SUBROUTINE FPFRQH *#********************************************************************** *# * *# VERSION: 30/07/98 Steve Burke * *# * *# Print FRQH BANK * *# Created BY SJM 02/03/90 * *# * *#********************************************************************** *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/ *KEND. * Conversion GeV -> keV PARAMETER(GEVKEV=1000000.) * Locate FRQH Bank... IND = NLINK('FRQH',0) IF (IND .EQ. 0) THEN WRITE(6,*) 'FRQH BANK NOT FOUND ' RETURN ENDIF * Compute number of responses... INUM = IW(IND+2) IF(INUM.LE.0) GOTO 999 WRITE(6,100) INUM WRITE(6,110) INDST = IND+2 DO 11 JJHIT = 1,INUM * Information from FRPH bank ICLNUM = IW(INDST + 1) EDEP = GEVKEV*RW(INDST + 2) DRIF = RW(INDST + 3) IHTTYP = IW(INDST + 4) ISIGN = IW(INDST + 5) ITRHIS = IW(INDST + 6) ITRKNM = IW(INDST + 7) WRITE(6,200)JJHIT,ICLNUM,EDEP,DRIF, + IHTTYP,ISIGN,ITRHIS,ITRKNM INDST = INDST + IW(IND+1) 11 CONTINUE 100 FORMAT(' ',72('-'),/,5X, 'FRQH WITH',I5,' HITS') 110 FORMAT(' Row',' Cell', + ' Edep-keV Drif', + ' HTyp Sgn His Trk') 200 FORMAT(I5,I6,2F10.4,4I5) 999 CONTINUE RETURN END *CMZU: 03/08/98 14.41.58 by Stephen Burke *-- Author : Stephen Burke 03/08/98 SUBROUTINE FPFRQT *#********************************************************************** *# * *# VERSION: 30/07/98 Steve Burke * *# * *# Print FRQT BANK * *# Created BY SJM 02/03/90 * *# * *#********************************************************************** *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/ *KEND. PARAMETER(NBN=0) * Locate FRQT banks... IND =NLINK('FRQT',NBN) IF(IND.NE.0) THEN * Number of hits in bank INUM=IW(IND+2) WRITE(6,100) NBN,INUM * Loop through hits in this bank INDST = IND+2 WRITE(6,110) DO 11 JJHIT = 1,INUM * Information from track response bank... ICLNUM= IW(INDST + 1) XIN = RW(INDST + 2) YIN = RW(INDST + 3) ZIN = RW(INDST + 4) XOUT = RW(INDST + 5) YOUT = RW(INDST + 6) ZOUT = RW(INDST + 7) EDEP = 1000000.*RW(INDST + 8) ITRHIS= IW(INDST + 9) ITRKNM= IW(INDST +10) WRITE(6,200)JJHIT,ICLNUM,XIN,YIN,ZIN,XOUT,YOUT,ZOUT, + EDEP,ITRHIS,ITRKNM INDST = INDST + IW(IND+1) 11 CONTINUE END IF 100 FORMAT(' ',72('-'),/,5X, 'FRQT BANK ',I3,' with',I5,' Hits') 110 FORMAT(' Row Cell Xin Yin Zin', + ' Xout Yout Zout E-keV His', + ' Trk') 200 FORMAT(2I5,7F7.2,2I4) RETURN END *CMZU: 03/08/98 14.41.58 by Stephen Burke *-- Author : Stephen Burke 03/08/98 SUBROUTINE FPFRQX *#********************************************************************** *# * *# VERSION: 30/07/98 Steve Burke * *# * *# Print FRQX BANK * *# Created BY SJM 02/03/90 * *# * *#********************************************************************** *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/ *KEND. COMMON/FPF5WW/IND *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. * Locate FRQX Bank... IBK = 0 IND = NLINK('FRQX',IBK) IF (IND .EQ. 0) THEN WRITE(6,*) 'FRQX', IBK,' BANK NOT FOUND ' RETURN ENDIF IND=0 CALL BKTOW(IW,'FRQX',IBK,IW,IND,*900) * Compute number of responses... INUM = IW(IND+2) IF(INUM.LE.0) GOTO 999 WRITE(6,100) IBK,INUM WRITE(6,*) ' Row',' IFlag', + ' Trk', + ' IFRQE' DO 11 K = 1,INUM WRITE(6,'(1X,I4,3(2X,I6))') + K,(IBTAB(IND,J,K), J=1,3) 11 CONTINUE 100 FORMAT(' ',72('-'),/,5X, 'FRQX ',I2,' WITH',I5,' HITS') 999 CONTINUE CALL WDROP(IW,IND) RETURN 900 CONTINUE WRITE(6,*) ' *****ERROR IN W BANK CREATION FPFRQX' RETURN END *CMZU: 03/08/98 14.42.18 by Stephen Burke *-- Author : Stephen Burke 03/08/98 SUBROUTINE UTQCRB ********************************************************************** * * * Create unpacked versions of the digi pointer and hit relation * * banks for use by UTQSTR * * * * Banks created are: FTPY, FTQY, FTRY, CTJY, CVYY, CVZY, * * FRPY, FRQY, FRRY, CRJY, CRYY, CRZY and STRX * * * * See the DDL for details * * * * Updated 31/7/98 to allow for the new planar chambers * * * ********************************************************************** PARAMETER (NSUBDT=6,NCDP=2,NCXR=5) DIMENSION IFLG(NSUBDT),ISTR(NSUBDT),IHIT(NSUBDT) CHARACTER*4 DPNAME(NSUBDT),XRNAME(NSUBDT) CHARACTER*4 DPNAMY(NSUBDT),XRNAMY(NSUBDT) LOGICAL LFIRST SAVE IFLG,ISTR,IHIT,DPNAME,XRNAME,DPNAMY,XRNAMY,LFIRST COMMON /IUSTRY/ INDDP(NSUBDT),INDXR(NSUBDT) DATA IFLG/1,1,1,0,0,0/,ISTR/2,2,2,1,1,1/,IHIT/3,3,3,2,2,2/ DATA DPNAME/'FTPX','FTQX','FTRX','CTJX','CRYE','CRZE'/ DATA DPNAMY/'FTPY','FTQY','FTRY','CTJY','CVYY','CVZY'/ DATA XRNAME/'FRPX','FRQX','FRRX','CRJX','CRYX','CRZX'/ DATA XRNAMY/'FRPY','FRQY','FRRY','CRJY','CRYY','CRZY'/ DATA LFIRST/.TRUE./ *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. ********************************************************************** IF (LFIRST) THEN LFIRST = .FALSE. * Define the bank formats (just in case they get written out) CALL BKFMT('STRX','I') DO JS=1,NSUBDT CALL BKFMT(DPNAMY(JS),'I') CALL BKFMT(XRNAMY(JS),'I') END DO ENDIF * Zero work bank indices CALL VZERO(INDDP,NSUBDT) CALL VZERO(INDXR,NSUBDT) INSTR = NLINK('STR ',0) IF (INSTR.GT.0) THEN * Create the STRX bank and add to R list NSTR = IW(INSTR+2) INSTRX = NBANK('STRX',0,2+NSUBDT*NSTR) IF (INSTRX.LE.0) GOTO 9000 CALL VZERO(IW(INSTRX+1),2+NSUBDT*NSTR) CALL BLIST(IW,'R+','STRX') IW(INSTRX+1) = NSUBDT IW(INSTRX+2) = NSTR ELSE NSTR = 0 ENDIF * * Main loop over subdetectors * DO 100 JS=1,NSUBDT * Get rid of any pre-existing banks CALL BDROP(IW,DPNAMY(JS)) CALL BDROP(IW,XRNAMY(JS)) * Do nothing if the banks don't exist IF (NLINK(DPNAME(JS),0).LE.0 .OR. & NLINK(XRNAME(JS),0).LE.0) GOTO 100 * Unpack banks (all B16) CALL BKTOW(IW,DPNAME(JS),0,IW,INDDP(JS),*9000) CALL BKTOW(IW,XRNAME(JS),0,IW,INDXR(JS),*9000) NDP = IW(INDDP(JS)+2) NXR = IW(INDXR(JS)+2) * Create the new banks and add to R list INDDPY = NBANK(DPNAMY(JS),0,2+NCDP*NDP) IF (INDDPY.LE.0) GOTO 9000 CALL BLIST(IW,'R+',DPNAMY(JS)) INDXRY = NBANK(XRNAMY(JS),0,2+NCXR*NXR) IF (INDXRY.LE.0) GOTO 9000 CALL BLIST(IW,'R+',XRNAMY(JS)) CALL VZERO(IW(INDDPY+1),2+NCDP*NDP) CALL VZERO(IW(INDXRY+1),2+NCXR*NXR) IW(INDDPY+1) = NCDP IW(INDDPY+2) = NDP IW(INDXRY+1) = NCXR IW(INDXRY+2) = NXR * Loop over the cross-reference banks in reverse order DO JXR=NXR,1,-1 IF (IFLG(JS).GT.0) THEN * True hits only (this flag only exists for radials and planars) IFLAG = IBTAB(INDXR(JS),IFLG(JS),JXR) ELSE IFLAG = 0 ENDIF IF (IFLAG.LT.512) THEN JDP = IBTAB(INDXR(JS),IHIT(JS),JXR) JSTR = IBTAB(INDXR(JS),ISTR(JS),JXR) * Fill in the various pointers IF (JDP.GT.0 .AND. JDP.LE.NDP) THEN JXX = IBTAB(INDDPY,2,JDP) IW(INDCR(INDDPY,2,JDP)) = JXR IW(INDCR(INDXRY,1,JXR)) = JSTR IW(INDCR(INDXRY,2,JXR)) = JDP IW(INDCR(INDXRY,3,JXR)) = JXX IW(INDCR(INDXRY,5,JXR)) = IFLAG ENDIF IF (JSTR.GT.0 .AND. JSTR.LE.NSTR) THEN JXY = IBTAB(INSTRX,JS,JSTR) IW(INDCR(INSTRX,JS,JSTR)) = JXR IW(INDCR(INDXRY,4,JXR)) = JXY ENDIF ENDIF END DO * Finally copy the "pointer to next digi" (meaningless for z-chambers) DO JDP=1,NDP IW(INDCR(INDDPY,1,JDP)) = IBTAB(INDDP(JS),1,JDP) END DO 100 CONTINUE 900 CONTINUE * * Must make sure all work banks are dropped!!! * DO JS=1,NSUBDT CALL WDROP(IW,INDDP(JS)) CALL WDROP(IW,INDXR(JS)) END DO RETURN 9000 CONTINUE CALL ERRLOG(1201,'S:UTQCRB: Error in bank creation') GOTO 900 END *CMZU: 03/08/98 14.42.18 by Stephen Burke *-- Author : Stephen Burke 03/08/98 SUBROUTINE UTQSTR(JDIGP,JDIGQ,JDIGR,JDIGJ,JCVPR,JSTR,NHIT,NPOSS) ********************************************************************** * * * Find the best candidate for the 'true' track, given a list * * of digis. * * * * Note that UTQCRB must be called once per event before this * * routine can be used. * * * * The arguments are pointers into the circular lists of digis, or * * for the z-chambers to the "pointering" bank: * * * * JDIGP --> FTPX (foward planars) * * JDIGQ --> FTQX (foward new planars) * * JDIGR --> FTRX (forward radials) * * JDIGJ --> CTJX (CJC) * * JCVPR --> CVPR (CIZ + COZ) * * * * The return values are: * * * * JSTR - The 'true' track (STR) number * * NHIT - The number of hits from track JSTR in the digi list(s) * * NPOSS - The total number of hits from track JSTR * * * * Thus NHIT/NPOSS is some sort of "hit-finding efficiency". * * * * Zero or negative pointers are ignored; the return value JSTR is * * the STR index of the "best" track (the one contributing most hits) * * for those subdetectors with pointers > 0. * * * * Pointers which are negative on entry will exclude that subdetector * * from having its hits counted in NPOSS * * * * If the FT unpacked banks (FPLC/FPG1, FQLC/FQG1 and FRLC/FRG1) * * exist, NPOSS does not include hits on dead wires (which may have * * been simulated and then killed in reconstruction). These banks * * can be generated by calling F{P/Q/R}LOCO and FTCORG (in H1REC). * * No similar banks currently exist for the CTD (to my knowledge). * * Note that these banks are also created by the FRCART routine, * * used e.g. in the event display. * * * * Note that H1SIM must be run with the secondary momentum cut * * (SKECUT) set to zero for each track to have a unique STR number; * * the default is for all secondaries to have the same number as * * the parent. * * * * The following values are returned as error codes: * * * * JSTR = 0 - track/digi cross-reference bank not found * * = -1 - digi pointer bank not found * * = -2 - digi pointer invalid * * = -3 - digi pointer list not circular * * * * NHIT and NPOSS are zero in this case. * * * ********************************************************************** PARAMETER (NSUBDT=6,IWCHNK=1000) DIMENSION JDIG(NSUBDT),NNDIG(NSUBDT) DIMENSION INDDP(NSUBDT),INDXR(NSUBDT),INDLC(3),INDG1(3) LOGICAL LDWBK(NSUBDT),LCIRC(NSUBDT) CHARACTER*4 DPNAME(NSUBDT),DPNAMY(NSUBDT),XRNAMY(NSUBDT) CHARACTER*4 LCNAME(3),G1NAME(3) SAVE DPNAME,DPNAMY,XRNAMY,LCNAME,G1NAME,LCIRC COMMON /IUSTRZ/ INDDPX(NSUBDT),INCVPR,INDTRU DATA DPNAME/'FTPX','FTQX','FTRX','CTJX','CVYX','CVZX'/ DATA DPNAMY/'FTPY','FTQY','FTRY','CTJY','CVYY','CVZY'/ DATA XRNAMY/'FRPY','FRQY','FRRY','CRJY','CRYY','CRZY'/ DATA LCIRC/.TRUE.,.TRUE.,.TRUE.,.TRUE.,.FALSE.,.FALSE./ DATA LCNAME/'FPLC','FQLC','FRLC'/ DATA G1NAME/'FPG1','FQG1','FRG1'/ *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. ********************************************************************** JSTR = -1 NHIT = 0 NPOSS = 0 * Zero work bank indices CALL VZERO(INDDPX,NSUBDT) INCVPR = 0 INDTRU = 0 * Copy pointers JDIG(1) = JDIGP JDIG(2) = JDIGQ JDIG(3) = JDIGR JDIG(4) = JDIGJ JDIG(5) = JCVPR JDIG(6) = JCVPR CALL VZERO(NNDIG,NSUBDT) * Unpack the CVPR and z-chamber digi pointer banks if necessary IF (JCVPR.GT.0) THEN IF (NLINK('CVPR',0).LE.0) RETURN CALL BKTOW(IW,'CVPR',0,IW,INCVPR,*9000) JDIG(5) = IBTAB(INCVPR,2,JCVPR) JDIG(6) = IBTAB(INCVPR,4,JCVPR) NNDIG(5) = IBTAB(INCVPR,1,JCVPR) NNDIG(6) = IBTAB(INCVPR,3,JCVPR) * Check that pointer banks exist and unpack (all B16) DO JS=5,6 IF (JDIG(JS).GT.0) THEN IF (NLINK(DPNAME(JS),0).LE.0) GOTO 900 CALL BKTOW(IW,DPNAME(JS),0,IW,INDDPX(JS),*9000) ENDIF END DO ENDIF JSTR = 0 * Get indices for unpacked banks DO JS=1,NSUBDT IF (JDIG(JS).GT.0) THEN INDDP(JS) = NLINK(DPNAMY(JS),0) INDXR(JS) = NLINK(XRNAMY(JS),0) IF (INDDP(JS).LE.0 .OR. INDXR(JS).LE.0) GOTO 900 ELSEIF (JDIG(JS).EQ.0) THEN INDXR(JS) = NLINK(XRNAMY(JS),0) ENDIF IF (JS.LE.3) THEN * See if FT unpacked banks exist INDLC(JS) = NLINK(LCNAME(JS),0) INDG1(JS) = NLINK(G1NAME(JS),0) LDWBK(JS) = INDLC(JS).GT.0 .AND. INDG1(JS).GT.0 ELSE * No dead wire info for CT (?) LDWBK(JS) = .FALSE. ENDIF END DO * Create work bank to store true track numbers CALL WBANK(IW,INDTRU,IWCHNK,*9000) CALL VZERO(IW(INDTRU+1),IWCHNK) * * Main loop over subdetectors * DO 500 JS=1,NSUBDT IF (JDIG(JS).LE.0) GOTO 500 * Get the starting digi pointer IF (LCIRC(JS)) THEN IDIG = JDIG(JS) ELSE IDIG = IBTAB(INDDPX(JS),2,JDIG(JS)) ENDIF NDIG = IW(INDDP(JS)+2) * Loop over digis looking for a corresponding hit ... INUM = 0 100 CONTINUE INUM = INUM + 1 IF (INUM.GT.NDIG) THEN * Pointer list can't be circular JSTR = -3 GOTO 900 ELSEIF (IDIG.LE.0 .OR. IDIG.GT.NDIG) THEN * Pointer is invalid JSTR = -2 GOTO 900 ENDIF JHIT = IBTAB(INDDP(JS),2,IDIG) IF (JHIT.LE.0) GOTO 400 200 CONTINUE * We have a match, so see if this track has been seen before KSTR = IBTAB(INDXR(JS),1,JHIT) IFOUND = 0 NSTR = 0 300 CONTINUE NSTR = NSTR + 1 IMAX = IW(INDTRU) IF (2*NSTR.GE.IMAX) THEN * Extend work bank (probably won't happen, but ...) CALL WBANK(IW,INDTRU,2*IMAX,*9000) CALL VZERO(IW(INDTRU+IMAX+1),IMAX) ENDIF IF (KSTR.EQ.IW(INDTRU+2*NSTR-1)) THEN IFOUND = NSTR ELSEIF (IW(INDTRU+2*NSTR-1).GT.0) THEN GOTO 300 ENDIF IF (IFOUND.EQ.0) THEN * New track number, so store it ... IW(INDTRU+2*NSTR-1) = KSTR IW(INDTRU+2*NSTR) = 1 ELSE * ... or increment the counter IW(INDTRU+2*NSTR) = IW(INDTRU+2*NSTR) + 1 ENDIF * Now see if there's another hit for this digi (can happen!) JHIT = IBTAB(INDXR(JS),3,JHIT) IF (JHIT.GT.0) GOTO 200 400 CONTINUE * Get the next digi pointer, and see if we're back where we started IF (LCIRC(JS)) THEN IDIG = IBTAB(INDDP(JS),1,IDIG) IF (IDIG.NE.JDIG(JS)) GOTO 100 ELSEIF (INUM.LT.NNDIG(JS)) THEN IDIG = IBTAB(INDDPX(JS),2,JDIG(JS)+INUM) GOTO 100 ENDIF 500 CONTINUE * * Now search through the list of tracks to find the best * NHIT = 0 NSTR = 0 600 CONTINUE NSTR = NSTR + 1 IF (IW(INDTRU+2*NSTR).GT.NHIT) THEN NHIT = IW(INDTRU+2*NSTR) JSTR = IW(INDTRU+2*NSTR-1) ENDIF IF (IW(INDTRU+2*NSTR-1).GT.0) GOTO 600 * * Finally, count the total number of hits on the "best" track * NPOSS = 0 INSTRX = NLINK('STRX',0) IF (INSTRX.LE.0 .OR. JSTR.LE.0) GOTO 900 DO 800 JS=1,NSUBDT * Only mask out a subdetector if the pointer is negative IF (JDIG(JS).LT.0 .OR. INDXR(JS).LE.0) GOTO 800 * Get first hit for this track JHIT = IBTAB(INSTRX,JS,JSTR) IF (JHIT.LE.0) GOTO 800 700 CONTINUE * Don't count a hit with no digi as findable IDIG = IBTAB(INDXR(JS),2,JHIT) IF (IDIG.GT.0) THEN IDEAD = 0 IF (LDWBK(JS)) THEN * Check dead wire map (FT only, and only if unpacked banks exist) * NB A wedge-pair can be half dead, but it's a pain to check! ICELL = IBTAB(INDLC(JS),1,IDIG) IDEAD = IBTAB(INDG1(JS),1,ICELL+1) ENDIF IF (IDEAD.EQ.0) NPOSS = NPOSS + 1 ENDIF * Get next hit for this track JHIT = IBTAB(INDXR(JS),4,JHIT) IF (JHIT.GT.0) GOTO 700 800 CONTINUE 900 CONTINUE * * Must make sure all work banks are dropped!!! * CALL WDROP(IW,INDTRU) CALL WDROP(IW,INCVPR) DO JS=1,NSUBDT CALL WDROP(IW,INDDPX(JS)) END DO RETURN 9000 CONTINUE CALL ERRLOG(1301,'S:UTQSTR: Error in bank creation') GOTO 900 END *------------------------------------------------------------------------- SUBROUTINE H1GEA *#********************************************************************** *# * *# SUBROUTINE H1GEA * *# * *# PURPOSE: Perform GEANT simulation for one event. * *# * *# Main steering routine of module 'H1GEA' * *# * *# Changed by M. Korn 02.12.94: merge A.F.'s changes of version * *# 3.03/11 to actual version 3.05/04 in * *# order to allow for use of GEANT 3.21: * *# Changed by A.F. 24.08.94: Make use of seq's GCFLAK and LGCBNK for * *# common GCFLAG and GCBANK-size respectively * *#********************************************************************** *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,BOSMDL. C ------BOSMDL LOGICAL BEGJOB,ENDRUN,BEGRUN,REVENT,ENDJOB,OTHDAT COMMON/BOSMDL/BEGJOB,ENDRUN,BEGRUN,REVENT,ENDJOB,OTHDAT, + LCCRUN,NCCRUN,NEVENT, + IHA,IBS,IDB,IDATEL,LUP,ISN,JSN SAVE /BOSMDL/ C ------ *KEEP,GCTIME. COMMON/GCTIME/TIMINT,TIMEND,ITIME,IGDATE,IGTIME INTEGER ITIME,IGDATE,IGTIME REAL TIMINT,TIMEND C *KEEP,H1OSGO. COMMON /H1OSGO/ LCONFG,IGEAND(13),RGEANC(16),IGEANP(12) *KEND. * "reduced GCFLAG COMMON to avoid clash of NEVENT variables from * BOS and GEANT COMMON/GCFLAG/IDEBUG,IDEMIN,IDEMAX,ITEST,IDRUN,IDEVT,IEORUN + ,IEOTRI,IEVENT,ISWIT(10),IFINIT(20) CHARACTER*8 VERSQQ LOGICAL FIRST,POSITR,FIRSTP PARAMETER (NG=1500000) COMMON/GCBANK/Q(NG) LOGICAL graph /.FALSE./ DATA FIRST/.TRUE./,FIRSTP/.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,VERSQQ. VERSQQ = ' 3.06/36' IVERSQ = 30636 *KEND. * random number handling requested (negative IVERSQ) CALL MODULS('H1GEA',-IVERSQ,'GTR GVX STRBSVXB') CALL MODDEF(30441) IF(BEGJOB)THEN * *KEEP,DATEQQ. IDATQQ = 980710 *KEEP,TIMEQQ. ITIMQQ = 1126 *KEND. WRITE(6,1000)IDATQQ,ITIMQQ 1000 FORMAT( +'1**********************************************************'/ +' ****** ', *KEEP,QFTITLE,N=40. + 40H* H1SIM 3.06/36 23/02/96 17.47.42 *KEND. +,' ******'/ +' ****** Compiled at date ',I6,' and time ',I4,' ******'/ +' **********************************************************') NAHEAD=NAMIND('HEAD') NAHEAR=NAMIND('HEAR') ENDIF * overwrite HEAD bank with correct field value (even before geometry * definition !). For new data overwrite HEAR bank. IF(REVENT.OR.BEGRUN)THEN INHEAR=IW(NAHEAR) CALL UGTBNK('FIEL',INFIEL) IF(INHEAR.NE.0)THEN * create HEAR bank with new length INHEAR=NBANK('HEAR',0,22) * put in correct field value IF(INFIEL.EQ.0)THEN IW(INHEAR+ 6)=11600 ELSE IW(INHEAR+ 6)=NINT(1000.*RW(INFIEL+1)) ENDIF * for REVENT also add the information about e+/e- beams (influences * e-magnets in simulation) IF(REVENT)THEN * calculate POSITR flag only once: IF(FIRSTP)THEN FIRSTP=.FALSE. * check GTR banks and find first lepton, assume positron as default POSITR=.TRUE. INDGTR=IW(NAMIND('GTR ')) IF(INDGTR.GT.0)THEN NTR=IW(INDGTR+2) DO 5 ITR=1,NTR IPDG=IBTAB(INDGTR,7,ITR) IF(IABS(IPDG).EQ.11)THEN POSITR=IPDG.EQ.-11 GOTO 6 ENDIF 5 CONTINUE 6 CONTINUE ENDIF IF(POSITR)THEN WRITE(6,*)' Positron magnet setup used.' ELSE WRITE(6,*)' Electron magnet setup used.' ENDIF LL=LUNLOG() IF(LL.GT.0)THEN IF(POSITR)THEN WRITE(LL,'(A)')'Magnet setup: Positron' ELSE WRITE(LL,'(A)')'Magnet setup: Electron' ENDIF ENDIF ENDIF * and add POSITR flag to HEAR bank IF(POSITR)IW(14)=IBSET(IW(14),16) ENDIF ELSE INHEAD=IW(NAHEAD) IF(INFIEL.EQ.0)THEN IW(INHEAD+10)=11600 ELSE IW(INHEAD+10)=NINT(1000.*RW(INFIEL+1)) ENDIF ENDIF ENDIF * initialize setup only at first event (not at BEGRUN, because the * information about beam polarity and therefor magnet polarity is only * available at first event) IF(REVENT) THEN * prevent second initialisation if run number changes IF(FIRST)THEN FIRST=.FALSE. * create or modify steering banks using the OTTO bank CALL OTTOST * unpack steering information from banks OSGO and OSGD CALL UH1GEA CALL GZEBRA(NG) * "user" initialization CALL GUINIT c--------------------------------------- if(graph) then * set up workstation CALL IGINIT(-1000000) c CALL IGINIT(0) CALL IOPKS(0) CALL IOPWK(1,1,1) CALL IGRNG(20.,20.) CALL IACWK(1) * initialise drawing package CALL GDINIT endif c--------------------------------------- CALL TIMEL(TIMINT) ENDIF END IF if(graph) then CALL GINTER endif * overwrite first word in HEAD bank with information about * configuration setup (LCONFG=1,2,... coming from OSGO bank) IF(REVENT.OR.BEGRUN)THEN INHEAD=IW(NAHEAD) IF(INHEAD.GT.0)IW(INHEAD+1)=1+LCONFG ENDIF IF(REVENT) THEN IEVENT=IEVENT + 1 * create SIPA bank containing relevant simulation parameters CALL USIPA * turn GTR/GVX banks into STR/SVX banks CALL USTSV * initialize event partition CALL GTRIGI * process event (trigger) CALL GTRIG * clear event partition CALL GTRIGC END IF IF(ENDJOB) THEN * "user" termination CALL GULAST END IF CALL MODULF CALL MODDEF(0) RETURN END SUBROUTINE GINTER CHARACTER*6 NAME CHARACTER*4 VNAME CALL GDRAWC('FWDT',2,0.0,10.0,10.0,0.1,0.1) CALL GDSCAL(su,sv) write(6,*) ' GINTER entered....type name of GEANT drawing routine' 10 read(5,'(A6)') NAME IF(NAME.EQ.'STOP') STOP IF(NAME.EQ.'GDRAWC') THEN WRITE(6,*) 'Enter VNAME,IAXIS,CUTVAL,U0,V0,SU,SV' READ(5,'(A4,1x,I1,1x,5F5.1)') vname,iaxis,cutval,u0,v0,su,sv c CALL ICLRWK(0,1) CALL GDRAWC(vname,iaxis,cutval,u0,v0,su,sv) CALL GDSCAL(su,sv) GO TO 10 ENDIF IF(NAME.EQ.'GDRAWX') THEN WRITE(6,*) 'Enter VNAME,CUTTHE,CUTPHI,CUTVAL,TH,PHI,U0,V0,SU,SV' READ(5,'(A4,1x,9F6.2)') vname,cutthe,cutphi,cutval, & theta,phi,u0,v0,su,sv CALL ICLRWK(0,1) CALL GDRAWX(vname,cutthe,cutphi,cutval,theta,phi,u0,v0,su,sv) CALL GDSCAL(su,sv) GO TO 10 ENDIF IF(NAME.EQ.'CLEAR') CALL ICLRWK(0,1) GO TO 10 RETURN END *-----------------------------------------------------------------------