1 jones 1.1 *CMZ :          02/08/94  19.29.57  by  S.Ravndal
  2           *-- Author :
  3                 SUBROUTINE GXPHYS
  4           C.
  5           C.    ******************************************************************
  6           C.    *                                                                *
  7           C.    *      Physics parameters control commands                       *
  8           C.    *                                                                *
  9           C.    *       Author:    R.Brun      **********                        *
 10           C.    *                                                                *
 11           C.    ******************************************************************
 12           C.
 13           *KEEP,GCBANK.
 14                 INTEGER IQ,LQ,NZEBRA,IXSTOR,IXDIV,IXCONS,LMAIN,LR1,JCG
 15                 INTEGER KWBANK,KWWORK,IWS
 16                 REAL GVERSN,ZVERSN,FENDQ,WS,Q
 17           C
 18                 PARAMETER (KWBANK=69000,KWWORK=5200)
 19                 COMMON/GCBANK/NZEBRA,GVERSN,ZVERSN,IXSTOR,IXDIV,IXCONS,FENDQ(16)
 20                +             ,LMAIN,LR1,WS(KWBANK)
 21                 DIMENSION IQ(2),Q(2),LQ(8000),IWS(2)
 22 jones 1.1       EQUIVALENCE (Q(1),IQ(1),LQ(9)),(LQ(1),LMAIN),(IWS(1),WS(1))
 23                 EQUIVALENCE (JCG,JGSTAT)
 24                 INTEGER       JDIGI ,JDRAW ,JHEAD ,JHITS ,JKINE ,JMATE ,JPART
 25                +      ,JROTM ,JRUNG ,JSET  ,JSTAK ,JGSTAT,JTMED ,JTRACK,JVERTX
 26                +      ,JVOLUM,JXYZ  ,JGPAR ,JGPAR2,JSKLT
 27           C
 28                 COMMON/GCLINK/JDIGI ,JDRAW ,JHEAD ,JHITS ,JKINE ,JMATE ,JPART
 29                +      ,JROTM ,JRUNG ,JSET  ,JSTAK ,JGSTAT,JTMED ,JTRACK,JVERTX
 30                +      ,JVOLUM,JXYZ  ,JGPAR ,JGPAR2,JSKLT
 31           C
 32           *KEEP,GCPHYS.
 33                 COMMON/GCPHYS/IPAIR,SPAIR,SLPAIR,ZINTPA,STEPPA
 34                +             ,ICOMP,SCOMP,SLCOMP,ZINTCO,STEPCO
 35                +             ,IPHOT,SPHOT,SLPHOT,ZINTPH,STEPPH
 36                +             ,IPFIS,SPFIS,SLPFIS,ZINTPF,STEPPF
 37                +             ,IDRAY,SDRAY,SLDRAY,ZINTDR,STEPDR
 38                +             ,IANNI,SANNI,SLANNI,ZINTAN,STEPAN
 39                +             ,IBREM,SBREM,SLBREM,ZINTBR,STEPBR
 40                +             ,IHADR,SHADR,SLHADR,ZINTHA,STEPHA
 41                +             ,IMUNU,SMUNU,SLMUNU,ZINTMU,STEPMU
 42                +             ,IDCAY,SDCAY,SLIFE ,SUMLIF,DPHYS1
 43 jones 1.1      +             ,ILOSS,SLOSS,SOLOSS,STLOSS,DPHYS2
 44                +             ,IMULS,SMULS,SOMULS,STMULS,DPHYS3
 45                +             ,IRAYL,SRAYL,SLRAYL,ZINTRA,STEPRA
 46                 COMMON/GCPHLT/ILABS,SLABS,SLLABS,ZINTLA,STEPLA
 47                +             ,ISYNC
 48                +             ,ISTRA
 49           *
 50                 INTEGER IPAIR,ICOMP,IPHOT,IPFIS,IDRAY,IANNI,IBREM,IHADR,IMUNU
 51                +       ,IDCAY,ILOSS,IMULS,IRAYL,ILABS,ISYNC,ISTRA
 52                 REAL    SPAIR,SLPAIR,ZINTPA,STEPPA,SCOMP,SLCOMP,ZINTCO,STEPCO
 53                +       ,SPHOT,SLPHOT,ZINTPH,STEPPH,SPFIS,SLPFIS,ZINTPF,STEPPF
 54                +       ,SDRAY,SLDRAY,ZINTDR,STEPDR,SANNI,SLANNI,ZINTAN,STEPAN
 55                +       ,SBREM,SLBREM,ZINTBR,STEPBR,SHADR,SLHADR,ZINTHA,STEPHA
 56                +       ,SMUNU,SLMUNU,ZINTMU,STEPMU,SDCAY,SLIFE ,SUMLIF,DPHYS1
 57                +       ,SLOSS,SOLOSS,STLOSS,DPHYS2,SMULS,SOMULS,STMULS,DPHYS3
 58                +       ,SRAYL,SLRAYL,ZINTRA,STEPRA,SLABS,SLLABS,ZINTLA,STEPLA
 59           C
 60           *KEEP,GCCUTS.
 61                 COMMON/GCCUTS/CUTGAM,CUTELE,CUTNEU,CUTHAD,CUTMUO,BCUTE,BCUTM
 62                +             ,DCUTE ,DCUTM ,PPCUTM,TOFMAX,GCUTS(5)
 63           C
 64 jones 1.1       REAL          CUTGAM,CUTELE,CUTNEU,CUTHAD,CUTMUO,BCUTE,BCUTM
 65                +             ,DCUTE ,DCUTM ,PPCUTM,TOFMAX,GCUTS
 66           C
 67           *KEEP,GCONSP.
 68                 DOUBLE PRECISION PI,TWOPI,PIBY2,DEGRAD,RADDEG,CLIGHT,BIG,EMASS
 69                 DOUBLE PRECISION EMMU,PMASS,AVO
 70           *
 71                 PARAMETER (PI=3.14159265358979324D0)
 72                 PARAMETER (TWOPI=6.28318530717958648D0)
 73                 PARAMETER (PIBY2=1.57079632679489662D0)
 74                 PARAMETER (DEGRAD=0.0174532925199432958D0)
 75                 PARAMETER (RADDEG=57.2957795130823209D0)
 76                 PARAMETER (CLIGHT=29979245800.D0)
 77                 PARAMETER (BIG=10000000000.D0)
 78                 PARAMETER (EMASS=0.0005109990615D0)
 79                 PARAMETER (EMMU=0.105658387D0)
 80                 PARAMETER (PMASS=0.9382723128D0)
 81                 PARAMETER (AVO=0.60221367D0)
 82           *
 83           *KEEP,GCUNIT.
 84                 COMMON/GCUNIT/LIN,LOUT,NUNITS,LUNITS(5)
 85 jones 1.1       INTEGER LIN,LOUT,NUNITS,LUNITS
 86                 COMMON/GCMAIL/CHMAIL
 87                 CHARACTER*132 CHMAIL
 88           C
 89           *KEEP,GCMULO.
 90                 COMMON/GCMULO/SINMUL(101),COSMUL(101),SQRMUL(101),OMCMOL,CHCMOL
 91                +  ,EKMIN,EKMAX,NEKBIN,NEK1,EKINV,GEKA,GEKB,EKBIN(200),ELOW(200)
 92           C
 93                 REAL SINMUL,COSMUL,SQRMUL,OMCMOL,CHCMOL,EKMIN,EKMAX,ELOW,EKINV
 94                 REAL GEKA,GEKB,EKBIN
 95                 INTEGER NEKBIN,NEK1
 96           C
 97           *KEND.
 98                 DIMENSION UCUTS(10),ULCUTS(10)
 99                 EQUIVALENCE(UCUTS(1),CUTGAM)
100                 DIMENSION MECA(5,13)
101                 EQUIVALENCE (MECA(1,1),IPAIR)
102                 CHARACTER*6 CUTNAM(10)
103                 CHARACTER*4 CEN(10)
104                 CHARACTER*32 CHPATL
105                 CHARACTER*(*) CHNUMB
106 jones 1.1       PARAMETER (CHNUMB='1234567890')
107                 DATA CUTNAM/'CUTGAM','CUTELE','CUTNEU','CUTHAD','CUTMUO',
108                +            'BCUTE' ,'BCUTM' ,'DCUTE' ,'DCUTM' ,'PPCUTM'/
109           C.
110           C.    ------------------------------------------------------------------
111           C.
112                 CALL KUPATL(CHPATL,NPAR)
113           *
114                 IF(CHPATL.EQ.'ANNI')THEN
115                    CALL KUGETI(IANNI)
116           *
117                 ELSEIF(CHPATL.EQ.'AUTO')THEN
118                    CALL KUGETI(IAUTO)
119           *
120                 ELSEIF(CHPATL.EQ.'BREM')THEN
121                    CALL KUGETI(IBREM)
122           *
123                 ELSEIF(CHPATL.EQ.'CKOV')THEN
124                    CALL KUGETI(ICKOV)
125           *
126                 ELSEIF(CHPATL.EQ.'COMP')THEN
127 jones 1.1          CALL KUGETI(ICOMP)
128           *
129                 ELSEIF(CHPATL.EQ.'DCAY')THEN
130                    CALL KUGETI(IDCAY)
131           *
132                 ELSEIF(CHPATL.EQ.'DRAY')THEN
133                    CALL KUGETI(IDRAY)
134           *
135                 ELSEIF(CHPATL.EQ.'ERAN')THEN
136                    CALL KUGETR(EKMIN)
137                    CALL KUGETR(EKMAX)
138                    CALL KUGETI(NEKBIN)
139                    NEKBIN=MIN(NEKBIN,199)
140           *
141                 ELSEIF(CHPATL.EQ.'HADR')THEN
142                    CALL KUGETI(IHADR)
143           *
144                 ELSEIF(CHPATL.EQ.'LABS')THEN
145                    CALL KUGETI(ILABS)
146           *
147                 ELSEIF(CHPATL.EQ.'LOSS')THEN
148 jones 1.1          CALL KUGETI(ILOSS)
149                    IF(ILOSS.EQ.0.OR.ILOSS.EQ.2)THEN
150                       IDRAY=0
151                    ELSE
152                       IDRAY=1
153                    ENDIF
154           *
155                 ELSEIF(CHPATL.EQ.'MULS')THEN
156                    CALL KUGETI(IMULS)
157           *
158                 ELSEIF(CHPATL.EQ.'MUNU')THEN
159                    CALL KUGETI(IMUNU)
160           *
161                 ELSEIF(CHPATL.EQ.'PAIR')THEN
162                    CALL KUGETI(IPAIR)
163           *
164                 ELSEIF(CHPATL.EQ.'PFIS')THEN
165                    CALL KUGETI(IPFIS)
166           *
167                 ELSEIF(CHPATL.EQ.'PHOT')THEN
168                    CALL KUGETI(IPHOT)
169 jones 1.1 *
170                 ELSEIF(CHPATL.EQ.'RAYL')THEN
171                    CALL KUGETI(IRAYL)
172           *
173                 ELSEIF(CHPATL.EQ.'STRA')THEN
174                    CALL KUGETI(ISTRA)
175           *
176                 ELSEIF(CHPATL.EQ.'SYNC')THEN
177                    CALL KUGETI(ISYNC)
178           *
179                 ELSEIF(CHPATL.EQ.'CUTS')THEN
180                    IF(NPAR.LE.0)THEN
181                       WRITE(LOUT,10000)
182           10000       FORMAT(/,' Current PHYSICS parameters:',/)
183                       DO 10 I=1,10
184                          CALL GEVKEV(UCUTS(I),ULCUTS(I),CEN(I))
185                          WRITE(LOUT,10100)CUTNAM(I),ULCUTS(I),CEN(I)
186           10100          FORMAT(5X,A,' = ',F7.2,1X,A)
187              10       CONTINUE
188                       GO TO 999
189                    ENDIF
190 jones 1.1          CALL KUGETR(CUTGAM)
191                    CALL KUGETR(CUTELE)
192                    CALL KUGETR(CUTHAD)
193                    CALL KUGETR(CUTNEU)
194                    CALL KUGETR(CUTMUO)
195                    CALL KUGETR(BCUTE)
196                    CALL KUGETR(BCUTM)
197                    CALL KUGETR(DCUTE)
198                    CALL KUGETR(DCUTM)
199                    CALL KUGETR(PPCUTM)
200                    CALL KUGETR(TOFMAX)
201                    CALL KUGETR(GCUTS(1))
202                    IF(BCUTE.LE.0.)BCUTE=CUTGAM
203                    IF(BCUTM.LE.0.)BCUTM=CUTGAM
204                    IF(DCUTE.LE.0.)DCUTE=CUTELE
205                    IF(DCUTM.LE.0.)DCUTM=CUTELE
206                    IF(PPCUTM.LT.4.*EMASS)PPCUTM=4.*EMASS
207           *
208                 ELSEIF(CHPATL.EQ.'DRPRT')THEN
209                    CALL KUGETI(IPART)
210                    CALL KUGETI(IMATE)
211 jones 1.1          CALL KUGETR(STEP)
212                    CALL KUGETI(NPOINT)
213                    CALL GDRPRT(IPART,IMATE,STEP,NPOINT)
214           *
215                 ELSEIF(CHPATL.EQ.'PHYSI')THEN
216                    IF(JTMED.GT.0)THEN
217                       DO 30 I=1,IQ(JTMED-2)
218                          JTM=LQ(JTMED-I)
219                          IF(JTM.LE.0)GO TO 30
220                          IF(IQ(JTM-2).EQ.0)THEN
221                             CALL MZPUSH(IXCONS,JTM,10,0,'I')
222                             GO TO 30
223                          ENDIF
224                          DO 20 J=1,10
225                             JTMI=LQ(JTM-J)
226                             IF(JTMI.GT.0)THEN
227                                CALL MZDROP(IXCONS,JTMI,' ')
228                             ENDIF
229              20          CONTINUE
230              30       CONTINUE
231                       CALL UCOPY(CUTGAM,Q(JTMED+1),10)
232 jones 1.1             DO 40 I=1,13
233                          Q(JTMED+10+I)=MECA(1,I)
234              40       CONTINUE
235                    ENDIF
236                    IF(JMATE.LE.0)GO TO 999
237                    DO 60 I=1,IQ(JMATE-2)
238                       JMA=LQ(JMATE-I)
239                       IF(JMA.LE.0)GO TO 60
240                       DO 50 J=1,IQ(JMA-2)
241                          IF(J.EQ.4.OR.J.EQ.5)GO TO 60
242                          JM=LQ(JMA-J)
243                          IF(JM.LE.0)GO TO 50
244                          CALL MZDROP(IXCONS,JM,'L')
245              50       CONTINUE
246              60    CONTINUE
247                    CALL MZGARB (IXCONS, 0)
248                    CALL GPHYSI
249                 ENDIF
250           *
251             999 END