C======================================================================= C C V E N U S 4.12 C (VERY ENERGETIC NUCLEAR SCATTERING) C SUBROUTINE-TURBO-VERSION MAY 04, 1994 C C----------------------------------------------------------------------- C C AUTHOR: C ------- C C KLAUS WERNER C C UNIV. HEIDELBERG, INST. F. THEORETISCHE PHYSIK C PHILOSOPHENWEG 19, 6900 HEIDELBERG, GERMANY C WERNER@DHDMPI5.BITNET, WERNER@MINNIE.MPI-HD.MPG.DE, 28877::WERNER C C NOW AT: C UNIVERSITE DE NANTES, SUBATECH - ECOLE DES MINES C 4, RUE ALFRED KASTLER, F44070 NANTES CEDEX 03, FRANCE C E-MAIL: WERNER@NANHP2.IN2P3.FR C FAX: (33) 51 85 84 79 C TEL: (33) 51 85 84 25 C C C SUBROUTINE-TURBO-VERSION 4.12/5: C -------------------------------- C DIETER HECK C FORSCHUNGSZENTRUM KARLSRUHE, INST. F. KERNPHYSIK 3 C POSTFACH 3640, D-76021 KARLSRUHE, GERMANY C E-MAIL: HECK@IK3.FZK.DE C FAX: 07247-82-4075 C TEL: 07247-82-3777 C C LAST CHANGES: OCT 05, 1995 C rename of jdcay to jdecayv oct. 18, 1999 by D.H. C include SAVE statements Sept.26, 2000 by D.H. C----------------------------------------------------------------------- C C VENUS: C ------ C C VENUS IS A MONTE CARLO PROCEDURE TO SIMULATE HADRONIC INTERACTIONS AT C ULTRARELATIVISTIC ENERGIES (HADRON-HADRON, HADRON-NUCLEUS, NUCLEUS- C NUCLEUS SCATTERING), AND ALSO INTERACTIONS INVOLVING LEPTONS (E+E- C ANNIHILATION, LEPTON-NUCLEON, LEPTON-NUCLEUS SCATTERING). C VENUS IS BASED ON GRIBOV-REGGE THEORY (OF MULTIPLE POMERON EXCHANGE) C AND CLASSICAL RELATIVISTIC STRING DYNAMICS. A DETAILED DESCRIPTION CA C BE FOUND IN THE UNIV. HEIDELBERG PREPRINT HD-TVP-93-1 (270 PAGES), C WHICH IS PUBLISHED IN PHYSICS REPORTS 232 (1993) 87-299. C C DISTRIBUTION: C ------------- C C THIS CODE SHOULD NOT BE DISTRIBUTED WITHOUT NOTIFYING THE AUTHOR, IN- C DICATING WHAT THE CODE IS GOING TO BE USED FOR. DEPENDING ON THE TYPE C OF REACTION AND THE KIND OF OBSERVABLES ANALYSED, THE SYSTEMATIC UN- C CERTAINTIES OF THE VENUS SIMULATIONS VARY STRONGLY, AND THIS SHOULD C BE CLARIFIED BEFORE USING VENUS. C C IMPORTANT FEATURES: C ------------------- C C COVARIANT TREATMENT OF SECONDARY INTERACTIONS. EACH PRODUCED PARTICLE C IS ALLOWED TO REINTERACT WITH OTHER PRODUCED PARTICLES OR WITH C SPECTATORS. IMPORTANT FOR HADRON-NUCLEUS, NUCLEUS-NUCLEUS AND C LEPTON-NUCLEUS SCATTERING. C NO FINAL STATE INTERACTION, IF 'RADIAC' IS SET ZERO. C C PARTICIPATION OF ANTIQUARKS (IN ADDITION TO QUARKS) IN THE C COLOUR EXCHANGE MECHANISM TO FORM STRINGS. C C POSSIBILITY OF DIQUARK BREAKUP, LEADING TO MULTI-STRINGS, LIKE C A FORWARD QUARK LINKED VIA TWO (!) STRINGS TO TWO BACKWARD C QUARKS (DOUBLE-STRING). SUCH STRINGS FRAGMENT DIFFERENTLY THAN C QUARK-DIQUARK STRINGS. IN CASE OF THE DOUBLE-STRING, THE FORWARD C QUARK WILL FRAGMENT VIA TWO BREAKS INTO A LEADING BARYON. C C SOPHISTICATED FRAGMENTATION PROCEDURE. SINCE SPACE-TIME C EVOLUTION IS AN IMPORTANT ISSUE CONCERNING FINAL STATE INTER- C ACTIONS, IT IS NOT ENOUGH TO HAVE A FRAGMENTATION MODEL WHICH C WORKS, IT SHOULD HAVE THE RIGHT SPACE-TIME DESCRIPTION! THERE- C FOR THE FIELD-FEYNMAN MODEL OF EARLIER VERSIONS (<3.00) HAS BEEN C ABANDONED AND REPLACED BY A VERY POWERFUL AND APPEALING PROCEDURE C SUGGESTED BY ARTRU/MENNESSIER. C C VERY LARGE RESONANCE TABLE, INCLUDING FOR EXAMPLE ALL NUCLEON C RESONANCES UP TO 2 GEV. THE DECAY TABLE INCLUDES ALSO KSHORT C AND LAMBDA DECAYS. DECAY SUPPRESSION IS GOVERNED BY THE PARAMETERS C 'NDECAY' AND 'NDECAX'. SETTING 'NDECAY' TO 1 SUPPRESSES ALL DECAYS. C FOR FURTHER DETAILS SEARCH FOR 'DECAY SUPPRESSION' IN SUBR. AINITL C C FOR VERSION >= 4.01, WE USE GRIBOVS CUT-POMERON PROBABILITIES TO C DETERMINE THE WEIGHTS FOR MULTI-COLOUR-EXCHANGE. C C----------------------------------------------------------------------- C C PARTICLE ID (SAME AS ISAJET - SEE ISAJET.DOC, F.E.PAIGE) C -------------------------------------------------------- C C QUARKS AND LEPTONS ARE NUMBERED IN ORDER OF MASS: C UP=1 DN=2 ST=3 CH=4 BT=5 TP=6 C NUE=11 E-=12 NUM=13 MU-=14 NUT=15 TAU-=16 C WITH A NEGATIVE SIGN FOR ANTIPARTICLES. C ARBITRARY CONVENTIONS ARE: C GL=9 GM=10 KS=20 KL=-20 W+=80 Z0=90 . C THE CODE FOR A MESON IS AN INTEGER +-JKL, WHERE J.LE.K ARE THE C QUARKS AND L IS THE SPIN. THE SIGN IS FOR THE J QUARK. C FLAVOR SINGLET MESONS ARE ORDERED BY MASS: C PI0=110 ETA=220 ETAP=330 ETAC=440 . C SIMILARLY, THE CODE FOR A BARYON IS A COMPOUND INTEGER +-IJKL C FORMED FROM THE THREE QUARKS I,J,K AND A SPIN LABEL L=0,1. C THE CODE FOR A DIQUARK IS +-IJ00. C C LIST OF IDENT CODES: C C IDENT LABEL MASS CHARGE C 1 UP .30000E+00 .67 C -1 UB .30000E+00 -.67 C 2 DN .30000E+00 -.33 C -2 DB .30000E+00 .33 C 3 ST .50000E+00 -.33 C -3 SB .50000E+00 .33 C 4 CH .16000E+01 .67 C -4 CB .16000E+01 -.67 C 5 BT .49000E+01 -.33 C -5 BB .49000E+01 .33 C 6 TP .30000E+02 .67 C -6 TB .30000E+02 -.67 C C 9 GL 0. 0.00 C C 10 GM 0. 0.00 C C 11 NUE 0. 0.00 C -11 ANUE 0. 0.00 C 12 E- .51100E-03 -1.00 C -12 E+ .51100E-03 1.00 C 13 NUM 0. 0.00 C -13 ANUM 0. 0.00 C 14 MU- .10566E+00 -1.00 C -14 MU+ .10566E+00 1.00 C 15 NUT 0. 0.00 C -15 ANUT 0. 0.00 C 16 TAU- .18070E+01 -1.00 C -16 TAU+ .18070E+01 1.00 C C 20 KS .49767E+00 0.00 C -20 KL .49767E+00 0.00 C C 80 W+ SIN2W=.23 1.00 C -80 W- SIN2W=.23 -1.00 C 90 Z0 SIN2W=.23 0.00 C C 110 PI0 .13496E+00 0.00 C 120 PI+ .13957E+00 1.00 C -120 PI- .13957E+00 -1.00 C 220 ETA .54880E+00 0.00 C 130 K+ .49367E+00 1.00 C -130 K- .49367E+00 -1.00 C 230 K0 .49767E+00 0.00 C -230 AK0 .49767E+00 0.00 C 330 ETAP .95760E+00 0.00 C 140 AD0 .18633E+01 0.00 C -140 D0 .18633E+01 0.00 C 240 D- .18683E+01 -1.00 C -240 D+ .18683E+01 1.00 C 340 F- .20300E+01 -1.00 C -340 F+ .20300E+01 1.00 C 440 ETAC .29760E+01 0.00 C C 111 RHO0 .77000E+00 0.00 C 121 RHO+ .77000E+00 1.00 C -121 RHO- .77000E+00 -1.00 C 221 OMEG .78260E+00 0.00 C 131 K*+ .88810E+00 1.00 C -131 K*- .88810E+00 -1.00 C 231 K*0 .89220E+00 0.00 C -231 AK*0 .89220E+00 0.00 C 331 PHI .10196E+01 0.00 C 141 AD*0 .20060E+01 0.00 C -141 D*0 .20060E+01 0.00 C 241 D*- .20086E+01 -1.00 C -241 D*+ .20086E+01 1.00 C 341 F*- .21400E+01 -1.00 C -341 F*+ .21400E+01 1.00 C 441 JPSI .30970E+01 0.00 C C 1120 P .93828E+00 1.00 C -1120 AP .93828E+00 -1.00 C 1220 N .93957E+00 0.00 C -1220 AN .93957E+00 0.00 C 1130 S+ .11894E+01 1.00 C -1130 AS- .11894E+01 -1.00 C 1230 S0 .11925E+01 0.00 C -1230 AS0 .11925E+01 0.00 C 2130 L .11156E+01 0.00 C -2130 AL .11156E+01 0.00 C 2230 S- .11974E+01 -1.00 C -2230 AS+ .11974E+01 1.00 C 1330 XI0 .13149E+01 0.00 C -1330 AXI0 .13149E+01 0.00 C 2330 XI- .13213E+01 -1.00 C -2330 AXI+ .13213E+01 1.00 C 1140 SC++ .24300E+01 2.00 C -1140 ASC-- .24300E+01 -2.00 C 1240 SC+ .24300E+01 1.00 C -1240 ASC- .24300E+01 -1.00 C 2140 LC+ .22600E+01 1.00 C -2140 ALC- .22600E+01 -1.00 C 2240 SC0 .24300E+01 0.00 C -2240 ASC0 .24300E+01 0.00 C 1340 USC. .25000E+01 1.00 C -1340 AUSC. .25000E+01 -1.00 C 3140 SUC. .24000E+01 1.00 C -3140 ASUC. .24000E+01 -1.00 C 2340 DSC. .25000E+01 0.00 C -2340 ADSC. .25000E+01 0.00 C 3240 SDC. .24000E+01 0.00 C -3240 ASDC. .24000E+01 0.00 C 3340 SSC. .26000E+01 0.00 C -3340 ASSC. .26000E+01 0.00 C 1440 UCC. .35500E+01 2.00 C -1440 AUCC. .35500E+01 -2.00 C 2440 DCC. .35500E+01 1.00 C -2440 ADCC. .35500E+01 -1.00 C 3440 SCC. .37000E+01 1.00 C -3440 ASCC. .37000E+01 -1.00 C C 1111 DL++ .12320E+01 2.00 C -1111 ADL-- .12320E+01 -2.00 C 1121 DL+ .12320E+01 1.00 C -1121 ADL- .12320E+01 -1.00 C 1221 DL0 .12320E+01 0.00 C -1221 ADL0 .12320E+01 0.00 C 2221 DL- .12320E+01 -1.00 C -2221 ADL+ .12320E+01 1.00 C 1131 S*+ .13823E+01 1.00 C -1131 AS*- .13823E+01 -1.00 C 1231 S*0 .13820E+01 0.00 C -1231 AS*0 .13820E+01 0.00 C 2231 S*- .13875E+01 -1.00 C -2231 AS*+ .13875E+01 1.00 C 1331 XI*0 .15318E+01 0.00 C -1331 AXI*0 .15318E+01 0.00 C 2331 XI*- .15350E+01 -1.00 C -2331 AXI*+ .15350E+01 1.00 C 3331 OM- .16722E+01 -1.00 C -3331 AOM+ .16722E+01 1.00 C 1141 UUC* .26300E+01 2.00 C -1141 AUUC* .26300E+01 -2.00 C 1241 UDC* .26300E+01 1.00 C -1241 AUDC* .26300E+01 -1.00 C 2241 DDC* .26300E+01 0.00 C -2241 ADDC* .26300E+01 0.00 C 1341 USC* .27000E+01 1.00 C -1341 AUSC* .27000E+01 -1.00 C 2341 DSC* .27000E+01 0.00 C -2341 ADSC* .27000E+01 0.00 C 3341 SSC* .28000E+01 0.00 C -3341 ASSC* .28000E+01 0.00 C 1441 UCC* .37500E+01 2.00 C -1441 AUCC* .37500E+01 -2.00 C 2441 DCC* .37500E+01 1.00 C -2441 ADCC* .37500E+01 -1.00 C 3441 SCC* .39000E+01 1.00 C -3441 ASCC* .39000E+01 -1.00 C 4441 CCC* .48000E+01 2.00 C -4441 ACCC* .48000E+01 -2.00 C----------------------------------------------------------------------- C C LIST OF SUBROUTINES AND FUNCTIONS OF SUBROUTINE-TURBO-VERSION 4.12 C ------------------------------------------------------------------ C C AVENUS HAHABS HAPAPA HASI HASTFC HASTFL HASTFR HASTFS C HASTFW HASTPR HDECMP HRESCL IDCOMJ IDCOMK IDCOMP IDDECO C IDENCO IDFLAV IDLABL IDMASS IDMIX IDQUAC IDRES IDRESI C IDSPIN IDTAU IDTRA IDTRAI IDTRB IDTRBI IDTR4 C JAMBR1 JAMBR2 JAMFRA JCENTD JCENTP JCENTR JCLUDE JDECA C JDECAYV JDECIN JESTPR JETGEN JFRADE JINTA1 JINTA2 C JINTCC JINTCE JINTCH JINTCL JINTEL JINTFP JINTFS C JINTFU JINTPA JRESCL JSPLIT LEPEXP LEPSTR LEPTAR C NUCINI NUCLCO NUCOGE NUCOLL NUCSTR PVJPSF C RACPRO RANSTC RANXQ SBET SDENSI SGAM SGAU C SHOPAR SJCENT SJCEN4 SJCGAM SMASS SMASSI SMASSP SMASST C SPTF SPTH SPTJ SPTQ SSE0 SSE1 SSPLIT SSPLIX C STAA STXD STXS STXU STXUS STXZNE STXZPR SVA0 C SVA1 UINTEG UTACOS UTAMNU UTAMNX UTAMNY UTAMNZ UTAMST C UTAXIS UTCHM UTCLEA UTHIST UTHSEA UTINVT UTKSIX C UTKSTR UTLOBO UTLOB2 UTLOC UTMSG UTMSGF UTOVEL UTPAGE C UTPART UTPCM UTQUAF UTQZ UTREMB UTREPL UTRESM UTREST C UTROTA UTROT2 UTSTOP UTTAIN UTTAIX UTTAUS UTTAUT UTTUCL C C----------------------------------------------------------------------- C C SUBROUTINE-TURBO-VERSION 4.12: C ------------------------------ C C IT IS TUNED FOR FASTER CALCULATION, ESPECIALLY IF ENERGY AND C TARGET ARE VARYING FROM COLLISION TO COLLISION, AS IS THE CASE IN C THE DEVELOPMENT OF AN AIR SHOWER CASCADE. C IT NEEDS LINKING ROUTINES FOR INPUT AND OUTPUT AND A RANDOM C GENERATOR. ALL PARAMETERS MUST BE SET IN THE LINKING ROUTINES. C FOR CONNECTION WITH THE AIR SHOWER PROGRAM 'CORSIKA', SUCH ROUTINES C ARE AVAILABLE: C RANGEN: RANDOM GENERATOR C UTQSEA: CALC. OF SEA QUARK STRUCTURE FUNCTION INTEGRAL C UTQVAL: CALC. OF VALENCE QUARK STRUCTURE FUNCTION INTEGRAL C VENDAT: INITIALIZATION OF PARTICLE ID TABLE C VENINI: FOR FIRST INITIALIZATION OF PARAMETERS C VENLNK: FOR INITIALIZATION OF ENERGY DEPENDENT PARAMETERS C VSTORE: TO STORE THE GENERATED SECONDARY PARTICLES C C NOTE: THE COMMONS ARE IN GENERAL DIFFERENT FROM THE UNTUNED C VENUS VERSION 4.12 C----------------------------------------------------------------------- C COPYRIGHT AND ANY OTHER APPROPRIATE LEGAL PROTECTION OF THESE C COMPUTER PROGRAMS AND ASSOCIATED DOCUMENTATION RESERVED IN ALL C COUNTRIES OF THE WORLD. C C FZK WELCOMES COMMENTS CONCERNING THE VENUS CODE BUT UNDERTAKES NO C OBLIGATION FOR MAINTENANCE OF THE PROGRAMS, NOR RESPONSIBILITY FOR C THEIR CORRECTNESS, AND ACCEPTS NO LIABILITY WHATSOEVER RESULTING C FROM THE USE OF ITS PROGRAMS. C======================================================================= SUBROUTINE AVENUS C----------------------------------------------------------------------- C GENERATES ONE VENUS EVENT C----------------------------------------------------------------------- COMMON /ACCUM/ AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT * ,NRPTL,NRSTR,NTEVT COMMON /CEVT/ BIMEVT,COLEVT,EGYEVT,PHIEVT,PMXEVT * ,KOLEVT,NEVT,NPJEVT,NTGEVT DOUBLE PRECISION SEEDC,SEEDI COMMON /CSEED/ SEEDC,SEEDI COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT SAVE C----------------------------------------------------------------------- ISH0=ISH ISHS0=ISHSUB IF ( ISHEVT .NE. 0 .AND. NREVT+1 .NE. ISHEVT ) THEN ISH=0 ISHSUB=0 ENDIF CDH IF ( NREVT.EQ.0 .AND. (ISH.EQ.13.OR.ISH.EQ.14) ) CALL UTTIMT CDH IF ( ISH .EQ. 14 ) CALL UTTIMA('*** AVENUS *** ') IF ( ISH .EQ. 17 .OR. ISH .GT. 92 ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,*)'AVENUS (ENTRY)' ENDIF IPAGE=0 CALL UTPAGE IF ( ISH .GE. 91 ) * WRITE(IFCH,113)('-',L=1,79),IPAGE,NREVT+1,SEEDC,('-',L=1,79) 113 FORMAT(/1X,79A1/1X,I5,'.PAGE ' * ,5X,'EVT:',I4,5X,'SEEDC:',D25.15/1X,79A1/) IF ( ICHOIC. EQ. 4 .OR. ICHOIC .EQ. 5 ) GOTO 1000 BIMEVT=-1 NTEVT0=NTEVT 3 NTEVT=NTEVT0 2 NTEVT=NTEVT+1 IF ( ICHOIC .EQ. 1 ) THEN CALL JETGEN(IER) IF ( IER .EQ. 1 ) GOTO 3 ELSEIF ( ICHOIC .EQ. 2 .OR. ICHOIC .EQ. 3 ) THEN CALL NUCOLL ENDIF IF ( ICHOIC .EQ. 1 .OR. ICHOIC .EQ. 2 ) THEN CALL JFRADE(IER) IF ( IER. EQ. 1 ) GOTO 3 ENDIF IF ( (ICHOIC.EQ.2 .OR. ICHOIC.EQ.3) .AND. NEVT.EQ.0 ) THEN BIMEVT=-1 GOTO 2 ENDIF IF ( JERR .GT. 0 ) THEN CALL UTSTOP('AVENUS: JERR > 0 ') ENDIF NREVT=NREVT+1 1000 CONTINUE CDH IF ( ISH .EQ. 14 ) CALL UTTIMA(' AVENUS F ') IF ( ISH .EQ. 17 .OR. ISH .GT. 92 ) THEN WRITE(IFCH,*)'AVENUS (EXIT)' ENDIF ISH=ISH0 ISHSUB=ISHS0 RETURN END C======================================================================= SUBROUTINE HAHABS(PROJ,TARG,IAP,IAT,ISKIP,IRETHH) C----------------------------------------------------------------------- C PERFORMS A BASIC (ONE COLOR EXCHANGE) HADRON-HADRON COLLISION C----------------------------------------------------------------------- PARAMETER (KOLLMX=2500) PARAMETER (MAMX=56) PARAMETER (MXSTR=3000) PARAMETER (NDEP=129) PARAMETER (NDET=129) PARAMETER (NFLAV=6) PARAMETER (NSI=6) PARAMETER (NSIX=40) PARAMETER (NHA=NSIX+2) COMMON /ACCUM/ AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT * ,NRPTL,NRSTR,NTEVT COMMON /CEVT/ BIMEVT,COLEVT,EGYEVT,PHIEVT,PMXEVT * ,KOLEVT,NEVT,NPJEVT,NTGEVT COMMON /CKOL/ KOL COMMON /CLEAD/ COOAV3,COOAV4,LEAD COMMON /CNCE/ NCES,NCOLEX COMMON /CNEW/ KOTRI,NEWCOL,NEWICO COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /COL/ BIMP,BMAX,COORD(4,KOLLMX),DISTCE(KOLLMX) * ,QDEP(NDEP),QDET14(NDET),QDET16(NDET),QDET40(NDET) * ,QDET99(NDET),RMPROJ,RMTARG(4),XDEP(NDEP) * ,XDET14(NDET),XDET16(NDET),XDET40(NDET) * ,XDET99(NDET) * ,KOLL,LTARG,NORD(KOLLMX),NPROJ,NRPROJ(KOLLMX) * ,NRTARG(KOLLMX),NTARG COMMON /CPROJA/ IPROJ,ITARG,KPROJA(NHA,MAMX),KTARGA(NHA,MAMX) COMMON /CPZSTR/ ESTRL,PZSTRL,ISEA,ISTRL COMMON /CSTR/ PSTR(5,MXSTR),ROTSTR(3,MXSTR),XORSTR(4,MXSTR) * ,ICSTR(4,MXSTR),IORSTR(MXSTR),IRLSTR(MXSTR),NSTR COMMON /CSTSH/ NSTSH COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT REAL PROJ(NSI,NHA),PSUM(5),PSUMX(5) * ,SIL(NSI),SILP(NSI),SILT(NSI) * ,SIX(NSI,NSIX),SIXP(NSI,NSIX),SIXT(NSI,NSIX) * ,STRAP(NSI,NSIX+1),STRAT(NSI,NSIX+1) * ,STRLP(NSI,NSIX+1),STRLT(NSI,NSIX+1) * ,STR0(NSI,NSIX+1),TARG(NSI,NHA) INTEGER ICVP(2),ICVT(2),JCVP(NFLAV,2),JCVT(NFLAV,2) CHARACTER XFLAP*3,XFLAT*3,XFLBP*3,XFLBT*3 SAVE C----------------------------------------------------------------------- R=RANGEN() NTRY=0 IRETHH=0 CALL UTREMB(PROJ,TARG,2) GOTO 9 9994 IRET=0 CALL UTREST(PROJ,TARG,2) 9 CONTINUE DO 8 NX=1,NSIX DO 8 N=1,NSI SIXP(N,NX)=0. SIXT(N,NX)=0. 8 CONTINUE CALL HDECMP(PROJ,SIL,SIX) CALL UTKSIX(SIX,KMAXP) CALL HDECMP(TARG,SIL,SIX) CALL UTKSIX(SIX,KMAXT) IF ( ISH .GE. 91 ) THEN WRITE(IFCH,100) ( (PROJ(I,J),I=1,NSI), J=2,KMAXP+2 ) 100 FORMAT ( ' PROJ:',4F13.5,2F8.0/,20(' ',4F13.5,2F8.0/) ) WRITE(IFCH,102) ( (TARG(I,J),I=1,NSI), J=2,KMAXT+2 ) 102 FORMAT ( ' TARG:',4F13.5,2F8.0/,50(' ',4F13.5,2F8.0/) ) ENDIF IF ( ISKIP .EQ. 1 ) GOTO 9999 9997 CALL HDECMP(PROJ,SILP,SIXP) CALL HDECMP(TARG,SILT,SIXT) 1 ICVP(1)=NINT(PROJ(5,1)) ICVP(2)=NINT(PROJ(6,1)) ICVT(1)=NINT(TARG(5,1)) ICVT(2)=NINT(TARG(6,1)) CALL HAPAPA(SILP,IFLAP,XFLAP,PTAP,PTAHP,IFLBP,XFLBP,PTBP,PTBHP * ,NQAQP,ICVP) CALL HAPAPA(SILT,IFLAT,XFLAT,PTAT,PTAHT,IFLBT,XFLBT,PTBT,PTBHT * ,NQAQT,ICVT) IF ( NQAQP*NQAQT .EQ. -1 ) GOTO 1 9998 NTRY=NTRY+1 IF ( NTRY .GT. NTRYMX+1 ) THEN ISKIP=1 GOTO 9999 ENDIF CALL HDECMP(PROJ,SILP,SIXP) CALL HDECMP(TARG,SILT,SIXT) CALL HASTFS(SILP,SIXP,IFLAP,XFLAP,PTAP,PTAHP * ,SILT,SIXT,IFLBT,XFLBT,PTBT,PTBHT,STRAP,IRET,1) IF ( IRET .EQ. 1 ) THEN ISKIP=1 GOTO 9999 ENDIF IF ( IRET .EQ. 2 ) GOTO 9997 IF ( IRET .EQ. 3 ) THEN IF ( XFLBP(1:2) .EQ. 'VA' ) XFLBP(1:2)='SE' IF ( XFLAT(1:2) .EQ. 'VA' ) XFLAT(1:2)='SE' IFLAT=IFLBT IFLBP=IFLAP GOTO 9998 ENDIF IF ( IRET .EQ. 5 ) THEN IF ( XFLAP(1:2) .EQ. 'SE' .AND. XFLBP(1:2) .EQ. 'SE' ) THEN IFLBP=-ABS(IFLBP) IFLAP=IFLBP ENDIF IF ( XFLAT(1:2) .EQ. 'SE' .AND. XFLBT(1:2) .EQ. 'SE' ) THEN IFLAT=-ABS(IFLAT) IFLBT=IFLAT ENDIF GOTO 9998 ENDIF CALL HASTFS(SILT,SIXT,IFLAT,XFLAT,PTAT,PTAHT *,SILP,SIXP,IFLBP,XFLBP,PTBP,PTBHP,STRAT,IRET,2) IF ( IRET .EQ. 1 ) THEN ISKIP=1 GOTO 9999 ENDIF IF ( IRET .EQ. 2 ) GOTO 9997 IF ( IRET .EQ. 3 ) THEN IF ( XFLAP(1:2) .EQ. 'VA' ) XFLAP(1:2)='SE' IF ( XFLBT(1:2) .EQ. 'VA' ) XFLBT(1:2)='SE' IFLBT=IFLAT IFLAP=IFLBP GOTO 9998 ENDIF IF ( IRET .EQ. 5 ) THEN IF ( XFLAP(1:2) .EQ. 'SE' .AND. XFLBP(1:2) .EQ. 'SE' ) THEN IFLAP=-ABS(IFLAP) IFLBP=IFLAP ENDIF IF ( XFLAT(1:2) .EQ. 'SE' .AND. XFLBT(1:2) .EQ. 'SE' ) THEN IFLBT=-ABS(IFLBT) IFLAT=IFLBT ENDIF GOTO 9998 ENDIF CALL HASTFC(SILP,SIXP,IRET) IF ( IRET .EQ. 0 ) THEN CALL HASTFC(SILT,SIXT,IRET) ELSEIF ( IRET .EQ. 1 ) THEN IF ( ISH .GE. 91 ) WRITE(IFCH,*)'LIGHT STRING --> REDO HASTFS' GOTO 9998 ELSEIF ( IRET .EQ. 2 ) THEN IF ( ISH .GE. 91 ) WRITE(IFCH,*)'JC>9 --> REDO HAPAPA' GOTO 9997 ENDIF 9999 CONTINUE IF ( ISKIP .EQ. 1 ) THEN COLEVT=COLEVT-1./NCOLEX CALL HDECMP(PROJ,SILP,SIXP) CALL HDECMP(TARG,SILT,SIXT) IF ( ISH .GE. 91 ) THEN WRITE(IFCH,*)'SKIP' CALL HASTFW(SILP,SIXP) CALL HASTFW(SILT,SIXT) ENDIF ENDIF CALL HASTFL(SILP,SIXP,STRLP) CALL HASTFL(SILT,SIXT,STRLT) IF ( ISKIP .EQ. 1 ) GOTO 9995 CALL IDDECO(ICVP,JCVP) CALL IDDECO(ICVT,JCVT) IF ( XFLAP(1:2).EQ.'VA') JCVP(IABS(IFLAP),1)=JCVP(IABS(IFLAP),1)-1 IF ( XFLBP(1:2).EQ.'VA') JCVP(IABS(IFLBP),2)=JCVP(IABS(IFLBP),2)-1 IF ( XFLAT(1:2).EQ.'VA') JCVT(IABS(IFLAT),1)=JCVT(IABS(IFLAT),1)-1 IF ( XFLBT(1:2).EQ.'VA') JCVT(IABS(IFLBT),2)=JCVT(IABS(IFLBT),2)-1 CALL IDENCO(JCVP,ICVP,IRETEN) IF ( IRETEN .EQ. 1 ) THEN CALL UTSTOP('HAPAPA: IDENCO RET CODE = 1 ') ENDIF CALL IDENCO(JCVT,ICVT,IRETEN) IF ( IRETEN .EQ. 1 ) THEN CALL UTSTOP('HAPAPA: IDENCO RET CODE = 1 ') ENDIF PROJ(5,1)=ICVP(1) PROJ(6,1)=ICVP(2) TARG(5,1)=ICVT(1) TARG(6,1)=ICVT(2) CALL UTKSIX(SIXP,KMAXPN) CALL UTKSIX(SIXT,KMAXTN) IF ( KMAXPN+1 .GT. NSIX ) THEN CALL UTSTOP('HAHABS: DIMENSION NSIX TOO SMALL ') ENDIF IF ( KMAXTN+1 .GT. NSIX ) THEN CALL UTSTOP('HAHABS: DIMENSION NSIX TOO SMALL ') ENDIF KMXP=KMAXPN+1 KMXT=KMAXTN+1 DO 5 N=1,NSI PROJ(N,2)=STRLP(N,1) TARG(N,2)=STRLT(N,1) DO 6 J=1,KMXP PROJ(N,2+J)=SIXP(N,J) 6 CONTINUE DO 7 J=1,KMXT TARG(N,2+J)=SIXT(N,J) 7 CONTINUE KPROJA(2,IPROJ)=KOL IF ( KMAXPN .GT. KMAXP ) THEN DO 2 K=KMAXP+1,KMAXPN KPROJA(2+K,IPROJ)=KOL 2 CONTINUE ENDIF KTARGA(2,ITARG)=KOL IF ( KMAXTN .GT. KMAXT ) THEN DO 3 K=KMAXT+1,KMAXTN KTARGA(2+K,ITARG)=KOL 3 CONTINUE ENDIF 5 CONTINUE NSTSH=0 LEAD=0 ISPLT=0 11 CALL HASTPR(STRAP,ISPLT) IF ( ISPLT .NE. 0 ) THEN CALL UTSTOP('HAHABS: ISPLT /= 0 ') ENDIF ISPLT=0 12 CALL HASTPR(STRAT,ISPLT) IF ( ISPLT .NE. 0 ) THEN CALL UTSTOP('HAHABS: ISPLT /= 0 ') ENDIF IF ( KMAXPN .GT. KMAXP ) THEN PROJ(3,1)=PROJ(3,1)+COORD(3,KOL) PROJ(4,1)=PROJ(4,1)+COORD(4,KOL) ENDIF IF ( KMAXTN .GT. KMAXT ) THEN TARG(3,1)=TARG(3,1)+COORD(3,KOL) TARG(4,1)=TARG(4,1)+COORD(4,KOL) ENDIF KMAXP=KMAXPN KMAXT=KMAXTN 9995 LEAD=1 C WRITE LEADING STRING (PROJ) C --------------------------- IF ( IAP .EQ. 1 ) THEN IF ( KMAXP .GT. 0 ) THEN COOAV3=PROJ(3,1)/KMAXP COOAV4=PROJ(4,1)/KMAXP ELSE COOAV3=COORD(3,KOL) COOAV4=COORD(4,KOL) ENDIF CALL UTKSTR(STRLP,KMAXOR) PZSTRL=0. ESTRL=0. ISEA=1 PSUM(1)=0. PSUM(2)=0. PSUM(3)=0. PSUM(4)=0. DO 22 K=1,KMAXOR PSUM(1)=PSUM(1)+STRLP(1,K) PSUM(2)=PSUM(2)+STRLP(2,K) PSUM(3)=PSUM(3)+STRLP(3,K) PSUM(4)=PSUM(4)+STRLP(4,K) AMPR=0. C-C IF ( K .EQ. 1 ) AMPR=.94 PZSTRL=PZSTRL+STRLP(3,K) ESTRL=ESTRL+SQRT(STRLP(4,K)**2+AMPR**2) IF (K.GE.2.AND.STRLP(5,K).GT.0..AND.STRLP(6,K).GT.0.) ISEA=0 22 CONTINUE PSUM(5)=PSUM(4)**2-PSUM(3)**2-PSUM(2)**2-PSUM(1)**2 IF ( PSUM(5) .GT. 0. ) PSUM(5)=SQRT(PSUM(5)) IF ( PZSTRL/PNLLX.GT.1.-0.850/ENGY**2.AND.ISKIP.NE.1 ) GOTO 1002 ISTRL=0 IF ( NSTSH .EQ. 0 .AND. ISEA .EQ. 1 .AND. * PZSTRL/PNLLX .GT. 1.-10.000/ENGY**2 ) ISTRL=1 DO 23 K=1,KMAXOR DO 23 I=1,NSI STR0(I,K)=STRLP(I,K) 23 CONTINUE NSTR0=NSTR 17 NSTR=NSTR0 ISPLT=0 15 CONTINUE DO 24 K=1,KMAXOR DO 24 I=1,NSI STRLP(I,K)=STR0(I,K) 24 CONTINUE 13 CALL HASTPR(STRLP,ISPLT) IF ( ISPLT .EQ. -1 ) THEN IF ( ISKIP .EQ. 1 ) GOTO 9996 GOTO 9994 ELSEIF ( ISPLT .EQ. -3 ) THEN GOTO 15 ELSEIF ( ISPLT .EQ. -4 ) THEN GOTO 1001 ELSEIF ( ISPLT .EQ. -5 ) THEN GOTO 17 ELSEIF ( ISPLT .GT. 0 ) THEN GOTO 13 ENDIF IF ( NSTR .GT. NSTR0+1 ) THEN PSUMX(1)=0. PSUMX(2)=0. PSUMX(3)=0. PSUMX(4)=0. DO 25 J=NSTR0+1,NSTR PSUMX(1)=PSUMX(1)+PSTR(1,J) PSUMX(2)=PSUMX(2)+PSTR(2,J) PSUMX(3)=PSUMX(3)+PSTR(3,J) PSUMX(4)=PSUMX(4)+PSTR(4,J) 25 CONTINUE PSUMX(5)=PSUMX(4)**2-PSUMX(3)**2-PSUMX(2)**2-PSUMX(1)**2 IF ( PSUMX(5) .GT. 0. ) PSUMX(5)=SQRT(PSUMX(5)) C-C WRITE(6,*)' ' C-C DO 26 J=NSTR0+1,NSTR C-C WRITE(6,109) J,(ICSTR(K,J)/100,K=1,4) C-C * ,SQRT(PSTR(1,J)**2+PSTR(2,J)**2),PSTR(3,J)/PNLLX,PSTR(5,J) C-C * ,IRLSTR(J) C-C26 CONTINUE C-C WRITE(6,*)PSUM C-C WRITE(6,*)PSUMX DO 27 J=NSTR0+1,NSTR PSTR(1,J+NSTR-NSTR0)=PSTR(1,J) PSTR(2,J+NSTR-NSTR0)=PSTR(2,J) PSTR(3,J+NSTR-NSTR0)=PSTR(3,J) PSTR(4,J+NSTR-NSTR0)=PSTR(4,J) 27 CONTINUE CALL HRESCL(NSTR0+1,NSTR,PSUM,IFAIL) IF ( IFAIL .GT. 0 ) THEN C-C WRITE(6,*)'RESCALE FAILED' DO 28 J=NSTR0+1,NSTR PSTR(1,J)=PSTR(1,J+NSTR-NSTR0) PSTR(2,J)=PSTR(2,J+NSTR-NSTR0) PSTR(3,J)=PSTR(3,J+NSTR-NSTR0) PSTR(4,J)=PSTR(4,J+NSTR-NSTR0) 28 CONTINUE ENDIF PSUMX(1)=0. PSUMX(2)=0. PSUMX(3)=0. PSUMX(4)=0. DO 29 J=NSTR0+1,NSTR PSUMX(1)=PSUMX(1)+PSTR(1,J) PSUMX(2)=PSUMX(2)+PSTR(2,J) PSUMX(3)=PSUMX(3)+PSTR(3,J) PSUMX(4)=PSUMX(4)+PSTR(4,J) 29 CONTINUE PSUMX(5)=PSUMX(4)**2-PSUMX(3)**2-PSUMX(2)**2-PSUMX(1)**2 IF ( PSUMX(5) .GT. 0. ) PSUMX(5)=SQRT(PSUMX(5)) C-C DO 30 J=NSTR0+1,NSTR C-C WRITE(6,109) J,(ICSTR(K,J)/100,K=1,4) C-C * ,SQRT(PSTR(1,J)**2+PSTR(2,J)**2),PSTR(3,J)/PNLLX,PSTR(5,J) C-C * ,IRLSTR(J) C-C30 CONTINUE C-C WRITE(6,*)PSUM C-C WRITE(6,*)PSUMX 109 FORMAT(' /CSTR/',I4,3X,4I5,2X,3(E10.3),I4) ENDIF ENDIF C WRITE LEADING STRING (TARG) C --------------------------- IF ( IAT .EQ. 1 ) THEN IF ( KMAXT .GT. 0 ) THEN COOAV3=TARG(3,1)/KMAXT COOAV4=TARG(4,1)/KMAXT ELSE COOAV3=COORD(3,KOL) COOAV4=COORD(4,KOL) ENDIF CALL UTKSTR(STRLT,KMAXOR) PZSTRL=0. ESTRL=0. ISEA=1 PSUM(1)=0. PSUM(2)=0. PSUM(3)=0. PSUM(4)=0. DO 33 K=1,KMAXOR PSUM(1)=PSUM(1)+STRLT(1,K) PSUM(2)=PSUM(2)+STRLT(2,K) PSUM(3)=PSUM(3)+STRLT(3,K) PSUM(4)=PSUM(4)+STRLT(4,K) AMPR=0. C-C IF ( K .EQ. 1 ) AMPR=.94 PZSTRL=PZSTRL+STRLT(3,K) ESTRL=ESTRL+SQRT(STRLT(4,K)**2+AMPR**2) IF ( K.GE.2.AND.STRLT(5,K).GT.0..AND.STRLT(6,K).GT.0. ) ISEA=0 33 CONTINUE PSUM(5)=PSUM(4)**2-PSUM(3)**2-PSUM(2)**2-PSUM(1)**2 IF ( PSUM(5) .GT. 0. ) PSUM(5)=SQRT(PSUM(5)) IF ( -PZSTRL/PNLLX.GT.1.-0.850/ENGY**2.AND.ISKIP.NE.1 )GOTO 1002 ISTRL=0 IF ( NSTSH .EQ. 0 .AND. ISEA .EQ. 1 .AND. * -PZSTRL/PNLLX .GT. 1.-10.000/ENGY**2 ) ISTRL=1 DO 34 K=1,KMAXOR DO 34 I=1,NSI STR0(I,K)=STRLT(I,K) 34 CONTINUE NSTR0=NSTR 18 NSTR=NSTR0 ISPLT=0 16 CONTINUE DO 35 K=1,KMAXOR DO 35 I=1,NSI STRLT(I,K)=STR0(I,K) 35 CONTINUE 14 CALL HASTPR(STRLT,ISPLT) IF ( ISPLT .EQ. -1 ) THEN IF ( ISKIP .EQ. 1 ) GOTO 9996 GOTO 9994 ELSEIF ( ISPLT .EQ. -3 ) THEN GOTO 16 ELSEIF ( ISPLT .EQ. -4 ) THEN GOTO 1001 ELSEIF ( ISPLT .EQ. -5 ) THEN GOTO 18 ELSEIF ( ISPLT .GT. 0 ) THEN GOTO 14 ENDIF IF ( NSTR .GT. NSTR0+1 ) THEN PSUMX(1)=0. PSUMX(2)=0. PSUMX(3)=0. PSUMX(4)=0. DO 36 J=NSTR0+1,NSTR PSUMX(1)=PSUMX(1)+PSTR(1,J) PSUMX(2)=PSUMX(2)+PSTR(2,J) PSUMX(3)=PSUMX(3)+PSTR(3,J) PSUMX(4)=PSUMX(4)+PSTR(4,J) 36 CONTINUE PSUMX(5)=PSUMX(4)**2-PSUMX(3)**2-PSUMX(2)**2-PSUMX(1)**2 IF ( PSUMX(5) .GT. 0. ) PSUMX(5)=SQRT(PSUMX(5)) C-C WRITE(6,*)' ' C-C DO 37 J=NSTR0+1,NSTR C-C WRITE(6,109) J,(ICSTR(K,J)/100,K=1,4) C-C * ,SQRT(PSTR(1,J)**2+PSTR(2,J)**2),PSTR(3,J)/PNLLX,PSTR(5,J) C-C * ,IRLSTR(J) C-C37 CONTINUE C-C WRITE(6,*)PSUM C-C WRITE(6,*)PSUMX DO 38 J=NSTR0+1,NSTR PSTR(1,J+NSTR-NSTR0)=PSTR(1,J) PSTR(2,J+NSTR-NSTR0)=PSTR(2,J) PSTR(3,J+NSTR-NSTR0)=PSTR(3,J) PSTR(4,J+NSTR-NSTR0)=PSTR(4,J) 38 CONTINUE CALL HRESCL(NSTR0+1,NSTR,PSUM,IFAIL) IF ( IFAIL .GT. 0 ) THEN C-C WRITE(6,*)'RESCALE FAILED' DO 39 J=NSTR0+1,NSTR PSTR(1,J)=PSTR(1,J+NSTR-NSTR0) PSTR(2,J)=PSTR(2,J+NSTR-NSTR0) PSTR(3,J)=PSTR(3,J+NSTR-NSTR0) PSTR(4,J)=PSTR(4,J+NSTR-NSTR0) 39 CONTINUE ENDIF PSUMX(1)=0. PSUMX(2)=0. PSUMX(3)=0. PSUMX(4)=0. DO 40 J=NSTR0+1,NSTR PSUMX(1)=PSUMX(1)+PSTR(1,J) PSUMX(2)=PSUMX(2)+PSTR(2,J) PSUMX(3)=PSUMX(3)+PSTR(3,J) PSUMX(4)=PSUMX(4)+PSTR(4,J) 40 CONTINUE PSUMX(5)=PSUMX(4)**2-PSUMX(3)**2-PSUMX(2)**2-PSUMX(1)**2 IF ( PSUMX(5) .GT. 0. ) PSUMX(5)=SQRT(PSUMX(5)) C-C DO 41 J=NSTR0+1,NSTR C-C WRITE(6,109) J,(ICSTR(K,J)/100,K=1,4) C-C * ,SQRT(PSTR(1,J)**2+PSTR(2,J)**2),PSTR(3,J)/PNLLX,PSTR(5,J) C-C * ,IRLSTR(J) C-C41 CONTINUE C-C WRITE(6,*)PSUM C-C WRITE(6,*)PSUMX ENDIF ENDIF C EXIT C ---- IF ( ISH .LT. 91 ) RETURN WRITE(IFCH,100) ( (PROJ(I,J),I=1,NSI), J=2,KMAXP+2 ) WRITE(IFCH,102) ( (TARG(I,J),I=1,NSI), J=2,KMAXT+2 ) 101 FORMAT ( ' ',I3,'. TRIAL') RETURN 9996 CONTINUE IF ( ISH .GE. 91 ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,*)'SKIP IMPOSSIBLE, STRL CANT BE STORED' ENDIF ISKIP=2 RETURN 1001 CONTINUE IF ( ISH .GE. 91 ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,*) * 'SR HAHABS: NOT JUSTIFIED COMPLETE ABSORPTION -> IRETHH=1' ENDIF IRETHH=1 IF ( ISKIP .EQ. 1 ) GOTO 9996 RETURN 1002 CONTINUE IF ( ISH .GE. 91 ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,*)'SR HAHABS: TOO FAST MULTI-STRING -> IRETHH=1' ENDIF IRETHH=1 IF ( ISKIP .EQ. 1 ) THEN CALL UTSTOP('HAHABS: ISKIP=1 SHOULD NOT HAPPEN ') ENDIF RETURN END C======================================================================= SUBROUTINE HAPAPA(SIL,IFLA,XFLA,PTA,PTAH,IFLB,XFLB,PTB,PTBH,NQAQ *,ICV) C----------------------------------------------------------------------- C DETERMINES MOMENTA AND FLAVOR OF PARTICIPATING PARTONS IN A HADRON C----------------------------------------------------------------------- PARAMETER (NFLAV=6) PARAMETER (NPTQ=129) PARAMETER (NSI=6) PARAMETER (NSTRU=2049) COMMON /ACCUM/ AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT * ,NRPTL,NRSTR,NTEVT COMMON /CEVT/ BIMEVT,COLEVT,EGYEVT,PHIEVT,PMXEVT * ,KOLEVT,NEVT,NPJEVT,NTGEVT COMMON /CNEW/ KOTRI,NEWCOL,NEWICO COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /CPTQ/ QPTH(NPTQ),QPTQ(NPTQ),XPTQ(NPTQ),QPTQMX,QPTHMX COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT REAL PROBAB(NFLAV),PROBSU(NFLAV+1),SIL(NSI) INTEGER ICV(2),ID(2),JC(NFLAV,2),JCV(NFLAV,2) CHARACTER CHPT*1,XFLA*3,XFLB*3 SAVE C----------------------------------------------------------------------- SGN=SIGN(1.,SIL(3)) IF ( SGN .GT. 0. ) THEN QVALC=QVAPC QSEAC=QSEPC CHPT='P' W=WPROJ ELSE QVALC=QVATC QSEAC=QSETC CHPT='T' W=WTARG ENDIF CALL IDDECO(ICV,JCV) NVQ=0 NVA=0 DO 12 I=1,NFLAV IF ( ISH.GE.0 .AND. (JCV(I,1).LT.0.OR.JCV(I,2).LT.0) ) THEN CALL UTMSG('HAHABS') WRITE(IFCH,*)'***** NEGATIVE JCV' WRITE(IFCH,*)'JCV:' WRITE(IFCH,*)JCV CALL UTMSGF ENDIF NVQ=NVQ+JCV(I,1) NVA=NVA+JCV(I,2) 12 CONTINUE ID(1)=NINT(SIL(4+1)) ID(2)=NINT(SIL(4+2)) CALL IDDECO(ID,JC) NQU=0 NAQ=0 DO 11 I=1,NFLAV NQU=NQU+JC(I,1) NAQ=NAQ+JC(I,2) 11 CONTINUE NEQ=NQU-NAQ C DETERMINE NQAQ,IVAL1,IVAL2 C -------------------------- NQAQ=0 IVAL=0 IF ( RANGEN() .GT. W ) THEN IF ( NEQ .GT. NEQMN ) THEN PQ=1. ELSE PQ=0. ENDIF IF ( NEQ .LT. NEQMX ) THEN PA=1. ELSE PA=0. ENDIF SUM=(NVQ*PQ+NVA*PA*IAQU)*QVALC+QSEAC*.5*(PQ+PA*IAQU) IF ( SUM .EQ. 0. ) GOTO 14 SUMI = 1./SUM PVQ=NVQ*PQ*QVALC*SUMI PVA=NVA*PA*IAQU*QVALC*SUMI PSQ=.5*PQ*QSEAC*SUMI PSA=.5*PA*IAQU*QSEAC*SUMI R=RANGEN() IF ( R .LT. PVQ+PVA ) IVAL=1 NQAQ=-1 IF ( IVAL .EQ. 1 .AND. R .LT. PVQ ) NQAQ=1 IF ( IVAL .EQ. 0 .AND. R .LT. PVQ+PVA+PSQ ) NQAQ=1 IF ( NQU-NAQ-NQAQ .LT. NEQMN ) THEN IF ( ISH .GE. 90 ) THEN CALL UTMSG('HAPAPA') WRITE(IFCH,*)'***** NEQ < NEQMN' WRITE(IFCH,*)'PVQ/A PSQ/A:',PVQ,PVA,PSQ,PSA WRITE(IFCH,*)'NQAQ:',NQAQ CALL UTMSGF ENDIF NQAQ=0 ENDIF IF ( NQU-NAQ-NQAQ .GT. NEQMX ) THEN IF ( ISH .GE. 90 ) THEN IF ( ISH .GE. 91 ) WRITE(IFCH,*)' ' CALL UTMSG('HAPAPA') WRITE(IFCH,*)'***** NEQ > NEQMX' WRITE(IFCH,*)'PVQ/A PSQ/A:',PVQ,PVA,PSQ,PSA WRITE(IFCH,*)'NQAQ:',NQAQ IF ( ISH .GE. 91 ) WRITE(IFCH,*)' ' ENDIF NQAQ=0 ENDIF IF ( NQU-NAQ-NQAQ .LT. NEQMN ) THEN CALL UTSTOP('HAPAPA: NEQ.LT.NEQMN ') ENDIF IF ( NQU-NAQ-NQAQ .GT. NEQMX ) THEN CALL UTSTOP('HAPAPA: NEQ.GT.NEQMX ') ENDIF ENDIF 14 CONTINUE IVAL1=IVAL IVAL2=IVAL IF ( NQAQ .EQ. 0 ) THEN IVAL1=0 SUM=NVQ*QVALC+QSEAC*.5 IF ( SUM .EQ. 0. ) GOTO 15 SUMI = 1./SUM PVQ=NVQ*QVALC*SUMI PSQ=.5*QSEAC*SUMI R=RANGEN() IF ( R .LT. PVQ ) IVAL1=1 15 CONTINUE C-C IF ( NVQ.GT.0 .AND. RANGEN().LT.PVALEN ) IVAL1=1 IVAL2=0 SUM=NVA*IAQU*QVALC+QSEAC*.5*IAQU IF ( SUM .EQ. 0. ) GOTO 16 SUMI = 1./SUM PVA=NVA*IAQU*QVALC*SUMI PSA=.5*IAQU*QSEAC*SUMI R=RANGEN() IF ( R .LT. PVA ) IVAL2=1 16 CONTINUE C-C IF ( NVA.GT.0 .AND. RANGEN().LT.PVALEN ) IVAL2=1 IF ( IVAL1 .EQ. 1 .AND. IVAL2 .EQ. 1 ) THEN R=RANGEN() IF ( R .LT. 0.5 ) THEN IVAL1=0 ELSE IVAL2=0 ENDIF ENDIF ENDIF C QUARK C ----- XFLA='---' IF ( NQAQ .GE. 0 ) THEN IF ( IVAL1 .EQ. 1 ) THEN PROBAB(1)=JCV(1,1) PROBAB(2)=JCV(2,1) PROBAB(3)=JCV(3,1) PROBAB(4)=JCV(4,1) SU=PROBAB(1)+PROBAB(2)+PROBAB(3)+PROBAB(4) XFLA='VA'//CHPT ELSE PROBAB(1)=1. PROBAB(2)=1. PROBAB(3)=RSTRAS PROBAB(4)=0. SU=2.+PROBAB(3) XFLA='SE'//CHPT ENDIF PROBSU(1)=0. PROBSU(2)=1./SU*PROBAB(1) PROBSU(3)=1./SU*PROBAB(2)+PROBSU(2) PROBSU(4)=1./SU*PROBAB(3)+PROBSU(3) PROBSU(5)=1./SU*PROBAB(4)+PROBSU(4) R=RANGEN() IF ( R .LE. PROBSU(2) ) THEN IFLA=1 ELSEIF ( R .LE. PROBSU(3) ) THEN IFLA=2 ELSEIF ( R .LE. PROBSU(4) ) THEN IFLA=3 ELSE IFLA=4 ENDIF R=RANGEN() IF ( IOPTQ .EQ. 2 ) THEN PTA = SQRT( -4.*PTQ**2/PI * LOG(1.-R*QPTQMX) ) ELSEIF ( IOPTQ .EQ. 3 ) THEN PTA = PTQ*SQRT( QPTQMX*R/(1.-QPTQMX*R) ) ELSE PTA=UTINVT(NPTQ,XPTQ,QPTQ,R*QPTQ(NPTQ)) ENDIF PTAH=PTH*SQRT( 1./SQRT(1.-2.*PTH**2*RANGEN()*QPTHMX) - 1. ) ENDIF C ANTIQUARK C --------- XFLB='---' IF ( NQAQ .LE. 0 ) THEN IF ( IVAL2 .EQ. 1 ) THEN PROBAB(1)=JCV(1,2) PROBAB(2)=JCV(2,2) PROBAB(3)=JCV(3,2) PROBAB(4)=JCV(4,2) SU=PROBAB(1)+PROBAB(2)+PROBAB(3)+PROBAB(4) XFLB='VA'//CHPT ELSE PROBAB(1)=1. PROBAB(2)=1. PROBAB(3)=RSTRAS SU=2.+RSTRAS PROBAB(4)=0. XFLB='SE'//CHPT ENDIF PROBSU(1)=0. PROBSU(2)=1./SU*PROBAB(1) PROBSU(3)=1./SU*PROBAB(2)+PROBSU(2) PROBSU(4)=1./SU*PROBAB(3)+PROBSU(3) PROBSU(5)=1./SU*PROBAB(4)+PROBSU(4) R=RANGEN() IF ( R .LE. PROBSU(2) ) THEN IFLB=1 ELSEIF ( R .LE. PROBSU(3) ) THEN IFLB=2 ELSEIF ( R .LE. PROBSU(4) ) THEN IFLB=3 ELSE IFLB=4 ENDIF IF ( NQAQ.EQ.0 .AND. IVAL1.EQ.0 .AND. IVAL2.EQ.0 ) IFLB=IFLA C-C IF ( NQAQ.EQ.0 .AND. IVAL2.EQ.0 ) IFLB=IFLA C-C IF ( NQAQ.EQ.0 .AND. IVAL1.EQ.0 ) IFLA=IFLB R=RANGEN() IF ( IOPTQ .EQ. 2 ) THEN PTB = SQRT( -4.*PTQ**2/PI * LOG(1.-QPTQMX*R) ) ELSEIF ( IOPTQ .EQ. 3 ) THEN PTB = PTQ*SQRT( QPTQMX*R/(1.-QPTQMX*R) ) ELSE PTB=UTINVT(NPTQ,XPTQ,QPTQ,R*QPTQ(NPTQ)) ENDIF PTBH=PTH*SQRT( 1./SQRT(1.-2.*PTH**2*RANGEN()*QPTHMX) - 1. ) ENDIF IF ( NQAQ.EQ.0 .AND. IVAL1.EQ.0 .AND. IVAL2.EQ.0 ) THEN IFLA=-IFLA IFLB=-IFLB ENDIF RETURN END C======================================================================= SUBROUTINE HASI(QAQ,SIL,IFL,XFL,PT0,PT0H,SI,IRET,JORD,IXFLAB * ,PTDIFF) C----------------------------------------------------------------------- C DETERMINES STRING INGREDIENTS (=JETS) C IRET=0: OK C IRET=1: REMNANT CHANGES DIRECTION C IRET=2: JC(,)=10 C----------------------------------------------------------------------- PARAMETER (NFLAV=6) PARAMETER (NSI=6) COMMON /ACCUM/ AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT * ,NRPTL,NRSTR,NTEVT COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT REAL PTDIFF(2),SI(NSI),SIL(NSI) INTEGER IC(2),ID(2),JC(NFLAV,2) CHARACTER QAQ*5,XFL*3 SAVE C----------------------------------------------------------------------- IRET=0 IRETX=0 NTRY=0 PTDIFF(1)=0. PTDIFF(2)=0. IFLA=ABS(IFL) IF ( XFL .EQ. '000' ) THEN DO 11 J=3,NSI SI(J)=0. 11 CONTINUE ELSE DO 10 J=1,NSI SI(J)=0. 10 CONTINUE ENDIF IF ( XFL .EQ. '---' ) GOTO 1000 IF ( JORD .EQ. 1 ) THEN IF ( QAQ .EQ. 'QUARK' ) THEN AMS=AMPROJ ELSEIF ( QAQ .EQ. 'ANTIQ' ) THEN AMS=AMTARG ENDIF ELSEIF ( JORD .EQ. 2 ) THEN IF ( QAQ .EQ. 'ANTIQ' ) THEN AMS=AMPROJ ELSEIF ( QAQ .EQ. 'QUARK' ) THEN AMS=AMTARG ENDIF ENDIF C-C ENLL=SQRT(AMS**2+PNLLX**2) ENLL=SIL(4) SGN=SIGN(1.,SIL(3)) IF ( RANGEN() .LE. PHARD ) THEN IHARD=1 ELSE IHARD=0 ENDIF ID(1)=NINT(SIL(4+1)) ID(2)=NINT(SIL(4+2)) CALL IDDECO(ID,JC) 9999 NTRY=NTRY+1 IF ( NTRY .GT. 20 ) THEN IRET=1 GOTO 1000 ENDIF IF ( IHARD .EQ. 0 ) THEN PT=PT0 IF ( PT .GT. ENLL ) PT=RANGEN()*ENLL ENMIN=0. ELSE PT=PT0H IF ( PT .GT. ENLL ) PT=RANGEN()*ENLL ENMIN=PT ENDIF PTFULL=PT LO=0 51 LO=LO+1 IF ( XFL .EQ. '000' ) THEN EN=0. PT=0. ELSE EN=RANSTC(XFL,ENMIN/ENLL)*ENLL ENDIF IF ( PT .GT. EN ) THEN IF ( RANGEN() .LT. 0.5 .AND. LO .LE. 10 ) GOTO 51 PT=RANGEN()*EN ENDIF PHI=2.*PI*RANGEN() IF ( XFL .NE. '000' ) THEN SI(1)=PT*COS(PHI) SI(2)=PT*SIN(PHI) SI(3)=SGN*SQRT(EN**2-PT**2) IF ( SI(1).EQ.0. .AND. SI(2).EQ.0. .AND. SI(3).EQ.0. ) THEN IRETX=1 IRET=1 GOTO 1000 ENDIF C-C PTDIFF(1)=(PTFULL-PT)*COS(PHI) C-C PTDIFF(2)=(PTFULL-PT)*SIN(PHI) ENDIF IF ( (SIL(3)-SI(3))*SIL(3) .LT. 0. ) THEN IF ( ISH .GE. 94 ) WRITE(IFCH,*)'SIL,SI,ENLL,EN',SIL,SI,ENLL,EN GOTO 9999 ENDIF SI(4)=SQRT(SI(1)**2+SI(2)**2+SI(3)**2) IF ( QAQ .EQ. 'QUARK' ) THEN SI(5)=10**(NFLAV-IFLA) ELSEIF ( QAQ .EQ. 'ANTIQ' ) THEN SI(6)=10**(NFLAV-IFLA) ENDIF IF ( IXFLAB .EQ. 0 ) THEN SIL(1)=SIL(1)-SI(1) SIL(2)=SIL(2)-SI(2) SIL(3)=SIL(3)-SI(3) SIL(4)=SQRT(SIL(1)**2+SIL(2)**2+SIL(3)**2) ENDIF IF ( JC(IFLA,1) .GT. 0 ) THEN L1=1 ELSE L1=0 ENDIF IF ( JC(IFLA,2) .GT. 0 ) THEN L2=1 ELSE L2=0 ENDIF IF ( QAQ .EQ. 'QUARK' ) THEN IF ( L1 .EQ. 0 ) THEN JC(IFLA,2)=JC(IFLA,2)+1 ELSE JC(IFLA,1)=JC(IFLA,1)-1 ENDIF ELSEIF ( QAQ .EQ. 'ANTIQ' ) THEN IF ( L2 .EQ. 0 ) THEN JC(IFLA,1)=JC(IFLA,1)+1 ELSE JC(IFLA,2)=JC(IFLA,2)-1 ENDIF ENDIF IF ( JC(IFLA,1) .EQ. 10 .OR. JC(IFLA,2) .EQ. 10 ) GOTO 9998 CALL IDENCO(JC,IC,IRETEN) IF ( IRETEN .EQ. 1 ) THEN CALL UTSTOP('HASI : IDENCO RET CODE = 1 ') ENDIF SIL(5)=IC(1) SIL(6)=IC(2) GOTO 1000 9998 IRET=2 IF ( ISH .GE. 90 ) THEN CALL UTMSG('HASI ') WRITE(IFCH,*)'***** JC(,)=10' WRITE(IFCH,*)JC CALL UTMSGF ENDIF 1000 CONTINUE IF ( ISH .GE. 90 .AND. IRETX .EQ. 1 ) THEN CALL UTMSG('HASI ') WRITE(IFCH,*)'***** SI(1/2/3)=0' WRITE(IFCH,*)SI CALL UTMSGF ENDIF IF ( ISH .GE. 93 ) THEN IF ( IRET .NE. 0 .OR. NTRY .GT. 1 ) * WRITE(IFCH,*)'IRET=',IRET,' NTRY=',NTRY IF ( NTRY .GT. 0 ) THEN WRITE(IFCH,100)XFL,PT0,PT,EN,EN/ENLL 100 FORMAT(' HASI: XFL=',A3 * ,' PT0=',E10.3,' PT=',E10.3,' EN=',E10.3,' X=',E10.3) ELSEIF ( NTRY .EQ. 0 ) THEN WRITE(IFCH,101)XFL 101 FORMAT(1X,'HASI: XFL=',A3) ENDIF ENDIF RETURN END C======================================================================= SUBROUTINE HASTFC(SIL,SIX,IRET) C----------------------------------------------------------------------- C CHECKS LONG STRINGS C IRET=0: OK C IRET=1: MASS .LT. MINIMAL MASS C IRET=2: JC(,) .GT. 9 C----------------------------------------------------------------------- PARAMETER (NFLAV=6) PARAMETER (NSI=6) PARAMETER (NSIX=40) COMMON /ACCUM/ AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT * ,NRPTL,NRSTR,NTEVT COMMON /CNCE/ NCES,NCOLEX COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT REAL SI(NSI),SIL(NSI),SIX(NSI,NSIX) INTEGER IC(2),JC(NFLAV,2),JCP(NFLAV,2) SAVE C----------------------------------------------------------------------- IRET=0 CALL UTKSIX(SIX,KMAX) IF ( KMAX .LT. 1 ) GOTO 9000 SI(1)=SIL(1) SI(2)=SIL(2) SI(3)=SIL(3) SI(4)=SIL(4) DO 110 K=1,KMAX SI(1)=SI(1)+SIX(1,K) SI(2)=SI(2)+SIX(2,K) SI(3)=SI(3)+SIX(3,K) SI(4)=SI(4)+SIX(4,K) 110 CONTINUE S=SI(4)**2-SI(1)**2-SI(2)**2-SI(3)**2 IC(1)=NINT(SIL(5)) IC(2)=NINT(SIL(6)) CALL IDDECO(IC,JC) DO 130 K=1,KMAX IC(1)=NINT(ABS(SIX(5,K))) IC(2)=NINT(ABS(SIX(6,K))) CALL IDDECO(IC,JCP) DO 120 I=1,NFLAV JC(I,1)=JC(I,1)+JCP(I,1) JC(I,2)=JC(I,2)+JCP(I,2) 120 CONTINUE 130 CONTINUE DO 125 I=1,NFLAV IF ( JC(I,1)-JC(I,2) .GE. 10 ) IRET=2 IF ( JC(I,1)-JC(I,2) .LE. -10 ) IRET=2 125 CONTINUE IF ( IRET .EQ. 2 ) GOTO 9000 KEU=JC(1,1)-JC(1,2) KED=JC(2,1)-JC(2,2) KES=JC(3,1)-JC(3,2) KEC=JC(4,1)-JC(4,2) AMIN=UTAMNU(KEU,KED,KES,KEC,4)*0.5 C-C IF ( S .LT. AMIN**2 ) IRET=1 9000 CONTINUE IF ( ISH .GE. 94 ) THEN WRITE(IFCH,*)' ' IF ( IRET .EQ. 0 ) THEN WRITE(IFCH,*)('-',L=1,79) ELSE WRITE(IFCH,*)('#',L=1,79) ENDIF WRITE(IFCH,*)'IRET= ',IRET ,' KMAX= ',KMAX,' NREVT= ',NREVT * ,' NCES= ',NCES WRITE(IFCH,8004)SIL 8004 FORMAT(' SIL: ',4F13.5,2F8.0) IF ( KMAX .GT. 0 ) THEN WRITE(IFCH,8007)(SIX(I,1),I=1,NSI) 8007 FORMAT(' SIX: ',4F13.5,2F8.0) IF ( KMAX .GT. 1 ) THEN DO 1 J=2,KMAX WRITE(IFCH,8008)(SIX(I,J),I=1,NSI) 1 CONTINUE 8008 FORMAT(' ',4F13.5,2F8.0) ENDIF WRITE(IFCH,8005)(SI(I),I=1,4) 8005 FORMAT(' SI: ',4F13.5) WRITE(IFCH,8006)(SI(I)**2,I=1,4) 8006 FORMAT(' SI^2:',4F13.5) WRITE(IFCH,*)'JC:' WRITE(IFCH,*)JC WRITE(IFCH,*)'KEU,KED,KES,KEC: ',KEU,KED,KES,KEC WRITE(IFCH,*)'S= ',S,' AMIN**2= ',AMIN**2,' AMIN= ',AMIN ENDIF IF ( IRET .NE. 0 ) THEN WRITE(IFCH,*)('#',L=1,79) ELSE WRITE(IFCH,*)('-',L=1,79) ENDIF WRITE(IFCH,*)' ' ENDIF IF ( IRET .NE. 0 ) RETURN IF ( ISH .GE. 91 ) CALL HASTFW (SIL,SIX) RETURN END C======================================================================= SUBROUTINE HASTFL(SIL,SIX,STRL) C----------------------------------------------------------------------- C FORMS A LEADING STRING C----------------------------------------------------------------------- PARAMETER (NSI=6) PARAMETER (NSIX=40) REAL SIL(NSI),SIX(NSI,NSIX),STRL(NSI,NSIX+1) SAVE C----------------------------------------------------------------------- DO 100 N=1,NSI STRL(N,1)=SIL(N) STRL(N,2)=0. 100 CONTINUE CALL UTKSIX(SIX,KMAX) IF ( KMAX .EQ. 0 ) RETURN DO 111 K=1,KMAX DO 110 N=1,NSI STRL(N,K+1)=SIX(N,K) 110 CONTINUE 111 CONTINUE DO 120 N=1,NSI STRL(N,KMAX+2)=0. 120 CONTINUE RETURN END C======================================================================= SUBROUTINE HASTFR(SILA,SILB,SIA,SIB,IRET) C----------------------------------------------------------------------- C SUBTRACTS SIA-SIB FROM SILA-SILB (ONLY MOMENTUM COMPONENTS) C----------------------------------------------------------------------- PARAMETER (NSI=6) COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT DOUBLE PRECISION A,B,D,DAUXIL,PAB(4),PAM,PAP,PA3,PA4 * ,PEM,PEP,PIM,PIP,PI3,PI4,PLAB(4) * ,POT,POX,POY,PUT,PUX,PUY,PYM,PYP,SLA * ,SSIA(NSI),SSIB(NSI),SSILA(NSI),SSILB(NSI) REAL SIA(NSI),SIB(NSI),SILA(NSI),SILB(NSI) SAVE C----------------------------------------------------------------------- IRET=0 DO 12 I=1,4 SSILB(I)=SILB(I) SSILA(I)=SILA(I) PLAB(I)=SSILA(I)+SSILB(I) SSIB(I)=SIB(I) SSIA(I)=SIA(I) PAB(I)=SSIA(I)+SSIB(I) 12 CONTINUE SLA=SIGN(1.D0, SSILA(3)) IF ( ISH.GE.0 .AND. SSIA(3)*SSILA(3) .LT. 0.D0 ) THEN CALL UTMSG('HASTFR') WRITE(IFCH,*)'***** SSIA(3)*SSILA(3)<0' WRITE(IFCH,*)SSIA(3),SSILA(3) CALL UTMSGF ENDIF A=0.D0 D=0.D0 PYP=0.D0 PYM=0.D0 PIP=0.D0 PAM=0.D0 POX=SSILA(1)-SSIA(1) POY=SSILA(2)-SSIA(2) POT=SQRT(POX**2+POY**2) PUX=SSILB(1)-SSIB(1) PUY=SSILB(2)-SSIB(2) PUT=SQRT(PUX**2+PUY**2) DAUXIL = SLA*(PLAB(3)-PAB(3)) PEP= PLAB(4)-PAB(4) + DAUXIL PEM= PLAB(4)-PAB(4) - DAUXIL IF ( PEP .LT. 0.D0 ) GOTO 9001 IF ( PEM .LT. 0.D0 ) GOTO 9001 A=(PEM*PEP-PUT**2-POT**2)*0.5D0 D=PUT*POT DAUXIL = A**2 - D**2 IF ( DAUXIL .LT. 0.D0 ) GOTO 9001 B=SQRT(DAUXIL) PYP=(A+PUT**2-B)/PEM PYM=(A+POT**2-B)/PEP IF ( PYP .LT. 0.D0 ) GOTO 9001 IF ( PYM .LT. 0.D0 ) GOTO 9001 PIP=PEP-PYP IF ( PIP .LT. 0.D0 ) GOTO 9001 PIM=PYM PAP=PYP PAM=PEM-PYM IF ( PAM .LT. 0.D0 ) GOTO 9001 PI3=(PIP-PIM)*0.5D0*SLA PI4=(PIP+PIM)*0.5D0 PA3=(PAP-PAM)*0.5D0*SLA PA4=(PAP+PAM)*0.5D0 IF ( PI3*SSILA(3) .LT. 0.D0 ) GOTO 9001 IF ( PA3*SSILB(3) .LT. 0.D0 ) GOTO 9001 SSILA(1)=POX SSILA(2)=POY SSILA(3)=PI3 SSILA(4)=PI4 SSILB(1)=PUX SSILB(2)=PUY SSILB(3)=PA3 SSILB(4)=PA4 DO 13 I=1,4 SILA(I)=SSILA(I) SILB(I)=SSILB(I) SIA(I)=SSIA(I) SIB(I)=SSIB(I) 13 CONTINUE IF ( ISH .LT. 90 ) GOTO 9000 IF ( ABS(PIP*PIM-POT**2) .GT. 1.D-4 ) THEN CALL UTMSG('HASTFR') WRITE(IFCH,*)'***** PIP*PIM /= POT**2' WRITE(IFCH,*)'PIP*PIM=',PIP*PIM WRITE(IFCH,*)'POT**2=',POT**2 WRITE(IFCH,*)'PIP=',PIP WRITE(IFCH,*)'PIM=',PIM WRITE(IFCH,*)'POT=',POT CALL UTMSGF ENDIF IF ( ABS(PAP*PAM-PUT**2) .GT. 1.D-4 ) THEN CALL UTMSG('HASTFR') WRITE(IFCH,*)'***** PAP*PAM /= PUT**2' WRITE(IFCH,*)'PAP*PAM=',PAP*PAM WRITE(IFCH,*)'PUT**2=',PUT**2 WRITE(IFCH,*)'PAP=',PAP WRITE(IFCH,*)'PAM=',PAM WRITE(IFCH,*)'PUT=',PUT CALL UTMSGF ENDIF IF ( ABS(SSILA(4)**2 * -SSILA(1)**2-SSILA(2)**2-SSILA(3)**2) .GT. 1.D-4 ) THEN CALL UTMSG('HASTFR') WRITE(IFCH,*)'***** MASS**2 OF SSILA NONZERO' WRITE(IFCH,*)'MASS**2=',SSILA(4)**2 * -SSILA(1)**2-SSILA(2)**2-SSILA(3)**2 CALL UTMSGF ENDIF IF ( ABS(SSILB(4)**2 * -SSILB(1)**2-SSILB(2)**2-SSILB(3)**2) .GT. 1.D-4 ) THEN CALL UTMSG('HASTFR') WRITE(IFCH,*)'***** MASS**2 OF SSILB NONZERO' WRITE(IFCH,*)'MASS**2=',SSILB(4)**2 * -SSILB(1)**2-SSILB(2)**2-SSILB(3)**2 CALL UTMSGF ENDIF DO 14 N=1,4 IF ( ABS(PLAB(N) * -SSILA(N)-SSILB(N)-SSIA(N)-SSIB(N)) .GT. 1.D-4 ) GOTO 15 14 CONTINUE GOTO 16 15 CONTINUE CALL UTMSG('HASTFR') WRITE(IFCH,*)'***** SSILA+SSILB /= SSILA_NEW+SSILB_NEW+SSIA+SSIB' WRITE(IFCH,*)'SSILA_OLD+SSILB_OLD:' WRITE(IFCH,*)PLAB WRITE(IFCH,*)'SSILA_NEW+SSILB_NEW+SSIA+SSIB:' WRITE(IFCH,*)((SSILA(K)+SSILB(K)+SSIA(K)+SSIB(K)),K=1,4) WRITE(IFCH,*)'SSILA_NEW:' WRITE(IFCH,*)(SSILA(N),N=1,4) WRITE(IFCH,*)'SSILB_NEW:' WRITE(IFCH,*)(SSILB(N),N=1,4) WRITE(IFCH,*)'SSIA:' WRITE(IFCH,*)(SSIA(N),N=1,4) WRITE(IFCH,*)'SSIB:' WRITE(IFCH,*)(SSIB(N),N=1,4) CALL UTMSGF 16 CONTINUE 9000 RETURN 9001 IRET=1 IF ( ISH .LT. 90 ) RETURN CALL UTMSG('HASTFR') WRITE(IFCH,*)'STRING SUBTRACTION NOT POSSIBLE' WRITE(IFCH,*)'SNGL(SSILA):' WRITE(IFCH,*)(SNGL(SSILA(N)),N=1,4) WRITE(IFCH,*)'SNGL(SSILB):' WRITE(IFCH,*)(SNGL(SSILB(N)),N=1,4) WRITE(IFCH,*)'SNGL(SSIA):' WRITE(IFCH,*)(SNGL(SSIA(N)),N=1,4) WRITE(IFCH,*)'SNGL(SSIB):' WRITE(IFCH,*)(SNGL(SSIB(N)),N=1,4) WRITE(IFCH,*)'PEP,PEM:',PEP,PEM WRITE(IFCH,*)'POT,PUT:',POT,PUT WRITE(IFCH,*)'A,D:',A,D WRITE(IFCH,*)'A**2-D**2:',A**2-D**2 WRITE(IFCH,*)'PYP,PYM:',PYP,PYM WRITE(IFCH,*)'PIP,PAM:',PIP,PAM WRITE(IFCH,*)'PI3,SILA(3):',PI3,SILA(3) WRITE(IFCH,*)'PA3,SILB(3):',PA3,SILB(3) CALL UTMSGF RETURN END C======================================================================= SUBROUTINE HASTFS(SILA,SIXA,IFLA,XFLA,PTA,PTAH * ,SILB,SIXB,IFLB,XFLB,PTB,PTBH ,STR,IRET ,JORD) C----------------------------------------------------------------------- C FORMS A SHORT (=Q-QBAR) STRING C IRET=0: OK C IRET=1: IN SR HASI: REMNANT CHANGES DIRECTION OR ZERO SI(). C IRET=2: IN SR HASI: JC(,)=10 . C IRET=3: STRING MASS TOO SMALL. NOT 4 , 5 . C IRET=4: STRING MASS TOO SMALL. EQUAL FLAVOUR,ZERO MOMENTUM,XFL='000'. C IRET=5: STRING MASS TOO SMALL. VALENCE QUARKS INVOLVED. C----------------------------------------------------------------------- PARAMETER (NPTQ=129) PARAMETER (NSI=6) PARAMETER (NSIX=40) COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /CPTQ/ QPTH(NPTQ),QPTQ(NPTQ),XPTQ(NPTQ),QPTQMX,QPTHMX COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT REAL PTDIFF(2),SIA(NSI),SIB(NSI),SILA(NSI),SILB(NSI) * ,SIXA(NSI,NSIX),SIXB(NSI,NSIX),STR(NSI,NSIX+1),STS(NSI,2) CHARACTER XFLA*3,XFLB*3 SAVE C----------------------------------------------------------------------- DO 50 N=1,NSI STR(N,1)=0. STR(N,2)=0. STR(N,3)=0. 50 CONTINUE CALL UTKSIX(SIXA,KMAXA) CALL UTKSIX(SIXB,KMAXB) R=RANGEN() IF ( IOPTQ .EQ. 2 ) THEN PT = SQRT( -4.*PTQ**2/PI * LOG(1.-QPTQMX*R) ) ELSEIF ( IOPTQ .EQ. 3 ) THEN PT = PTQ*SQRT( QPTQMX*R/(1.-QPTQMX*R) ) ELSE PT=UTINVT(NPTQ,XPTQ,QPTQ,R*QPTQ(NPTQ)) ENDIF PHI=2.*PI*RANGEN() SIA(1)=PT*COS(PHI) SIB(1)=-SIA(1) SIA(2)=PT*SIN(PHI) SIB(2)=-SIA(2) IXFLAB=0 IF ( XFLA.NE.'---' .AND. XFLB.NE.'---' .AND. * (XFLA .NE. '000' .OR. XFLB .NE. '000') ) IXFLAB=1 CALL HASI('QUARK',SILA,IFLA,XFLA,PTA,PTAH,SIA,IRET,JORD,IXFLAB * ,PTDIFF) IF ( IRET .EQ. 1 ) GOTO 9001 IF ( IRET .EQ. 2 ) GOTO 9002 SILA(1)=SILA(1)-PTDIFF(1) SILA(2)=SILA(2)-PTDIFF(2) SILB(1)=SILB(1)+PTDIFF(1) SILB(2)=SILB(2)+PTDIFF(2) CALL HASI('ANTIQ',SILB,IFLB,XFLB,PTB,PTBH,SIB,IRET,JORD,IXFLAB * ,PTDIFF) IF ( IRET .EQ. 1 ) GOTO 9001 IF ( IRET .EQ. 2 ) GOTO 9002 SILB(1)=SILB(1)-PTDIFF(1) SILB(2)=SILB(2)-PTDIFF(2) SILA(1)=SILA(1)+PTDIFF(1) SILA(2)=SILA(2)+PTDIFF(2) IF ( SILA(5) .EQ. 0. .AND. SILA(6) .EQ. 0. ) THEN SILA(5)=100000. SILA(6)=100000. ENDIF IF ( SILB(5) .EQ. 0. .AND. SILB(6) .EQ. 0. ) THEN SILB(5)=100000. SILB(6)=100000. ENDIF IF ( XFLA .EQ. '000' .AND. XFLB .EQ. '000' ) THEN GOTO 9003 ELSEIF ( XFLA .NE. '---' .AND. XFLB .NE. '---' ) THEN CALL HASTFR(SILA,SILB,SIA,SIB,IRET) IF ( IRET .EQ. 1 ) GOTO 9003 DO 65 N=1,NSI STS(N,1)=SIA(N) STS(N,2)=SIB(N) 65 CONTINUE CALL UTAMST(STS,AM,AMIN,IRET) IF ( IRET .NE. 0 ) GOTO 9003 DO 70 N=1,NSI STR(N,1)=SIA(N) STR(N,2)=SIB(N) 70 CONTINUE ELSEIF ( XFLA .NE. '---' .AND. XFLB .EQ. '---' ) THEN IF ( KMAXB+1 .GT. NSIX ) THEN CALL UTSTOP('HASTFS: NSIX TOO SMALL ') ENDIF DO 60 N=1,NSI SIXB(N,KMAXB+1)=SIA(N) IF ( KMAXB+2 .LE. NSIX ) SIXB(N,KMAXB+2)=0. 60 CONTINUE IF ( IFLA .LT. 0 ) THEN SIXB(5,KMAXB+1)=-SIXB(5,KMAXB+1) SIXB(6,KMAXB+1)=-SIXB(6,KMAXB+1) ENDIF KMAXB=KMAXB+1 ELSEIF ( XFLA .EQ. '---' .AND. XFLB .NE. '---' ) THEN IF ( KMAXA+1 .GT. NSIX ) THEN CALL UTSTOP('HASTFS: NSIX TOO SMALL ') ENDIF DO 80 N=1,NSI SIXA(N,KMAXA+1)=SIB(N) IF ( KMAXA+2 .LE. NSIX ) SIXA(N,KMAXA+2)=0. 80 CONTINUE IF ( IFLB .LT. 0 ) THEN SIXA(5,KMAXA+1)=-SIXA(5,KMAXA+1) SIXA(6,KMAXA+1)=-SIXA(6,KMAXA+1) ENDIF KMAXA=KMAXA+1 ELSEIF ( XFLA .EQ. '---' .AND. XFLB .EQ. '---' ) THEN C NO ACTION ELSE CALL UTSTOP('HASTFS: IF/ELSE ERROR ') ENDIF 9000 IRET=0 IF ( ISH .GE. 91 ) WRITE(IFCH,102)SIA,XFLA,SIB,XFLB 102 FORMAT(' SIA: ',4F13.5,2F8.0,2X,A3 * /' SIB: ',4F13.5,2F8.0,2X,A3) RETURN 9001 IRET=1 IF ( ISH .GE. 91 ) THEN WRITE(IFCH,102)SIA,XFLA,SIB,XFLB WRITE(IFCH,*)'REMNANT CHANGES DIRECTION' WRITE(IFCH,*)' OR ZERO SI(1/2/3)' WRITE(IFCH,*)' ' ENDIF RETURN 9002 IRET=2 C JC(,)=10 IF ( ISH .GE. 91 ) WRITE(IFCH,102)SIA,XFLA,SIB,XFLB RETURN 9003 IRET=3 IF ( XFLA(1:2) .EQ. 'VA' .OR. XFLB(1:2) .EQ. 'VA' ) GOTO 9005 WT=ABS(SIA(1)+SIB(1))+ABS(SIA(2)+SIB(2)) * +ABS(SIA(3)+SIB(3)) IF ( ABS(IFLA).EQ.ABS(IFLB) .AND. WT.LT.1.E-3 * .AND. XFLA.EQ.'000' .AND. XFLB.EQ.'000' ) GOTO 9004 IFLB=SIGN( IABS(IFLA), IFLB) IF ( ISH .GE. 91 ) THEN WRITE(IFCH,102)SIA,XFLA,SIB,XFLB WRITE(IFCH,*)'STRING MASS TOO SMALL (3)' WRITE(IFCH,*)' ' ENDIF XFLA='000' XFLB='000' RETURN 9004 IRET=4 IF ( ISH .GE. 91 ) THEN WRITE(IFCH,102)SIA,XFLA,SIB,XFLB WRITE(IFCH,*)'STRING MASS TOO SMALL (4)' WRITE(IFCH,*)' ' ENDIF RETURN 9005 IRET=5 IF ( ISH .GE. 91 ) THEN WRITE(IFCH,102)SIA,XFLA,SIB,XFLB WRITE(IFCH,*)'STRING MASS TOO SMALL (5)' WRITE(IFCH,*)' ' ENDIF XFLA(1:2)='SE' XFLB(1:2)='SE' RETURN END C======================================================================= SUBROUTINE HASTFW(SIL,SIX) C----------------------------------------------------------------------- PARAMETER (NSI=6) PARAMETER (NSIX=40) COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT REAL SIL(NSI),SIX(NSI,NSIX) SAVE C----------------------------------------------------------------------- CALL UTKSIX(SIX,KMAX) WRITE(IFCH,103)SIL,((SIX(I,J),I=1,NSI),J=1,KMAX) 103 FORMAT(/' SIL: ',4F13.5,2F8.0/,' SIX: ',4F13.5,2F8.0/ *,50(' ',4F13.5,2F8.0/)) RETURN END C======================================================================= SUBROUTINE HASTPR(STRO,ISPLT) C----------------------------------------------------------------------- C PROCESSES A STRING C OUT: ISPLT=0 : PROCESSING OF STRO FINISHED C >0 : HASTPR TO BE REDONE TO PROCESS REDUCED STRING C -1 : ERROR C -3 : HASTPR TO BE REDONE WITH NEW EPART,APART C -4 : HAHA COLLISION TO BE REDONE BEC OF TOO FAST LD PTL C (ONLY FOR ICHOIC=2) C -5 : HASTPR TO BE REDONE BECAUSE OF PRODUCED S=3/2 PARTICLE C----------------------------------------------------------------------- PARAMETER (KOLLMX=2500) PARAMETER (MAMX=56) PARAMETER (MXPTL=70000) PARAMETER (MXSTR=3000) PARAMETER (NDEP=129) PARAMETER (NDET=129) PARAMETER (NFLAV=6) PARAMETER (NSI=6) PARAMETER (NSIX=40) PARAMETER (NHA=NSIX+2) COMMON /ACCUM/ AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT * ,NRPTL,NRSTR,NTEVT COMMON /CEVT/ BIMEVT,COLEVT,EGYEVT,PHIEVT,PMXEVT * ,KOLEVT,NEVT,NPJEVT,NTGEVT COMMON /CJSPLI/ ALEAD,APART,ELEAD,EPART,SGNSIL,JPART,NSCC,NSCCX COMMON /CKOL/ KOL COMMON /CLEAD/ COOAV3,COOAV4,LEAD COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /CNSUC/ NSUC COMMON /COL/ BIMP,BMAX,COORD(4,KOLLMX),DISTCE(KOLLMX) * ,QDEP(NDEP),QDET14(NDET),QDET16(NDET),QDET40(NDET) * ,QDET99(NDET),RMPROJ,RMTARG(4),XDEP(NDEP) * ,XDET14(NDET),XDET16(NDET),XDET40(NDET) * ,XDET99(NDET) * ,KOLL,LTARG,NORD(KOLLMX),NPROJ,NRPROJ(KOLLMX) * ,NRTARG(KOLLMX),NTARG COMMON /CPROJA/ IPROJ,ITARG,KPROJA(NHA,MAMX),KTARGA(NHA,MAMX) COMMON /CPTL/ PPTL(5,MXPTL),TIVPTL(2,MXPTL),XORPTL(4,MXPTL) * ,IBPTL(4,MXPTL),ICLPTL(MXPTL),IDPTL(MXPTL) * ,IFRPTL(2,MXPTL),IORPTL(MXPTL),ISTPTL(MXPTL) * ,JORPTL(MXPTL),NPTL,NQJPTL(MXPTL) COMMON /CPZSTR/ ESTRL,PZSTRL,ISEA,ISTRL COMMON /CSTR/ PSTR(5,MXSTR),ROTSTR(3,MXSTR),XORSTR(4,MXSTR) * ,ICSTR(4,MXSTR),IORSTR(MXSTR),IRLSTR(MXSTR),NSTR COMMON /CSTSH/ NSTSH COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT DOUBLE PRECISION DAUXIL,PPE,PPM,PPP,PPX,PPY,PPZ,PP1(4),PP2(4) REAL P1(4),P2(4),STR(NSI,2),STRO(NSI,NSIX+1) INTEGER IC(2),IC1(2),IC1X(2),IC2(2) * ,JC(NFLAV,2),JC1(NFLAV,2),JC2(NFLAV,2) * ,JC3(NFLAV,2) SAVE C----------------------------------------------------------------------- IF ( ISPLT .EQ. -3 ) THEN JPART=1 ISPLT=0 ELSEIF ( ISPLT .EQ. 0 ) THEN JPART=0 ENDIF ISPLT0=ISPLT CALL UTKSTR(STRO,KMAX) C ZERO STRING C ----------- IF ( KMAX .EQ. 0 ) THEN IF ( ISH .GE. 91 ) THEN WRITE(IFCH,*)'ZERO STRING' WRITE(IFCH,*)' ' ENDIF ISPLT=0 RETURN ENDIF C PRINT C ----- IF ( ISH .GE. 91 ) THEN WRITE(IFCH,105)(STRO(I,1),I=1,4),(NINT(STRO(I,1)),I=5,6) 105 FORMAT(' STR: ',4F13.5,2I8) IF ( KMAX .GT. 1 ) THEN DO 8 K=2,KMAX WRITE(IFCH,104)(STRO(I,K),I=1,4),(NINT(STRO(I,K)),I=5,6) 104 FORMAT(' ',4F13.5,2I8) 8 CONTINUE ENDIF WRITE(IFCH,*)' ' ENDIF C CHECK LEADING OBJECT C -------------------- IC1(1)=NINT(STRO(4+1,1)) IC1(2)=NINT(STRO(4+2,1)) CALL IDCOMP(IC1,IC1X,JC3,1) STRO(4+1,1)=IC1X(1) STRO(4+2,1)=IC1X(2) CALL IDDECO(IC1X,JC1) NPA=0 DO 7 N=1,NFLAV NPA=NPA+JC1(N,1)+JC1(N,2) 7 CONTINUE C SPLIT STRING C ------------ IF ( KMAX .GT. 2 .OR. KMAX.EQ.2 .AND. ISPLT.GT.0 * .OR. KMAX.EQ.2 .AND. NPA.GT.3 * .OR. KMAX.EQ.2 .AND. LEAD.EQ.1 ) THEN IF ( ISPLT .EQ. 0 ) THEN NSUC=0 KMAXOR=KMAX IF ( STRO(3,1) .LT. 0. ) THEN SGNSIL=-1 ELSE SGNSIL=1 ENDIF DO 17 N=1,NFLAV JC2(N,1)=0 JC2(N,2)=0 17 CONTINUE DO 15 K=1,KMAX IC1(1)=NINT(ABS(STRO(4+1,K))) IC1(2)=NINT(ABS(STRO(4+2,K))) CALL IDDECO(IC1,JC1) DO 16 N=1,NFLAV JC2(N,1)=JC2(N,1)+JC1(N,1) JC2(N,2)=JC2(N,2)+JC1(N,2) IF ( N .GT. 4 .AND. (JC2(N,1).NE.0 .OR. * JC2(N,2) .NE. 0) ) THEN CALL UTSTOP('HASTPR: FLAVOUR > 4 ') ENDIF 16 CONTINUE 15 CONTINUE KEU=JC2(1,1)-JC2(1,2) KED=JC2(2,1)-JC2(2,2) KES=JC2(3,1)-JC2(3,2) KEC=JC2(4,1)-JC2(4,2) ALEAD=UTAMNU(KEU,KED,KES,KEC,0) C-C ALEAD=0. ELEAD=STRO(4,1) IF ( JPART .EQ. 0 ) THEN NSCCX=KMAXOR-1 NSTR0=NSTR ELSE NSCCX=MAX(1,NSCC) NSTR=NSTR0 ENDIF APART=ALEAD/NSCCX EPART=ELEAD/NSCCX IF ( ALEAD .GT. ELEAD ) THEN IF ( ISH .GE. 90 ) THEN CALL UTMSG('HASTPR') WRITE(IFCH,*)'***** ALEAD > ELEAD ==> RET CODE = -1' WRITE(IFCH,*)'ALEAD=',ALEAD,' ELEAD=',ELEAD CALL UTMSGF ENDIF ISPLT=-1 RETURN ENDIF ENDIF CALL JSPLIT(STRO,STR,KOLSP,IER,KMAXOR) IF ( IER .EQ. 1 ) THEN ISPLT=-1 RETURN ELSEIF ( IER .EQ. 3 ) THEN ISPLT=-3 RETURN ENDIF ISPLT=ISPLT+1 IF ( IER .EQ. 2 ) THEN IF ( ISH .GE. 91 ) THEN WRITE(IFCH,*)'MULTISTRING: ABSORPTION OF ONE LEG' WRITE(IFCH,*)' ' ENDIF RETURN ENDIF KOLZ=KOLSP IF ( KOLZ .LT. 1 .OR. KOLZ .GT. KOLLMX ) THEN WRITE(IFCH,*)'KOLZ=',KOLZ CALL UTSTOP('HASTPR: KOLZ OUT OF RANGE (1) ') ENDIF KIN=1 ELSE IF ( ISPLT .GT. 0 ) THEN KIN=1 ELSE KIN=0 ENDIF DO 5 N=1,NSI IF ( N .LE. 4 ) THEN STR(N,1)=STRO(N,1) STR(N,2)=STRO(N,2) ELSE STR(N,1)=ABS(STRO(N,1)) STR(N,2)=ABS(STRO(N,2)) ENDIF 5 CONTINUE IF ( ISPLT .GT. 0 ) THEN IF ( SGNSIL .LT. 0. ) THEN KOLZ=KTARGA(2,ITARG) ELSE KOLZ=KPROJA(2,IPROJ) ENDIF ELSEIF ( LEAD .EQ. 1 .AND. KMAX .EQ. 2 ) THEN IF ( STR(3,1) .LT. 0. ) THEN KOLZ=KTARGA(2,ITARG) ELSE KOLZ=KPROJA(2,IPROJ) ENDIF ELSE KOLZ=KOL ENDIF IF ( KOLZ .LT. 1 .OR. KOLZ .GT. KOLLMX ) THEN IF(ISH.GE.90)THEN CALL UTMSG('HASTPR') WRITE(IFCH,*)'***** KOLZ OUT OF RANGE; KOLZ:',KOLZ * ,' SET TO:',KOL WRITE(IFCH,105)(STR(I,1),I=1,4),(NINT(STR(I,1)),I=5,6) WRITE(IFCH,104)(STR(I,2),I=1,4),(NINT(STR(I,2)),I=5,6) CALL UTMSGF ENDIF KOLZ=KOL ENDIF ISPLT=0 ENDIF C ADD TWO JETS C ------------ IC1(1)=NINT(STR(4+1,1)) IC1(2)=NINT(STR(4+2,1)) IC2(1)=NINT(STR(4+1,2)) IC2(2)=NINT(STR(4+2,2)) IA1=IC1(1)+IC1(2) IA2=IC2(1)+IC2(2) IF ( IA1 .EQ. 0 .AND. IA2 .EQ. 0 ) THEN WRITE(IFCH,*)'STRO:' WRITE(IFCH,105)(STRO(I,1),I=1,4),(NINT(STRO(I,1)),I=5,6) IF ( KMAX .GT. 1 ) THEN DO 18 K=2,KMAX WRITE(IFCH,104)(STRO(I,K),I=1,4),(NINT(STRO(I,K)),I=5,6) 18 CONTINUE ENDIF WRITE(IFCH,*)'STR:' WRITE(IFCH,105)(STR(I,1),I=1,4),(NINT(STR(I,1)),I=5,6) WRITE(IFCH,104)(STR(I,2),I=1,4),(NINT(STR(I,2)),I=5,6) CALL UTSTOP('HASTPR: STR=0 ') ENDIF CALL IDDECO(IC1,JC1) CALL IDDECO(IC2,JC2) N1=0 N2=0 DO 9 N=1,NFLAV N1=N1+JC1(N,1)+JC1(N,2) N2=N2+JC2(N,1)+JC2(N,2) JC(N,1)=JC1(N,1)+JC2(N,1) JC(N,2)=JC1(N,2)+JC2(N,2) IF ( N .GT. 4 .AND. (JC(N,1) .NE. 0 .OR. * JC(N,2) .NE. 0) ) THEN CALL UTSTOP ('HASTPR: FLAVOUR > 4 ') ENDIF 9 CONTINUE KEU=JC(1,1)-JC(1,2) KED=JC(2,1)-JC(2,2) KES=JC(3,1)-JC(3,2) KEC=JC(4,1)-JC(4,2) AMSTR=UTAMNU(KEU,KED,KES,KEC,6) CALL IDENCO(JC,IC,IRETEN) IF ( IRETEN .EQ. 1 ) THEN CALL UTSTOP('HASTPR: IDENCO RET CODE = 1 ') ENDIF IDSTR=IDTRA(IC,0,0,3) C DETERMINE ROT C ------------- PP1(1)=STR(1,1) PP1(2)=STR(2,1) PP1(3)=STR(3,1) PP1(4)=STR(4,1) PP2(1)=STR(1,2) PP2(2)=STR(2,2) PP2(3)=STR(3,2) PP2(4)=STR(4,2) PPX=PP1(1)+PP2(1) PPY=PP1(2)+PP2(2) PPZ=PP1(3)+PP2(3) PPP=SQRT(PPX**2+PPY**2+PPZ**2) IF ( IA1 .NE. 0 .AND. IA2 .NE. 0 ) THEN PP1(4)=SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2) PP2(4)=SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2) PPE=PP1(4)+PP2(4) PPM=SQRT((PPE-PPP)*(PPE+PPP)) CALL UTLOB2(1,PPX,PPY,PPZ,PPE,PPM,PP1(1),PP1(2),PP1(3),PP1(4)) CALL UTLOB2(1,PPX,PPY,PPZ,PPE,PPM,PP2(1),PP2(2),PP2(3),PP2(4)) ELSE PPE=PP1(4)+PP2(4) DAUXIL=(PPE-PPP)*(PPE+PPP) IF ( DAUXIL .GT. 0.D0 ) THEN PPM=SQRT(DAUXIL) ELSE PPM=0.D0 PPE=PPP ENDIF PP1(1)=0.D0 PP1(2)=0.D0 PP1(3)=0.D0 PP1(4)=0.D0 PP2(1)=0.D0 PP2(2)=0.D0 PP2(3)=0.D0 PP2(4)=0.D0 ENDIF PX=PPX PY=PPY PZ=PPZ E=PPE AM=PPM P=PPP P1(1)=PP1(1) P1(2)=PP1(2) P1(3)=PP1(3) P1(4)=PP1(4) P2(1)=PP2(1) P2(2)=PP2(2) P2(3)=PP2(3) P2(4)=PP2(4) IF ( ISH .GE. 92 ) THEN WRITE(IFCH,107)(P1(I),I=1,4),IC1 WRITE(IFCH,107)(P2(I),I=1,4),IC2 107 FORMAT(' JET: ',4F13.5,2I8) WRITE(IFCH,*)' ' ENDIF CDH IF ( P1(3) .NE. 0. ) THEN CDH DIRCN=SIGN(1.,P1(3)) CDH ELSE CDH DIRCN=1. CDH ENDIF C MASS ADJUSTMENT C --------------- AM0=AM CALL IDRES(IDSTR,AM,IDSTRR,IADJ) C DIFFRACTIVE PARTICLE: C-C IF ( (IA1.EQ.0.OR.IA2.EQ.0) .AND. ISPLT0.EQ.0 ) THEN C-C IF ( MOD(IDSTRR,10).EQ.0 .AND. RANGEN().LT.0.1 ) THEN C-C AM=0. C-C CALL IDRES(IDSTR,AM,IDSTRR,IADJ) C-C AM=AM+.300 C-C CALL IDRES(IDSTR,AM,IDSTRR,IADJ) C-C ENDIF C-C ENDIF C REMNANT: IF ( (IA1.EQ.0 .OR. IA2.EQ.0) .AND. ISPLT0.GT.0 ) THEN IF ( NSUC .GT. 0 ) THEN AM=0. CALL IDRES(IDSTR,AM,IDSTRR,IADJ) IF ( N1+N2 .EQ. 2 ) THEN IF ( RANGEN() .LT. 0.33 ) AM=AM+0.400 ELSEIF ( MOD(IDSTRR,10) .EQ. 0 ) THEN IF ( RANGEN() .LT. 0.33 ) AM=AM+0.300 ELSE IF ( RANGEN() .GT. 0.33 ) THEN ISPLT=-5 RETURN ENDIF ENDIF CALL IDRES(IDSTR,AM,IDSTRR,IADJ) C ALL LEGS ABSORBED ELSEIF ( NSUC .EQ. 0 ) THEN IF ( ISEA .EQ. 0 ) THEN ISPLT=-4 RETURN ENDIF AM=0. IF ( ISTRL .EQ. 1 ) THEN AM=SQRT(ENGY**2*(1-ABS(PZSTRL)/PNLLX)+.94**2 ) ELSE CALL IDRES(IDSTR,AM,IDSTRR,IADJ) IF ( MOD(IDSTRR,10) .EQ. 0 ) THEN AM=AM+RANGEN() ELSE AM=AM+RANGEN()-0.30 ENDIF C-C IF ( MOD(IDSTRR,10).EQ.0.AND.RANGEN().LT.0.33 ) AM=AM+0.30 ENDIF CALL IDRES(IDSTR,AM,IDSTRR,IADJ) ENDIF ENDIF C LEADING STRING = HADRON: IF ( LEAD.EQ.1 .AND. IA1.NE.0 .AND.IA2.NE.0 * .AND. ISPLT0.EQ.0 .AND. ISPLT.EQ.0 .AND. IDSTRR.NE.0 ) THEN AM=0. CALL IDRES(IDSTR,AM,IDSTRR,IADJ) IF ( MOD(IDSTRR,10).EQ.0 .AND. RANGEN().LT.0.33 ) AM=AM+0.300 CALL IDRES(IDSTR,AM,IDSTRR,IADJ) ENDIF IDSTR=IDSTRR IF ( IDSTR .EQ. 0 .AND. AM .LT. AMSTR ) AM=AMSTR PPM=AM E=SQRT(PPP**2+PPM**2) C WRITE /CSTR/ C ------------ NSTR=NSTR+1 IF ( NSTR .GT. MXSTR ) THEN CALL UTSTOP('HASTPR: NSTR>MXSTR ') ENDIF IF ( LEAD .EQ. 0 ) NSTSH=1 NSUC=NSUC+1 IRLSTR(NSTR)=NSUC IF ( ISPLT0 .EQ. 0 .AND. ISPLT .EQ. 0 ) IRLSTR(NSTR)=0 ICSTR(1,NSTR)=IC1(1) ICSTR(2,NSTR)=IC1(2) ICSTR(3,NSTR)=IC2(1) ICSTR(4,NSTR)=IC2(2) PSTR(1,NSTR)=PX PSTR(2,NSTR)=PY PSTR(3,NSTR)=PZ PSTR(4,NSTR)=E PSTR(5,NSTR)=AM ROTSTR(1,NSTR)=P1(1) ROTSTR(2,NSTR)=P1(2) ROTSTR(3,NSTR)=P1(3) IF ( P1(1) .EQ. 0. .AND. P1(2) .EQ. 0. .AND. P1(3) .EQ. 0. ) * ROTSTR(3,NSTR)=1. XORSTR(1,NSTR)=COORD(1,KOLZ) XORSTR(2,NSTR)=COORD(2,KOLZ) XORSTR(3,NSTR)=COORD(3,KOLZ) XORSTR(4,NSTR)=COORD(4,KOLZ) IORSTR(NSTR)=-KOLZ AMSAC=AMSAC+AM IF ( ISH .GE. 91 ) THEN IF ( ISPLT .GT. 0 ) THEN WRITE(IFCH,*)'SPLIT OFF STRING:' ELSEIF ( ISPLT0 .GT. 0 ) THEN WRITE(IFCH,*)'REMAINDER:' ELSEIF ( LEAD .EQ. 1 ) THEN WRITE(IFCH,*)'ORDINARY BARYONIC STRING:' ELSE WRITE(IFCH,*)'ORDINARY MESONIC STRING:' ENDIF WRITE(IFCH,106)NSTR,(ICSTR(K,NSTR)/100,K=1,4) * ,(PSTR(I,NSTR),I=3,5) 106 FORMAT(/' /CSTR/',I4,3X,4I5,2X,3(E10.3)/) ENDIF RETURN END C======================================================================= SUBROUTINE HDECMP(BAR,SIL,SIX) C----------------------------------------------------------------------- C DECOMPOSES BAR INTO SIL,SIX C----------------------------------------------------------------------- PARAMETER (NSI=6) PARAMETER (NSIX=40) PARAMETER (NHA=NSIX+2) REAL BAR(NSI,NHA),SIL(NSI),SIX(NSI,NSIX) SAVE C----------------------------------------------------------------------- DO 1 N=1,NSI SIL(N)=BAR(N,2) 1 CONTINUE DO 3 M=1,NSIX SIXSQR=0. DO 2 N=1,NSI SIX(N,M)=BAR(N,2+M) SIXSQR=SIXSQR+SIX(N,M)**2 2 CONTINUE IF ( SIXSQR .LE. 1.E-5 ) RETURN 3 CONTINUE RETURN END C======================================================================= SUBROUTINE HRESCL(J1,J2,PSUM,IFAIL) C----------------------------------------------------------------------- C RESCALES STRING MOMENTA OF STRINGS J1-J2 TO HAVE TOTAL MOM PSUM. C----------------------------------------------------------------------- PARAMETER (MXSTR=3000) COMMON /ACCUM/ AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT * ,NRPTL,NRSTR,NTEVT COMMON /CSTR/ PSTR(5,MXSTR),ROTSTR(3,MXSTR),XORSTR(4,MXSTR) * ,ICSTR(4,MXSTR),IORSTR(MXSTR),IRLSTR(MXSTR),NSTR COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT DOUBLE PRECISION PADD(5),PP(5),PPSUM(5) REAL PSUM(5) DATA ERRLIM /.001/ SAVE C----------------------------------------------------------------------- IFAIL=1 PPSUM(1)=PSUM(1) PPSUM(2)=PSUM(2) PPSUM(3)=PSUM(3) PPSUM(4)=PSUM(4) PPSUM(5)=PSUM(5) IF ( J1 .GE. J2 ) THEN CALL UTSTOP('HRESCL: J1 .GE. J2 ') ENDIF PADD(1)=0.D0 PADD(2)=0.D0 PADD(3)=0.D0 PADD(4)=0.D0 PADD(5)=0.D0 DO 110 J=J1,J2 PADD(1)=PADD(1)+PSTR(1,J) PADD(2)=PADD(2)+PSTR(2,J) PADD(3)=PADD(3)+PSTR(3,J) PADD(4)=PADD(4)+PSTR(4,J) PADD(5)=PADD(5)+PSTR(5,J) 110 CONTINUE IF ( PADD(5) .GE. PPSUM(5) ) THEN IF ( ISH .GE. 90 ) THEN CALL UTMSG('HRESCL') WRITE(IFCH,*)'***** SUM OF STR MASSES .GE. PSUM(5)' DO 1 J=J1,J2 WRITE(IFCH,109)J,(ICSTR(K,J)/100,K=1,4) * ,(PSTR(L,J),L=3,5) 109 FORMAT(' /CSTR/',I4,3X,4I5,2X,3(E10.3)) 1 CONTINUE WRITE(IFCH,*)'PPSUM(345):',(SNGL(PPSUM(K)),K=3,5) CALL UTMSGF ENDIF RETURN ENDIF PADD(5)=PADD(4)**2-PADD(1)**2-PADD(2)**2-PADD(3)**2 IF ( PADD(5) .LE. 0.D0 ) THEN DO 2 J=J1,J2 WRITE(IFCH,108)J,(PSTR(L,J),L=1,5) 108 FORMAT(' /CSTR/',I4,2X,5(E10.3)) 2 CONTINUE CALL UTSTOP('HRESCL: MASS**2 OF STRING-SUM NEGATIVE ') ENDIF PADD(5)=SQRT(PADD(5)) C BOOST STRINGS TO REST C --------------------- DO 115 J=J1,J2 PP(1)=PSTR(1,J) PP(2)=PSTR(2,J) PP(3)=PSTR(3,J) PP(4)=PSTR(4,J) CALL UTLOB2(1,PADD(1),PADD(2),PADD(3),PADD(4),PADD(5) * ,PP(1),PP(2),PP(3),PP(4)) PSTR(1,J)=PP(1) PSTR(2,J)=PP(2) PSTR(3,J)=PP(3) PSTR(4,J)=PP(4) 115 CONTINUE C RESCALE MOMENTA IN REST FRAME C ----------------------------- SCAL=1. DO 301 IPASS=1,200 SUM=0. DO 310 J=J1,J2 PSTR(1,J)=SCAL*PSTR(1,J) PSTR(2,J)=SCAL*PSTR(2,J) PSTR(3,J)=SCAL*PSTR(3,J) PSTR(4,J)=SQRT(PSTR(1,J)**2+PSTR(2,J)**2+PSTR(3,J)**2 * +PSTR(5,J)**2) SUM=SUM+PSTR(4,J) 310 CONTINUE SCAL=PSUM(5)/SUM IF ( ABS(SCAL-1.) .LE. ERRLIM ) GOTO 300 301 CONTINUE IF ( ISH .GE. 90 ) THEN CALL UTMSG('HRESCL') WRITE(IFCH,*)'***** SCAL=',SCAL CALL UTMSGF ENDIF 300 CONTINUE C BOOST BACK WITH PPSUM C --------------------- DO 315 J=J1,J2 PP(1)=PSTR(1,J) PP(2)=PSTR(2,J) PP(3)=PSTR(3,J) PP(4)=PSTR(4,J) CALL UTLOB2(-1,PPSUM(1),PPSUM(2),PPSUM(3),PPSUM(4),PPSUM(5) * ,PP(1),PP(2),PP(3),PP(4)) PSTR(1,J)=PP(1) PSTR(2,J)=PP(2) PSTR(3,J)=PP(3) PSTR(4,J)=PP(4) 315 CONTINUE IFAIL=0 RETURN END C======================================================================= SUBROUTINE IDCOMJ(JC) C----------------------------------------------------------------------- C COMPACTIFIES JC C----------------------------------------------------------------------- PARAMETER (NFLAV=6) INTEGER IC(2),ICX(2),JC(NFLAV,2) SAVE C----------------------------------------------------------------------- CALL IDCOMP(IC,ICX,JC,2) RETURN END C======================================================================= SUBROUTINE IDCOMK(IC) C----------------------------------------------------------------------- C COMPACTIFIES IC C----------------------------------------------------------------------- PARAMETER (NFLAV=6) INTEGER IC(2),ICX(2),JC(NFLAV,2) SAVE C----------------------------------------------------------------------- CALL IDCOMP(IC,ICX,JC,1) IC(1)=ICX(1) IC(2)=ICX(2) RETURN END C======================================================================= SUBROUTINE IDCOMP(IC,ICX,JC,IM) C----------------------------------------------------------------------- C COMPACTIFIES IC,JC C INPUT: IM (1 OR 2) C IC (IF IM=1) C JC (IF IM=2) C OUTPUT: ICX (IF IM=1) C JC C----------------------------------------------------------------------- PARAMETER (NFLAV=6) INTEGER IC(2),ICX(2),JC(NFLAV,2) SAVE C----------------------------------------------------------------------- IF ( IM .EQ. 1 ) CALL IDDECO(IC,JC) ICX(1)=0 ICX(2)=0 DO 2 N=1,NFLAV IF ( JC(N,1) .NE. 0 .OR. JC(N,2) .NE. 0 ) GOTO 1 2 CONTINUE RETURN 1 L=0 DO 3 N=1,NFLAV K=MIN(JC(N,1),JC(N,2)) JC(N,1)=JC(N,1)-K JC(N,2)=JC(N,2)-K IF ( JC(N,1) .LT. 0 .OR. JC(N,2) .LT. 0 ) THEN CALL UTSTOP('IDCOMP: JC NEGATIVE ') ENDIF L=L+JC(N,1)+JC(N,2) 3 CONTINUE IF ( L .EQ. 0 ) THEN JC(1,1)=1 JC(1,2)=1 ENDIF IF ( IM .EQ. 1 ) THEN CALL IDENCO(JC,ICX,IRETEN) IF ( IRETEN .EQ. 1 ) THEN CALL UTSTOP('IDCOMP: IDENCO RET CODE = 1 ') ENDIF ENDIF RETURN END C======================================================================= SUBROUTINE IDDECO(IC,JC) C----------------------------------------------------------------------- C DECODE PARTICLE ID C----------------------------------------------------------------------- PARAMETER (NFLAV=6) INTEGER IC(2),JC(NFLAV,2) SAVE C----------------------------------------------------------------------- ICI=IC(1) JC(6,1)=MOD(ICI,10) JC(5,1)=MOD(ICI/10,10) JC(4,1)=MOD(ICI/100,10) JC(3,1)=MOD(ICI/1000,10) JC(2,1)=MOD(ICI/10000,10) JC(1,1)=MOD(ICI/100000,10) ICI=IC(2) JC(6,2)=MOD(ICI,10) JC(5,2)=MOD(ICI/10,10) JC(4,2)=MOD(ICI/100,10) JC(3,2)=MOD(ICI/1000,10) JC(2,2)=MOD(ICI/10000,10) JC(1,2)=MOD(ICI/100000,10) RETURN END C======================================================================= SUBROUTINE IDENCO(JC,IC,IRETEN) C----------------------------------------------------------------------- C ENCODE PARTICLE ID C----------------------------------------------------------------------- PARAMETER (NFLAV=6) INTEGER IC(2),JC(NFLAV,2) SAVE C----------------------------------------------------------------------- IRETEN=0 IC(1)=0 DO 20 I=1,NFLAV IF ( JC(I,1) .GE. 10 ) GOTO 22 IC(1)=IC(1)+JC(I,1)*10**(NFLAV-I) 20 CONTINUE IC(2)=0 DO 21 I=1,NFLAV IF ( JC(I,2) .GE. 10 ) GOTO 22 IC(2)=IC(2)+JC(I,2)*10**(NFLAV-I) 21 CONTINUE RETURN 22 IRETEN=1 IC(1)=0 IC(2)=0 RETURN END C======================================================================= SUBROUTINE IDFLAV(ID,IFL1,IFL2,IFL3,JSPIN,INDEX) C----------------------------------------------------------------------- C UNPACKS THE IDENT CODE ID=+/-IJKL C C MESONS-- C I=0, J<=K, +/- IS SIGN FOR J C ID=110 FOR PI0, ID=220 FOR ETA, ETC. C C BARYONS-- C I<=J<=K IN GENERAL C J 9 ') ENDIF IDR=ID/10*10+SIGN(J-1,ID) GOTO 2 ENDIF 1 CONTINUE GOTO 9999 2 CONTINUE DO 4 K=1,MXMX IF ( IX .EQ. IDMX(1,K) ) THEN IF ( J .LT. 1 .OR. J .GT. MXMA-1 ) THEN CALL UTSTOP('IDRES: INDEX J OUT OF RANGE ') ENDIF IF ( IDMX(J+1,K) .NE. 0 ) IDR = SIGN(IDMX(J+1,K),ID) ENDIF 4 CONTINUE IY=MOD(IABS(IDR),10) IF ( IY .GT. MAXRES ) THEN IADJ=0 IDR=0 GOTO 9999 ENDIF IF ( IY .NE. 0 .AND. IY .NE. 1 ) GOTO 9999 CALL IDMASS(IDR,AM) IF ( AM .LT. 0. ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,*)'***** ERROR IN IDRES: ' * ,'NEG MASS RETURNED FROM IDMASS' WRITE(IFCH,*)'ID,AM(INPUT):',IDI,AMI WRITE(IFCH,*)'IDR,AM:',IDR,AM CALL UTSTOP('IDRES: NEG MASS RETURNED FROM IDMASS ') ENDIF IADJ=1 9999 ID=IDI IF ( ISH .LT. 93 ) RETURN WRITE(IFCH,*)' ' WRITE(IFCH,*)'RETURN FROM IDRES. ID,AMI,AM,IDR,IADJ:' WRITE(IFCH,*)ID,AMI,AM,IDR,IADJ WRITE(IFCH,*)' ' RETURN END C======================================================================= SUBROUTINE IDRESI C----------------------------------------------------------------------- C INITIALIZES /CREMA/ C----------------------------------------------------------------------- PARAMETER (MXINDX=1000) PARAMETER (MXMA=11) PARAMETER (MXMX=6) PARAMETER (MXRE=100) PARAMETER (N=29) COMMON /CREMA/ REMA(MXRE,MXMA),REWI(MXRE,MXMA) * ,ICRE1(MXRE,MXMA),ICRE2(MXRE,MXMA) * ,IDMX(MXMA,MXMX),INDX(MXINDX) REAL REMAI(N,MXMA),REWII(N,MXMA) INTEGER ICREI(N,2*MXMA),IDMXI(MXMA,MXMX) DATA (IDMXI(J,1),J=1,MXMA)/ 11, 110, 111, 0, 0, 0, 0, 4*0/ DATA (IDMXI(J,2),J=1,MXMA)/ 22, 220, 330, 331, 0, 0, 0, 4*0/ DATA (IDMXI(J,3),J=1,MXMA)/123,2130,1230,1231, 0, 0, 0, 4*0/ DATA (IDMXI(J,4),J=1,MXMA)/124,2140,1240,1241, 0, 0, 0, 4*0/ DATA (IDMXI(J,5),J=1,MXMA)/134,3140,1340,1341, 0, 0, 0, 4*0/ DATA (IDMXI(J,6),J=1,MXMA)/234,3240,2340,2341, 0, 0, 0, 4*0/ DATA ((ICREI(K,M),M=1,2*MXMA),K=1,10)/ * 111,000000, 9*300000, 11*0, * 222,000000, 9*030000, 11*0, * 112, 10*210000, 11*0, * 122, 10*120000, 11*0, * 113, 10*201000, 11*0, * 223, 10*021000, 11*0, * 123, 10*111000, 11*0, * 133, 10*102000, 11*0, * 233, 10*012000, 11*0, * 333,000000, 9*003000, 11*0/ DATA ((ICREI(K,M),M=1,2*MXMA),K=11,20)/ * 114, 10*200100, 11*0, * 124, 10*110100, 11*0, * 224, 10*020100, 11*0, * 134, 10*101100, 11*0, * 234, 10*011100, 11*0, * 334, 10*002100, 11*0, * 144, 10*100200, 11*0, * 244, 10*010200, 11*0, * 344, 10*001200, 11*0, * 444,000000, 9*000300, 11*0/ DATA ((ICREI(K,M),M=1,2*MXMA),K=21,29)/ * 11, 10*100000, 0, 10*100000, * 22, 10*001000, 0, 10*001000, * 12, 10*100000, 0, 10*010000, * 13, 10*100000, 0, 10*001000, * 23, 10*010000, 0, 10*001000, * 14, 10*100000, 0, 10*000100, * 24, 10*010000, 0, 10*000100, * 34, 10*001000, 0, 10*000100, * 44, 10*000100, 0, 10*000100/ DATA ((REMAI(K,M),M=1,MXMA),K=1,10)/ *111.,0.000,1.425,1.660,1.825,2.000,0.000,0.000,0.000,0.000,0.000, *222.,0.000,1.425,1.660,1.825,2.000,0.000,0.000,0.000,0.000,0.000, *112.,1.080,1.315,1.485,1.575,1.645,1.685,1.705,1.825,2.000,0.000, *122.,1.080,1.315,1.485,1.575,1.645,1.685,1.705,1.825,2.000,0.000, *113.,1.300,1.500,1.700,1.850,2.000,0.000,0.000,0.000,0.000,0.000, *223.,1.300,1.500,1.700,1.850,2.000,0.000,0.000,0.000,0.000,0.000, *123.,1.117,1.300,1.395,1.465,1.540,1.655,1.710,1.800,1.885,2.000, *133.,1.423,2.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000, *233.,1.428,2.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000, *333.,0.000,2.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000/ DATA ((REMAI(K,M),M=1,MXMA),K=11,20)/ *114.,2.530,2.730,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000, *124.,2.345,2.530,2.730,0.000,0.000,0.000,0.000,0.000,0.000,0.000, *224.,2.530,2.730,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000, *134.,2.450,2.600,2.800,0.000,0.000,0.000,0.000,0.000,0.000,0.000, *234.,2.450,2.600,2.800,0.000,0.000,0.000,0.000,0.000,0.000,0.000, *334.,2.700,2.900,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000, *144.,3.650,3.850,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000, *244.,3.650,3.850,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000, *344.,3.800,4.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000, *444.,0.000,5.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000/ DATA ((REMAI(K,M),M=1,MXMA),K=21,29)/ * 11.,0.450,0.950,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000, * 22.,0.750,0.965,1.080,0.000,0.000,0.000,0.000,0.000,0.000,0.000, * 12.,0.450,0.950,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000, * 13.,0.700,1.050,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000, * 23.,0.700,1.050,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000, * 14.,1.935,2.077,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000, * 24.,1.938,2.079,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000, * 34.,2.085,2.195,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000, * 44.,3.037,3.158,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000/ DATA ((REWII(K,M),M=1,MXMA),K=1,5)/ *111.,0.000E+00,0.115E+00,0.140E+00,0.250E+00,0.250E+00, * 0.000E+00,0.000E+00,0.000E+00,0.000E+00,0.000E+00, *222.,0.000E+00,0.115E+00,0.140E+00,0.250E+00,0.250E+00, * 0.000E+00,0.000E+00,0.000E+00,0.000E+00,0.000E+00, *112.,0.000E+00,0.115E+00,0.200E+00,0.140E+00,0.140E+00, * 0.145E+00,0.250E+00,0.140E+00,0.250E+00,0.000E+00, *122.,0.000E+00,0.115E+00,0.200E+00,0.140E+00,0.140E+00, * 0.145E+00,0.250E+00,0.140E+00,0.250E+00,0.000E+00, *113.,0.824E-14,0.036E+00,0.080E+00,0.100E+00,0.170E+00, * 0.000E+00,0.000E+00,0.000E+00,0.000E+00,0.000E+00/ DATA ((REWII(K,M),M=1,MXMA),K=6,10)/ *223.,0.445E-14,0.039E+00,0.080E+00,0.100E+00,0.170E+00, * 0.000E+00,0.000E+00,0.000E+00,0.000E+00,0.000E+00, *123.,0.250E-14,0.890E-05,0.036E+00,0.040E+00,0.016E+00, * 0.090E+00,0.080E+00,0.100E+00,0.145E+00,0.170E+00, *133.,0.227E-14,0.009E+00,0.000E+00,0.000E+00,0.000E+00, * 0.000E+00,0.000E+00,0.000E+00,0.000E+00,0.000E+00, *233.,0.400E-14,0.010E+00,0.000E+00,0.000E+00,0.000E+00, * 0.000E+00,0.000E+00,0.000E+00,0.000E+00,0.000E+00, *333.,0.000E+00,0.800E-14,0.000E+00,0.000E+00,0.000E+00, * 0.000E+00,0.000E+00,0.000E+00,0.000E+00,0.000E+00/ DATA ((REWII(K,M),M=1,MXMA),K=11,15)/ *114.,0.400E-11,0.010E+00,0.000E+00,0.000E+00,0.000E+00, * 0.000E+00,0.000E+00,0.000E+00,0.000E+00,0.000E+00, *124.,0.400E-11,0.400E-11,0.010E+00,0.000E+00,0.000E+00, * 0.000E+00,0.000E+00,0.000E+00,0.000E+00,0.000E+00, *224.,0.400E-11,0.010E+00,0.010E+00,0.000E+00,0.000E+00, * 0.000E+00,0.000E+00,0.000E+00,0.000E+00,0.000E+00, *134.,0.150E-11,0.400E-11,0.010E+00,0.000E+00,0.000E+00, * 0.000E+00,0.000E+00,0.000E+00,0.000E+00,0.000E+00, *234.,0.150E-11,0.400E-11,0.010E+00,0.000E+00,0.000E+00, * 0.000E+00,0.000E+00,0.000E+00,0.000E+00,0.000E+00/ DATA ((REWII(K,M),M=1,MXMA),K=16,20)/ *334.,0.400E-11,0.010E+00,0.010E+00,0.000E+00,0.000E+00, * 0.000E+00,0.000E+00,0.000E+00,0.000E+00,0.000E+00, *144.,0.400E-11,0.010E+00,0.010E+00,0.000E+00,0.000E+00, * 0.000E+00,0.000E+00,0.000E+00,0.000E+00,0.000E+00, *244.,0.400E-11,0.010E+00,0.010E+00,0.000E+00,0.000E+00, * 0.000E+00,0.000E+00,0.000E+00,0.000E+00,0.000E+00, *344.,0.400E-11,0.010E+00,0.010E+00,0.000E+00,0.000E+00, * 0.000E+00,0.000E+00,0.000E+00,0.000E+00,0.000E+00, *444.,0.400E-11,0.010E+00,0.010E+00,0.000E+00,0.000E+00, * 0.000E+00,0.000E+00,0.000E+00,0.000E+00,0.000E+00/ DATA ((REWII(K,M),M=1,MXMA),K=21,25)/ * 11.,0.757E-08,0.153E+00,0.057E+00,0.000E+00,0.000E+00, * 0.000E+00,0.000E+00,0.000E+00,0.000E+00,0.000E+00, * 22.,0.105E-05,0.210E-03,0.034E+00,0.004E+00,0.000E+00, * 0.000E+00,0.000E+00,0.000E+00,0.000E+00,0.000E+00, * 12.,0.000E+00,0.153E+00,0.057E+00,0.000E+00,0.000E+00, * 0.000E+00,0.000E+00,0.000E+00,0.000E+00,0.000E+00, * 13.,0.000E+00,0.051E+00,0.000E+00,0.000E+00,0.000E+00, * 0.000E+00,0.000E+00,0.000E+00,0.000E+00,0.000E+00, * 23.,0.197E-02,0.051E+00,0.000E+00,0.000E+00,0.000E+00, * 0.000E+00,0.000E+00,0.000E+00,0.000E+00,0.000E+00/ DATA ((REWII(K,M),M=1,MXMA),K=26,29)/ * 14.,0.154E-11,0.002E+00,0.000E+00,0.000E+00,0.000E+00, * 0.000E+00,0.000E+00,0.000E+00,0.000E+00,0.000E+00, * 24.,0.615E-12,0.002E+00,0.000E+00,0.000E+00,0.000E+00, * 0.000E+00,0.000E+00,0.000E+00,0.000E+00,0.000E+00, * 34.,0.150E-11,0.020E+00,0.000E+00,0.000E+00,0.000E+00, * 0.000E+00,0.000E+00,0.000E+00,0.000E+00,0.000E+00, * 44.,0.010E+00,0.068E-03,0.000E+00,0.000E+00,0.000E+00, * 0.000E+00,0.000E+00,0.000E+00,0.000E+00,0.000E+00/ SAVE C----------------------------------------------------------------------- NN=N DO 3 I=1,MXINDX INDX(I)=0 3 CONTINUE DO 44 M=1,MXMA DO 4 K=1,MXRE REMA(K,M)=0. 4 CONTINUE 44 CONTINUE DO 22 I=1,MXMX DO 2 J=1,MXMA IDMX(J,I)=IDMXI(J,I) 2 CONTINUE 22 CONTINUE IF ( NN .GT. MXRE ) THEN CALL UTSTOP('IDRESI: DIMENSION MXRE TOO SMALL ') ENDIF DO 1 K=1,N IX=NINT(REMAI(K,1)) IX2=NINT(REWII(K,1)) IX3=ICREI(K,1) IF ( IX .NE. IX2 ) THEN CALL UTSTOP('IDRESI: IX /= IX2 ') ENDIF IF ( IX .NE. IX3 ) THEN CALL UTSTOP('IDRESI: IX /= IX3 ') ENDIF IF ( IX .LT. 1 .OR. IX .GT. MXINDX ) THEN CALL UTSTOP('IDRESI: IX OUT OF RANGE. ') ENDIF INDX(IX)=K REMA(K,1)=0. REWI(K,1)=0. ICRE1(K,1)=0 ICRE2(K,1)=0 DO 5 M=2,MXMA REMA(K,M)=REMAI(K,M) REWI(K,M)=REWII(K,M) ICRE1(K,M)=ICREI(K,M) ICRE2(K,M)=ICREI(K,MXMA+M) 5 CONTINUE 1 CONTINUE INDX(33) =INDX(22) INDX(213)=INDX(123) INDX(214)=INDX(124) INDX(314)=INDX(134) INDX(324)=INDX(234) RETURN END C======================================================================= SUBROUTINE IDSPIN(II,IC,ID,JSPIN) C----------------------------------------------------------------------- C DETERMINES PARTICLE SPIN C----------------------------------------------------------------------- PARAMETER (NFLAV=6) COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU REAL PSPIN1(8) INTEGER IC(2),JC(NFLAV,2) SAVE C----------------------------------------------------------------------- PSPIN1(1)=PSPINL PSPIN1(2)=PSPINL PSPIN1(3)=PSPINL PSPIN1(4)=PSPINH PSPIN1(5)=PSPINH PSPIN1(6)=PSPINH PSPIN1(7)=PSPINH PSPIN1(8)=PSPINH CALL IDDECO(IC,JC) IHIGH=0 IF ( II .EQ. 1 ) THEN DO 4 I=1,NFLAV IF ( JC(I,1) .NE. 0 ) IHIGH=I IF ( JC(I,2) .NE. 0 ) IHIGH=I 4 CONTINUE ELSE CALL IDFLAV(ID,I1,I2,I3,IDU1,IDU2) DO 5 I=1,NFLAV IF ( I.EQ.ABS(I1) .OR. I .EQ. ABS(I2) * .OR. I .EQ. ABS(I3) ) IHIGH=I 5 CONTINUE ENDIF JSPIN=INT(RANGEN()+PSPIN1(IHIGH)) RETURN END C======================================================================= SUBROUTINE IDTAU(ID,P4,P5,TAUGM) C----------------------------------------------------------------------- C RETURNS LIFETIME*GAMMA FOR ID WITH ENERGY P4, MASS P5 C----------------------------------------------------------------------- PARAMETER (MXINDX=1000) PARAMETER (MXMA=11) PARAMETER (MXMX=6) PARAMETER (MXRE=100) COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /CREMA/ REMA(MXRE,MXMA),REWI(MXRE,MXMA) * ,ICRE1(MXRE,MXMA),ICRE2(MXRE,MXMA) * ,IDMX(MXMA,MXMX),INDX(MXINDX) COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU SAVE C----------------------------------------------------------------------- IDABS = ABS(ID) IF ( IDABS .LT. 100 .AND. ID .NE. 20 ) THEN WI=0. ELSEIF ( ID .EQ. 20 ) THEN WI=.197/2.675E13 ELSEIF ( IDABS .LT. 100000000 ) THEN IX=IDABS/10 IF ( IX .LT. 1 .OR. IX .GT. MXINDX ) THEN CALL UTSTOP('IDTAU: IX OUT OF RANGE. ') ENDIF II=INDX(IX) JJ=MOD(IDABS,10)+2 DO 75 IMX=1,MXMX DO 76 IMA=2,MXMA IF ( IDABS .EQ. IDMX(IMA,IMX) ) JJ=IMA 76 CONTINUE 75 CONTINUE IF ( II.LT.1 .OR. II.GT.MXRE .OR. JJ.LT.1 .OR. JJ.GT.MXMA ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,*)'ID,II,JJ:',ID,' ',II,JJ CALL UTSTOP('IDTAU: II OR JJ OUT OF RANGE ') ENDIF WI=REWI(II,JJ) ELSE TAUZ=TAUNLL C-C TAUZ=MIN( 9./P5**2, TAUZ ) C-C TAUZ=MAX( .2, TAUZ ) WI=.197/TAUZ ENDIF IF ( WI .EQ. 0. ) THEN TAU=AINFIN TAUGM=AINFIN RETURN ELSE TAU=.197/WI IF ( TAU .GE. AINFIN ) THEN TAUGM = AINFIN RETURN ENDIF ENDIF IF ( P5 .EQ. 0. ) THEN GM=AINFIN TAUGM=AINFIN ELSE GM=P4/P5 IF ( GM .GE. AINFIN ) THEN TAUGM = AINFIN RETURN ELSE TAUGM=TAU*GM ENDIF ENDIF RETURN END C======================================================================= INTEGER FUNCTION IDTRA(IC,IER,IRES,IMIX) C----------------------------------------------------------------------- C TRANFORMS FROM WERNER-ID TO PAIGE-ID C----------------------------------------------------------------------- PARAMETER (NIDT=44) COMMON /ACCUM/ AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT * ,NRPTL,NRSTR,NTEVT COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU INTEGER IC(2),ICM(2),IDT(3,NIDT) DATA IDT/ * 100000,000000, 1 ,010000,000000, 2 ,001000,000000, 3 *,000100,000000, 4 *,200000,000000,1100 ,110000,000000,1200 ,020000,000000,2200 *,101000,000000,1300 ,011000,000000,2300 ,002000,000000,3300 *,100100,000000,1400 ,010100,000000,2400 ,001100,000000,3400 *,000200,000000,4400 *,100000,100000, 110 ,100000,010000, 120 ,010000,010000, 220 *,100000,001000, 130 ,010000,001000, 230 ,001000,001000, 330 *,100000,000100, 140 ,010000,000100, 240 ,001000,000100, 340 *,000100,000100, 440 *,300000,000000,1111 ,210000,000000,1120 ,120000,000000,1220 *,030000,000000,2221 ,201000,000000,1130 ,111000,000000,1230 *,021000,000000,2230 ,102000,000000,1330 ,012000,000000,2330 *,003000,000000,3331 ,200100,000000,1140 ,110100,000000,1240 *,020100,000000,2240 ,101100,000000,1340 ,011100,000000,2340 *,002100,000000,3340 ,100200,000000,1440 ,010200,000000,2440 *,001200,000000,3440 ,000300,000000,4441/ SAVE C----------------------------------------------------------------------- IF ( IC(1) .EQ. 0 .AND. IC(2) .EQ. 0 ) THEN IDTRA=0 RETURN ENDIF DO 1 I=1,NIDT IF ( IC(1).EQ.IDT(1,I) .AND. IC(2).EQ.IDT(2,I) ) THEN IDTRA=IDT(3,I) GOTO 2 ENDIF IF ( IC(2).EQ.IDT(1,I) .AND. IC(1).EQ.IDT(2,I) ) THEN IDTRA=-IDT(3,I) GOTO 2 ENDIF 1 CONTINUE IDTRA=0 2 CONTINUE IF ( IDTRA .NE. 0 ) THEN ISI=SIGN(1,IDTRA) JSPIN=0 IF ( MOD(IDTRA,10).EQ.0 .AND. IRES.EQ.1 ) * CALL IDSPIN(1,IC,IDU,JSPIN) ELSE ISI=1 JSPIN=0 ENDIF IF ( IMIX .EQ. 3 ) THEN IF ( IDTRA .EQ. 220 ) THEN IDTRA=110 ELSEIF ( IDTRA .EQ. 330 ) THEN IDTRA=220 ENDIF ELSEIF ( IMIX .EQ. 2 ) THEN IF ( IDTRA .EQ. 220 ) THEN IDTRA=110 ELSEIF ( IDTRA .EQ. 330 ) THEN IDTRA=110 ENDIF ELSEIF ( IMIX .EQ. 1 ) THEN CALL IDMIX(IC,JSPIN,ICM,IDTRAM) IF ( IDTRAM .NE. 0 ) IDTRA=IDTRAM IF ( JSPIN .EQ. 0 ) THEN IF ( RANGEN() .LT. PISPN ) THEN IF ( ABS(IDTRA). EQ. 1230 ) THEN IDTRA=ISI*2130 ELSEIF ( ABS(IDTRA) .EQ. 1240 ) THEN IDTRA=ISI*2140 ELSEIF ( ABS(IDTRA) .EQ. 1340 ) THEN IDTRA=ISI*3140 ELSEIF ( ABS(IDTRA) .EQ. 2340 ) THEN IDTRA=ISI*3240 ENDIF ENDIF ENDIF ENDIF IF ( IDTRA .NE. 0 ) IDTRA=IDTRA+JSPIN*ISI IF ( IDTRA .NE. 0 ) RETURN IF ( IER .NE. 1 ) RETURN JERR=JERR+1 WRITE(IFCH,*)' ' WRITE(IFCH,*)'***** ERROR IN IDTRA: UNKNOWN CODE' WRITE(IFCH,*)'IC = ',IC WRITE(IFCH,*)' ' RETURN END C======================================================================= INTEGER FUNCTION IDTRAI(NUM,ID,IER) C----------------------------------------------------------------------- PARAMETER (NIDT=44) COMMON /ACCUM/ AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT * ,NRPTL,NRSTR,NTEVT COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP INTEGER IDT(3,NIDT) DATA IDT/ * 100000,000000, 1 ,010000,000000, 2 ,001000,000000, 3 *,000100,000000, 4 *,200000,000000,1100 ,110000,000000,1200 ,020000,000000,2200 *,101000,000000,1300 ,011000,000000,2300 ,002000,000000,3300 *,100100,000000,1400 ,010100,000000,2400 ,001100,000000,3400 *,000200,000000,4400 *,100000,100000, 110 ,100000,010000, 120 ,010000,010000, 220 *,100000,001000, 130 ,010000,001000, 230 ,001000,001000, 330 *,100000,000100, 140 ,010000,000100, 240 ,001000,000100, 340 *,000100,000100, 440 *,300000,000000,1111 ,210000,000000,1120 ,120000,000000,1220 *,030000,000000,2221 ,201000,000000,1130 ,111000,000000,1230 *,021000,000000,2230 ,102000,000000,1330 ,012000,000000,2330 *,003000,000000,3331 ,200100,000000,1140 ,110100,000000,1240 *,020100,000000,2240 ,101100,000000,1340 ,011100,000000,2340 *,002100,000000,3340 ,100200,000000,1440 ,010200,000000,2440 *,001200,000000,3440 ,000300,000000,4441/ SAVE C----------------------------------------------------------------------- IDABS = ABS(ID) DO 1 I=1,NIDT IF ( IDABS .EQ. IDT(3,I) ) THEN IF ( ID .LT. 0 ) THEN IDTRAI=IDT(3-NUM,I) ELSE IDTRAI=IDT(NUM,I) ENDIF RETURN ENDIF 1 CONTINUE IDTRAI=0 IF ( IER .NE. 1 ) RETURN JERR=JERR+1 WRITE(IFCH,*)' ' WRITE(IFCH,*)'***** ERROR IN IDTRAI: UNKNOWN CODE' WRITE(IFCH,*)'ID = ',ID WRITE(IFCH,*)' ' RETURN END C======================================================================= SUBROUTINE IDTRB(IB1,IB2,IB3,IB4,JC) C----------------------------------------------------------------------- C ID TRANSFORMATION IB -> JC C----------------------------------------------------------------------- PARAMETER (NFLAV=6) COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP INTEGER JC(NFLAV,2) SAVE C----------------------------------------------------------------------- JC(1,1)=IB1/10000 JC(2,1)=IB2/10000 JC(3,1)=IB3/10000 JC(4,1)=IB4/10000 JC(5,1)=0 JC(6,1)=0 JC(1,2)=MOD(IB1,10000) JC(2,2)=MOD(IB2,10000) JC(3,2)=MOD(IB3,10000) JC(4,2)=MOD(IB4,10000) JC(5,2)=0 JC(6,2)=0 RETURN END C======================================================================= SUBROUTINE IDTRBI(JC,IB1,IB2,IB3,IB4) C----------------------------------------------------------------------- PARAMETER (NFLAV=6) COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP INTEGER JC(NFLAV,2) SAVE C----------------------------------------------------------------------- IB1=JC(1,1)*10000+JC(1,2) IB2=JC(2,1)*10000+JC(2,2) IB3=JC(3,1)*10000+JC(3,2) IB4=JC(4,1)*10000+JC(4,2) IB5=JC(5,1)*10000+JC(5,2) IB6=JC(6,1)*10000+JC(6,2) IF ( IB5 .NE. 0 .OR. IB6 .NE. 0 ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,*)'***** ERROR IN IDTRBI: BOTTOM OR TOP QUARKS' WRITE(IFCH,*)'JC:' WRITE(IFCH,*)JC CALL UTSTOP('IDTRBI: BOTTOM OR TOP QUARKS ') ENDIF RETURN END C======================================================================= SUBROUTINE IDTR4(ID,IC) C----------------------------------------------------------------------- C TRANSFORMS GENERALIZED PAIGE_ID -> WERNER_ID (FOR < 4 FLV) C----------------------------------------------------------------------- PARAMETER (MXINDX=1000) PARAMETER (MXMA=11) PARAMETER (MXMX=6) PARAMETER (MXRE=100) COMMON /CREMA/ REMA(MXRE,MXMA),REWI(MXRE,MXMA) * ,ICRE1(MXRE,MXMA),ICRE2(MXRE,MXMA) * ,IDMX(MXMA,MXMX),INDX(MXINDX) COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP INTEGER IC(2) SAVE C----------------------------------------------------------------------- IDABS = ABS(ID) IF ( IDABS .LT. 100000000 ) THEN IX=IDABS/10 IF ( IX .LT. 1 .OR. IX .GT. MXINDX ) GOTO 9999 II=INDX(IX) IF ( II .EQ. 0 ) GOTO 9998 JJ=IDABS-10*IX + 2 DO 28 IMX=1,MXMX DO 27 IMA=2,MXMA IF ( IDABS .EQ. IDMX(IMA,IMX) ) THEN JJ=IMA GOTO 29 ENDIF 27 CONTINUE 28 CONTINUE 29 IF ( ID .GT. 0 ) THEN IC(1)=ICRE1(II,JJ) IC(2)=ICRE2(II,JJ) ELSE IC(2)=ICRE1(II,JJ) IC(1)=ICRE2(II,JJ) ENDIF IF ( IC(1) .EQ. 100000 .AND. IC(2) .EQ. 100000 * .AND. RANGEN() .LT. 0.5 ) THEN IC(1)=010000 IC(2)=010000 ENDIF ELSEIF ( MOD(ID/100000000,10) .EQ. 8 ) THEN IC(1)=MOD(ID,100000000)/10000*100 IC(2)=MOD(ID,10000)*100 ELSE WRITE(IFCH,*)' ' WRITE(IFCH,*)'***** ID: ',ID CALL UTSTOP('IDTR4: UNRECOGNIZED ID ') ENDIF RETURN 9998 WRITE(IFCH,*)' ' WRITE(IFCH,*)'ID: ',ID CALL UTSTOP('IDTR4: INDX=0. ') RETURN 9999 WRITE(IFCH,*)' ' WRITE(IFCH,*)'ID: ',ID CALL UTSTOP('IDTR4: IX OUT OF RANGE. ') RETURN END C======================================================================= SUBROUTINE JAMBR1(NS,NSG,IRET) C----------------------------------------------------------------------- C "AMOR" (KOCH+WERNER, 89) C BREAKS STRING NS ACCORDING TO A-M MODEL. C NS: POINTS TO THE CURRENT FRAGMENTING STRING. C NSG: POINTS TO THE LAST PRODUCED SUBSTRING (SUCC INCREASED) C INPUT: C PSG(,NS): MOMENTUM OF STRING NS IN PP-CMS C PJT(,2*NS-1),PJT(,2*NS): MOMENTUM OF END OF STRING NS IN PP-CMS C OUTPUT: C XORSG(,NSG): ORIGIN OF SUBSTRING NSG IN PP-CMS C PJT(,2*NSG-1),PJT(,2*NSG): MOMENTUM OF END OF SUBSTRING NSG IN PP-CMS C ICJT(,2*NSG-1),ICJT(,2*NSG): IC-CODE OF END OF SUBSTRG NSG IN PP-CMS C PSG(,NSG): MOMENTUM OF SUBSTRING NSG IN PP-CMS C XBKPTL(,NPTLC-NPTL2): BREAKPOINT OF NS IN PP-CMS C ISPTL(,NPTLC-NPTL2): 1 IF STRING NS BREAKS C----------------------------------------------------------------------- PARAMETER (MXPC=500) PARAMETER (MXSG=500) PARAMETER (MXJT=2*MXSG) PARAMETER (NFLAV=6) PARAMETER (NPTF=129) COMMON /CDELRE/ DELRER COMMON /CJAMBR/ NPTLC,NPTL2 COMMON /CNSTA/ AINFIN,PI,PIOM,PROM DOUBLE PRECISION XBKPTL COMMON /CPC/ XBKPTL(2,MXPC),ISPTL(MXPC) COMMON /CPTF/ FPTFS,FPTFSS,FPTFU,FPTFUS,FPTFUU * ,QPTFS(NPTF),QPTFSS(NPTF),QPTFU(NPTF),QPTFUS(NPTF) * ,QPTFUU(NPTF),XPTF(NPTF) DOUBLE PRECISION PJT,PSG,ROTSG,XORSG COMMON /CSG/ PJT(5,MXJT),PSG(5,MXSG),ROTSG(3,MXSG) * ,XORSG(4,MXSG) * ,ICJT(2,MXJT),IORSG(MXSG),ISG(MXSG) COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT COMMON /QUARKM/ SMAS,SSMAS,USMAS,UUMAS DOUBLE PRECISION DAUXI1,DAUXI2,ETA,EETA,ETAM,ETAP * ,PM,PP,PT,PX,PY,P0M,P0P,XBK(4),XOR1(4),XOR2(4) INTEGER IC(2),ICM(2),ICMP(2),ICMS(2) * ,ICP(2),ICPM(2),ICPS(2),ICX(2),ICY(2) * ,JC(NFLAV,2) * ,JCM(NFLAV,2),JCMP(NFLAV,2),JCMS(NFLAV,2) * ,JCP(NFLAV,2),JCPM(NFLAV,2),JCPS(NFLAV,2) * ,JCX(NFLAV,2),JCY(NFLAV,2) SAVE C----------------------------------------------------------------------- NCNT3=0 NSG0=NSG 9993 NSG=NSG0 IRET=0 ICP(1)=ICJT(1,2*NS-1) ICP(2)=ICJT(2,2*NS-1) ICM(1)=ICJT(1,2*NS) ICM(2)=ICJT(2,2*NS) CALL IDDECO(ICP,JCP) CALL IDDECO(ICM,JCM) NP=0 DO 7 NF=1,NFLAV JC(NF,1)=JCP(NF,1)+JCM(NF,1) JC(NF,2)=JCP(NF,2)+JCM(NF,2) NP=NP+JCP(NF,1)-JCP(NF,2) 7 CONTINUE CALL IDENCO(JC,IC,IRETEN) ID=IDTRA(IC,0,0,3) AMMS=UTAMNX(JCP,JCM) AM=PSG(5,NS) C SPLIT STRING C ------------ J1 = 2*NS J2 = J1-1 DAUXI1= PJT(4,J1)+PJT(4,J2) DAUXI2= PJT(3,J1)+PJT(3,J2) P0P = DAUXI1 + DAUXI2 P0M = DAUXI1 - DAUXI2 9994 NCNT3=NCNT3+1 IF ( NCNT3 .GT. 100 ) THEN IF ( ISH .GE. 90 ) THEN CALL UTMSG('JAMBR1') WRITE(IFCH,*)'***** SPLIT KINEM NOT POSSIBLE.' WRITE(IFCH,112) * (ICJT(J,2*NS-1),J=1,2),(ICJT(J,2*NS),J=1,2),PSG(5,NS) 112 FORMAT(1X,2I8,4X,2I8,4X,F7.2) CALL UTMSGF ENDIF IF ( NS .EQ. 1 ) THEN IRET=9999 RETURN ENDIF IRET=9996 RETURN ENDIF DO 17 NF=1,NFLAV JCPM(NF,1)=0 JCPM(NF,2)=0 JCMP(NF,1)=0 JCMP(NF,2)=0 17 CONTINUE C DETERMINE FLAVOUR C ----------------- NQU=0 IF ( ISH .GE. 93 ) THEN WRITE(IFCH,*)'ORDINARY STRING FRAGMENTATION' WRITE(IFCH,*)' ' ENDIF IF ( RANGEN() .LE. PDIQUA ) THEN NQU=2 ELSE NQU=1 ENDIF IF ( MOD(NP+NQU,3) .EQ. 0 ) THEN II=1 ELSEIF ( MOD(NP-NQU,3) .EQ. 0 ) THEN II=2 ELSE CALL UTSTOP('JAMBR1: NO SINGLET CONSTRUCTION POSSIBLE') ENDIF IFLTT=0 DO 8 N=1,NQU IFL=INT(RANGEN()/PUD)+1 IFLTT=IFLTT*10+(IFL+1)/2 JCPM(IFL,II)=JCPM(IFL,II)+1 JCMP(IFL,3-II)=JCMP(IFL,3-II)+1 8 CONTINUE CALL IDENCO(JCPM,ICPM,IRETEN) IF ( IRETEN .EQ. 1 ) THEN CALL UTSTOP('JAMBR1: IDENCO(JCPM... RET.CODE=1 ') ENDIF CALL IDENCO(JCMP,ICMP,IRETEN) IF ( IRETEN .EQ. 1 ) THEN CALL UTSTOP('JAMBR1: IDENCO(JCMP... RET.CODE=1 ') ENDIF DO 25 NF=1,NFLAV JCPS(NF,1)=JCP(NF,1)+JCPM(NF,1) JCPS(NF,2)=JCP(NF,2)+JCPM(NF,2) JCMS(NF,1)=JCM(NF,1)+JCMP(NF,1) JCMS(NF,2)=JCM(NF,2)+JCMP(NF,2) 25 CONTINUE CALL IDENCO(JCPS,ICPS,IRETEN) CALL IDENCO(JCMS,ICMS,IRETEN) CALL IDCOMK(ICPS) CALL IDCOMK(ICMS) C CALCULATE P+,P-,PT OF STRING BREAKING C ------------------------------------- IF ( ISH .GE. 93 ) THEN WRITE(IFCH,109)ICM(1),ICMP(1),ICPM(1),ICP(1) * ,ICM(2),ICMP(2),ICPM(2),ICP(2) 109 FORMAT(1X,'FLAVORS:',2(I11,I7)/9X,2(I11,I7)/) WRITE(IFCH,*)'IFLTT:',IFLTT WRITE(IFCH,*)' ' ENDIF IDP=IDTRA(ICPS,0,0,3) IDM=IDTRA(ICMS,0,0,3) AMMP=UTAMNY(JCP,JCPM) AMMM=UTAMNY(JCM,JCMP) R = RANGEN() IF ( IFLTT .EQ .1 ) THEN IF ( IOPTF .EQ. 1 ) THEN PT=UTINVT(NPTF,XPTF,QPTFU ,R*QPTFU(NPTF)) C## WRITE(IFCH,*)'JAMBR1:PT(OLD)=',PT ELSE RPT = R*FPTFU AUXIL=-4.*PTF**2/PI PT=SQRT(AUXIL*LOG(1.+RPT*2./AUXIL)) ENDIF ELSEIF ( IFLTT .EQ. 2 ) THEN IF ( IOPTF .EQ. 1 ) THEN PT=UTINVT(NPTF,XPTF,QPTFS ,R*QPTFS(NPTF)) ELSE RPT = R*FPTFS AUXIL=-4.*PTF**2/PI PT=SQRT(AUXIL*LOG(EXP(SMAS**2/AUXIL)+RPT*2./AUXIL)-SMAS**2) ENDIF ELSEIF ( IFLTT .EQ. 11 ) THEN IF ( IOPTF .EQ. 1 ) THEN PT=UTINVT(NPTF,XPTF,QPTFUU,R*QPTFUU(NPTF)) ELSE RPT = R*FPTFUU AUXIL=-4.*PTF**2/PI PT=SQRT(AUXIL*LOG(EXP(UUMAS**2/AUXIL)+RPT*2./AUXIL)-UUMAS**2) ENDIF ELSEIF ( IFLTT .EQ. 12 .OR. IFLTT .EQ. 21 ) THEN IF ( IOPTF .EQ. 1 ) THEN PT=UTINVT(NPTF,XPTF,QPTFUS,R*QPTFUS(NPTF)) ELSE RPT = R*FPTFUS AUXIL=-4.*PTF**2/PI PT=SQRT(AUXIL*LOG(EXP(USMAS**2/AUXIL)+RPT*2./AUXIL)-USMAS**2) ENDIF ELSEIF ( IFLTT .EQ. 22 ) THEN IF ( IOPTF .EQ. 1 ) THEN PT=UTINVT(NPTF,XPTF,QPTFSS,R*QPTFSS(NPTF)) ELSE RPT = R*FPTFSS AUXIL=-4.*PTF**2/PI PT=SQRT(AUXIL*LOG(EXP(SSMAS**2/AUXIL)+RPT*2./AUXIL)-SSMAS**2) ENDIF ENDIF LO=1 GOTO 48 47 LO=LO+1 PT=RANGEN()*PT 48 CONTINUE PHI=2.D0*PI*RANGEN() PX=PT*COS(PHI) PY=PT*SIN(PHI) TMMP= (PT**2+AMMP**2) TMMM= (PT**2+AMMM**2) AREA=-LOG(RANGEN())/PAREA AREART = SQRT(AREA) ETAM=LOG((TMMM +AREA)/(AREART *P0M)) ETAP=LOG((AREART *P0P)/(TMMP +AREA)) IF ( ETAM .GT. ETAP ) THEN IF ( LO .LT. 5 ) GOTO 47 GOTO 9994 ENDIF ETA=ETAM+RANGEN()*(ETAP-ETAM) AMP=SQRT(P0P*AREART *EXP(-ETA)-AREA-PT**2) AMM=SQRT(P0M*AREART *EXP( ETA)-AREA-PT**2) CALL IDRES(IDP,AMP,IDPR,IADJP) CALL IDRES(IDM,AMM,IDMR,IADJM) R=RANGEN() IF ( IDPR .EQ. 110 .AND. R .LT. 0.5 ) THEN IDP=220 AMP=.549 IF ( R .LT. 0.6666667 ) AMP=.958 CALL IDRES(IDP,AMP,IDPR,IADJP) IADJP=1 ENDIF R=RANGEN() IF ( IDMR .EQ. 110 .AND. R .LT. 0.5 ) THEN IDM=220 AMM=.549 IF ( R .LT. 0.6666667 ) AMM=.958 CALL IDRES(IDM,AMM,IDMR,IADJM) IADJM=1 ENDIF TMP2=(PT**2+AMP**2) TMM2=(PT**2+AMM**2) IF ( IADJP .EQ. 1 .AND. IADJM .NE. 1 ) THEN ETA=LOG((AREART *P0P)/(TMP2+AREA)) IF ( ETA .LT. ETAM ) GOTO 9994 AMM=SQRT(P0M*AREART *EXP(ETA)-AREA-PT**2) CALL IDRES(IDM,AMM,IDMR,IADJM) TMM2=(PT**2+AMM**2) ENDIF IF ( IADJP .NE. 1 .AND. IADJM .EQ. 1 ) THEN ETA=LOG((TMM2+AREA)/(AREART *P0M)) IF ( ETA .GT. ETAP ) GOTO 9994 AMP=SQRT(P0P*AREART *EXP(-ETA)-AREA-PT**2) CALL IDRES(IDP,AMP,IDPR,IADJP) TMP2=(PT**2+AMP**2) ENDIF IF ( IADJP .EQ. 1 .AND. IADJM .EQ. 1 ) THEN TM=(P0P*P0M-TMM2-TMP2)*0.5 IF ( TM .LT. 0. ) GOTO 9994 IF ( TM**2-TMP2*TMM2 .LT. 0. ) GOTO 9994 AREA=TM-SQRT(TM**2 -TMP2*TMM2) AREART = SQRT(AREA) EETA=P0P*AREART/(TMP2+AREA) IF ( EETA .LE. 0.D0 ) GOTO 9994 ETA=LOG(EETA) ENDIF PP=AREART*EXP(ETA) PM=AREART*EXP(-ETA) IF ( P0P-PP-PT**2/PM .LT. 0.D0 .OR. * P0M-PM-PT**2/PP .LT. 0.D0 ) THEN IF ( ISH .GE. 90 ) THEN CALL UTMSG('JAMBR1') WRITE(IFCH,*)'***** NEGATIVE JET ENERGY. SPLIT AGAIN.' IF ( P0P-PP-PT**2/PM .LT. 0.D0 ) * WRITE(IFCH,*)'P0P: ',P0P,' PP+PT**2/PM: ',PP+PT**2/PM IF ( P0M-PM-PT**2/PP .LT. 0.D0 ) * WRITE(IFCH,*)'P0M: ',P0M,' PM+PT**2/PP: ',PM+PT**2/PP CALL UTMSGF ENDIF GOTO 9994 ENDIF C DETERMINE BREAK PNT AND NEW ORIGINS C ----------------------------------- XOR1(1)=0.D0 XOR1(2)=0.D0 XOR1(3)=PP*0.5D0/TENSN XOR1(4)=PP*0.5D0/TENSN IF ( ISH .GE. 93 ) WRITE(IFCH,118)XOR1 118 FORMAT(' NEW ORIGIN +: ',13X,4F7.2) CALL UTROT2(-1,ROTSG(1,NS),ROTSG(2,NS),ROTSG(3,NS) * ,XOR1(1),XOR1(2),XOR1(3)) CALL UTLOB2(-1,PSG(1,NS),PSG(2,NS),PSG(3,NS),PSG(4,NS),PSG(5,NS) * ,XOR1(1),XOR1(2),XOR1(3),XOR1(4)) XOR1(1)=XOR1(1)+XORSG(1,NS) XOR1(2)=XOR1(2)+XORSG(2,NS) XOR1(3)=XOR1(3)+XORSG(3,NS) XOR1(4)=XOR1(4)+XORSG(4,NS) IF ( ISH .GE. 93 ) WRITE(IFCH,117)XOR1 XBK(1)=0.D0 XBK(2)=0.D0 XBK(3)=0.5D0/TENSN*(PP-PM) XBK(4)=0.5D0/TENSN*(PP+PM) IF ( ISH .GE. 93 ) WRITE(IFCH,116)XBK 116 FORMAT(' BREAKING PNT: ',13X,4F7.2) CALL UTROT2(-1,ROTSG(1,NS),ROTSG(2,NS),ROTSG(3,NS) * ,XBK(1),XBK(2),XBK(3)) CALL UTLOB2(-1,PSG(1,NS),PSG(2,NS),PSG(3,NS),PSG(4,NS),PSG(5,NS) * ,XBK(1),XBK(2),XBK(3),XBK(4)) XBK(1)=XBK(1)+XORSG(1,NS) XBK(2)=XBK(2)+XORSG(2,NS) XBK(3)=XBK(3)+XORSG(3,NS) XBK(4)=XBK(4)+XORSG(4,NS) IF ( ISH .GE. 93 ) WRITE(IFCH,117)XBK 117 FORMAT(28X,4F7.2/) XOR2(1)=0.D0 XOR2(2)=0.D0 XOR2(3)=-PM*0.5D0/TENSN XOR2(4)= PM*0.5D0/TENSN IF ( ISH .GE. 93 ) WRITE(IFCH,119)XOR2 119 FORMAT(' NEW ORIGIN -: ',13X,4F7.2) CALL UTROT2(-1,ROTSG(1,NS),ROTSG(2,NS),ROTSG(3,NS) * ,XOR2(1),XOR2(2),XOR2(3)) CALL UTLOB2(-1,PSG(1,NS),PSG(2,NS),PSG(3,NS),PSG(4,NS),PSG(5,NS) * ,XOR2(1),XOR2(2),XOR2(3),XOR2(4)) XOR2(1)=XOR2(1)+XORSG(1,NS) XOR2(2)=XOR2(2)+XORSG(2,NS) XOR2(3)=XOR2(3)+XORSG(3,NS) XOR2(4)=XOR2(4)+XORSG(4,NS) IF ( ISH .GE. 93 ) WRITE(IFCH,117)XOR2 C STORE THE TWO SUBSTRINGS C ------------------------ NSGB=NSG DO 9998 M=1,2 NSG=NSG+1 IF ( NSG .GT. MXSG ) THEN CALL UTSTOP('JAMBR1: NSG>MXSG ') ENDIF ISG(NSG)=NPTLC IF ( M .EQ. 1 ) THEN XORSG(1,NSG)=XOR1(1) XORSG(2,NSG)=XOR1(2) XORSG(3,NSG)=XOR1(3) XORSG(4,NSG)=XOR1(4) PJT(1,2*NSG-1)=0.D0 PJT(2,2*NSG-1)=0.D0 PJT(3,2*NSG-1)=(P0P-PP-PT**2/PM)*0.5D0 PJT(4,2*NSG-1)=(P0P-PP-PT**2/PM)*0.5D0 PJT(5,2*NSG-1)=0.D0 ICJT(1,2*NSG-1)=ICJT(1,2*NS-1) ICJT(2,2*NSG-1)=ICJT(2,2*NS-1) PJT(1,2*NSG)=PX PJT(2,2*NSG)=PY PJT(3,2*NSG)=(PT**2/PM-PM)*0.5D0 PJT(4,2*NSG)=(PT**2/PM+PM)*0.5D0 PJT(5,2*NSG)=0.D0 ICJT(1,2*NSG)=ICPM(1) ICJT(2,2*NSG)=ICPM(2) DO 11 NF=1,NFLAV JC(NF,1)=JCPS(NF,1) JC(NF,2)=JCPS(NF,2) 11 CONTINUE ELSE XORSG(1,NSG)=XOR2(1) XORSG(2,NSG)=XOR2(2) XORSG(3,NSG)=XOR2(3) XORSG(4,NSG)=XOR2(4) PJT(1,2*NSG-1)=-PX PJT(2,2*NSG-1)=-PY PJT(3,2*NSG-1)=(PP-PT**2/PP)*0.5D0 PJT(4,2*NSG-1)=(PP+PT**2/PP)*0.5D0 PJT(5,2*NSG-1)=0.D0 ICJT(1,2*NSG-1)=ICMP(1) ICJT(2,2*NSG-1)=ICMP(2) DO 12 NF=1,NFLAV JC(NF,1)=JCMS(NF,1) JC(NF,2)=JCMS(NF,2) 12 CONTINUE PJT(1,2*NSG)=0.D0 PJT(2,2*NSG)=0.D0 PJT(3,2*NSG)=-(P0M-PM-PT**2/PP)*0.5D0 PJT(4,2*NSG)= (P0M-PM-PT**2/PP)*0.5D0 PJT(5,2*NSG)=0.D0 ICJT(1,2*NSG)=ICJT(1,2*NS) ICJT(2,2*NSG)=ICJT(2,2*NS) ENDIF ICX(1)=ICJT(1,2*NSG-1) ICX(2)=ICJT(2,2*NSG-1) ICY(1)=ICJT(1,2*NSG) ICY(2)=ICJT(2,2*NSG) CALL IDDECO(ICX,JCX) CALL IDDECO(ICY,JCY) DO 28 N=1,NFLAV DO 29 I=1,2 K=JCX(N,I)+JCY(N,I)-JC(N,I) IF ( K .LE. 0 ) GOTO 28 DO 19 L=1,K JX=JCX(N,I) JY=JCY(N,I) IF ( JX .EQ. 0 .AND. JY .GT. 0 ) THEN JCY(N,I)=JCY(N,I)-1 ELSEIF ( JX .GT. 0 .AND. JY .EQ. 0 ) THEN JCX(N,I)=JCX(N,I)-1 ELSEIF ( JX .GT. 0 .AND. JY .GT. 0 ) THEN IF ( RANGEN() .LT. 0.5 ) THEN JCX(N,I)=JCX(N,I)-1 ELSE JCY(N,I)=JCY(N,I)-1 ENDIF ELSE WRITE(IFCH,*)('*',LP=1,71) WRITE(IFCH,*)'***** IC; ',IC WRITE(IFCH,*)'***** ICX: ',ICX WRITE(IFCH,*)'***** ICY: ',ICY WRITE(IFCH,*)'***** N,I,K,L: ',N,I,K,L WRITE(IFCH,*)'***** JX,JY: ',JX,JY WRITE(IFCH,*)('*',LP=1,71) CALL UTSTOP('JAMBR1: ERROR DURING JET COMPACTIFICATN ') ENDIF 19 CONTINUE 29 CONTINUE 28 CONTINUE CALL IDENCO(JCX,ICX,IRETEN) IF ( IRETEN .EQ. 1 ) THEN CALL UTSTOP('JAMBR1: IDENCO(JCX... RET.CODE=1 ') ENDIF CALL IDENCO(JCY,ICY,IRETEN) IF ( IRETEN .EQ. 1 ) THEN CALL UTSTOP('JAMBR1: IDENCO(JCY... RET.CODE=1 ') ENDIF ICJT(1,2*NSG-1)=ICX(1) ICJT(2,2*NSG-1)=ICX(2) ICJT(1,2*NSG) =ICY(1) ICJT(2,2*NSG) =ICY(2) IF ( ISH .GE. 93 ) THEN WRITE(IFCH,108)NSG,NS * ,(ICJT(J,2*NSG-1),J=1,2),(SNGL(PJT(J,2*NSG-1)),J=1,5) 108 FORMAT(1X,I5,I4,I9,I7,1P,5E10.2) WRITE(IFCH,108)NSG,NS * ,(ICJT(J,2*NSG ),J=1,2),(SNGL(PJT(J,2*NSG )),J=1,5) ENDIF PSG(1,NSG)=PJT(1,2*NSG-1)+PJT(1,2*NSG) PSG(2,NSG)=PJT(2,2*NSG-1)+PJT(2,2*NSG) PSG(3,NSG)=PJT(3,2*NSG-1)+PJT(3,2*NSG) PSG(4,NSG)=PJT(4,2*NSG-1)+PJT(4,2*NSG) PSG(5,NSG)= * SQRT(PSG(4,NSG)**2-PSG(3,NSG)**2-PSG(2,NSG)**2-PSG(1,NSG)**2) IF ( ISH .GE. 93 ) WRITE(IFCH,110)NSG,NS,(PSG(J,NSG),J=1,5) 110 FORMAT(1X,I5,I4,16X,1P,5E10.2) CALL UTROT2(-1,ROTSG(1,NS),ROTSG(2,NS),ROTSG(3,NS) * ,PSG(1,NSG),PSG(2,NSG),PSG(3,NSG)) CALL UTLOB2(-1,PSG(1,NS),PSG(2,NS),PSG(3,NS),PSG(4,NS),PSG(5,NS) * ,PSG(1,NSG),PSG(2,NSG),PSG(3,NSG),PSG(4,NSG)) IORSG(NSG)=NS IF ( ISH .GE. 93 ) THEN WRITE(IFCH,102)NSG,IORSG(NSG),(PSG(J,NSG),J=1,5) 102 FORMAT(1X,I5,I4,16X,1P,5E10.2) WRITE(IFCH,*)' ' ENDIF C-C DO 56 I=1,2 C-C ICPZ(I)=ICJT(I,2*NSG-1) C-C56 ICMZ(I)=ICJT(I,2*NSG) C-C CALL IDDECO(ICPZ,JCPZ) C-C CALL IDDECO(ICMZ,JCMZ) C-C DO 57 NF=1,NFLAV C-C JCZ(NF,1)=JCPZ(NF,1)+JCMZ(NF,1) C-C57 JCZ(NF,2)=JCPZ(NF,2)+JCMZ(NF,2) C-C CALL IDENCO(JCZ,ICZ,IRETEN) C-C IDZ=IDTRA(ICZ,0,0,3) C-C AMZ=PSG(5,NSG) C-C CALL IDRES(IDZ,AMZ,IDRZ,IADJ) C-C IF ( IDRZ.EQ.110 .AND. RANGEN().LT.0.5 ) GOTO 9993 9998 CONTINUE XBKPTL(1,NPTLC-NPTL2)=XBK(3) XBKPTL(2,NPTLC-NPTL2)=XBK(4) ISPTL(NPTLC-NPTL2)=1 RETURN END C======================================================================= SUBROUTINE JAMBR2(NS,NSG,IRET) C----------------------------------------------------------------------- C "SAMBA" (SCHOLTEN+WERNER, MAR 92) C BREAKS STRING NS ACCORDING TO A-M MODEL. C NS: POINTS TO THE CURRENT FRAGMENTING STRING. C NSG: POINTS TO THE LAST PRODUCED SUBSTRING (SUCC INCREASED) C INPUT: C PSG(,NS): MOMENTUM OF STRING NS IN PP-CMS C PJT(,2*NS-1),PJT(,2*NS): MOMENTUM OF END OF STRING NS IN PP-CMS C OUTPUT: C XORSG(,NSG): ORIGIN OF SUBSTRING NSG IN PP-CMS C PJT(,2*NSG-1),PJT(,2*NSG): MOMENTUM OF END OF SUBSTRING NSG IN PP-CMS C ICJT(,2*NSG-1),ICJT(,2*NSG): IC-CODE OF END OF SUBSTRG NSG IN PP-CMS C PSG(,NSG): MOMENTUM OF SUBSTRING NSG IN PP-CMS C XBKPTL(,NPTLC-NPTL2): BREAKPOINT OF NS IN PP-CMS C ISPTL(,NPTLC-NPTL2): 1 IF STRING NS BREAKS C----------------------------------------------------------------------- PARAMETER (MXPC=500) PARAMETER (MXSG=500) PARAMETER (MXJT=2*MXSG) PARAMETER (NBRM=99) PARAMETER (NFLAV=6) PARAMETER (NPTF=129) DOUBLE PRECISION XBKPTL COMMON /CDELRE/ DELRER COMMON /CJAMBR/ NPTLC,NPTL2 COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /CPC/ XBKPTL(2,MXPC),ISPTL(MXPC) COMMON /CPTF/ FPTFS,FPTFSS,FPTFU,FPTFUS,FPTFUU * ,QPTFS(NPTF),QPTFSS(NPTF),QPTFU(NPTF),QPTFUS(NPTF) * ,QPTFUU(NPTF),XPTF(NPTF) DOUBLE PRECISION PJT,PSG,ROTSG,XORSG COMMON /CSG/ PJT(5,MXJT),PSG(5,MXSG),ROTSG(3,MXSG) * ,XORSG(4,MXSG) * ,ICJT(2,MXJT),IORSG(MXSG),ISG(MXSG) COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT COMMON /QUARKM/ SMAS,SSMAS,USMAS,UUMAS DOUBLE PRECISION A,AMAM,AMAX,ANEW,DA,DALFA,DATWID * ,DAUXIL,DR,DY,DYST,DYT,DY1,DY2,PHI,PM,PP,PT * ,PW(4),PX,PY,P0M,P0P,RA,RMX,RMY,XBK(4) * ,XBR,XOR2(4),XP,X2,YBR,YP,YTD,YNEW REAL PXBRAK(100),PYBRAK(100),XBREAK(100),YBREAK(100) INTEGER ICM(2),ICMP(2),ICMPBR(2,100),ICMZ(2) * ,ICP(2),ICPM(2),ICPMBR(2,100),ICPZ(2) * ,ICZ(2),ITRD(100),JC(NFLAV,2) * ,JCM(NFLAV,2),JCMP(NFLAV,2),JCMS(NFLAV,2),JCMZ(NFLAV,2) * ,JCP(NFLAV,2),JCPM(NFLAV,2),JCPZ(NFLAV,2),JCZ(NFLAV,2) LOGICAL LAST SAVE C----------------------------------------------------------------------- NCNT3=0 NSG0=NSG 9993 NSG=NSG0 C INITIALIZATION C -------------- IRET=0 ICP(1)=ICJT(1,2*NS-1) ICP(2)=ICJT(2,2*NS-1) ICM(1)=ICJT(1,2*NS) ICM(2)=ICJT(2,2*NS) ICPMBR(1,1)=ICM(1) ICPMBR(2,1)=ICM(2) CALL IDDECO(ICP,JCP) CALL IDDECO(ICM,JCM) NP=0 DO 7 NF=1,NFLAV NP=NP+JCP(NF,1)-JCP(NF,2) 7 CONTINUE AMMS=UTAMNX(JCP,JCM) AM=PSG(5,NS) C J = 2*NS DAUXIL= PJT(3,J-1)+PJT(3,J) P0P=PJT(4,J-1)+PJT(4,J)+DAUXIL P0M=PJT(4,J-1)+PJT(4,J)-DAUXIL XT=P0M YT=P0P C DALFA=DBLE(PAREA) C INITIALIZE XBREAK(1)=XT YBREAK(1)=0. PXBRAK(1)=0. PYBRAK(1)=0. C REDO C ---- NCNT3=0 9994 NCNT3=NCNT3+1 IBR=1 XP=XT YP=0.D0 YTD=YT IF ( NCNT3 .GT. 100 ) THEN IF ( ISH .GE. 90 ) THEN CALL UTMSG('JAMBR2') WRITE(IFCH,*)'***** SPLIT KINEM NOT POSSIBLE.' WRITE(IFCH,112) * (ICJT(J,2*NS-1),J=1,2),(ICJT(J,2*NS),J=1,2),PSG(5,NS) 112 FORMAT(1X,2I8,4X,2I8,4X,F7.2) CALL UTMSGF ENDIF IF ( NS .EQ. 1 ) THEN IRET=9999 RETURN ENDIF IRET=9996 RETURN ENDIF C SEARCH FOR BREAKPOINTS C ---------------------- 9 CONTINUE DO 17 NF=1,NFLAV JCPM(NF,1)=0 JCPM(NF,2)=0 JCMP(NF,1)=0 JCMP(NF,2)=0 17 CONTINUE C ORDINARY STRINGS C ---------------- C NQU=0 IF ( ISH .GE. 92 ) THEN WRITE(IFCH,*)'ORDINARY STRING FRAGMENTATION' WRITE(IFCH,*)' ' ENDIF IF ( RANGEN() .LE. PDIQUA ) THEN NQU=2 ELSE NQU=1 ENDIF IF ( MOD(NP+NQU,3) .EQ. 0 ) THEN II=1 ELSEIF ( MOD(NP-NQU,3) .EQ. 0 ) THEN II=2 ELSE CALL UTSTOP('JAMBR2: NO SINGLET CONSTRUCTION POSSIBLE') ENDIF IFLTT=0 DO 18 N=1,NQU IFL=INT(RANGEN()/PUD)+1 IFLTT=IFLTT*10+(IFL+1)/2 JCPM(IFL,II)=JCPM(IFL,II)+1 JCMP(IFL,3-II)=JCMP(IFL,3-II)+1 18 CONTINUE CALL IDENCO(JCPM,ICPM,IRETEN) IF ( IRETEN .EQ. 1 ) THEN CALL UTSTOP('JAMBR2: IDENCO(JCPM... RET.CODE=1 ') ENDIF CALL IDENCO(JCMP,ICMP,IRETEN) IF ( IRETEN .EQ. 1 ) THEN CALL UTSTOP('JAMBR2: IDENCO(JCMP... RET.CODE=1 ') ENDIF C CALCULATE PT OF STRING BREAKING C ------------------------------------- IF ( ISH .GE. 92 ) THEN WRITE(IFCH,109)ICM(1),ICMP(1),ICPM(1),ICP(1) * ,ICM(2),ICMP(2),ICPM(2),ICP(2) 109 FORMAT(1X,'FLAVORS:',2(I11,I7)/9X,2(I11,I7)/) WRITE(IFCH,*)'IFLTT:',IFLTT WRITE(IFCH,*)' ' ENDIF AMMP=UTAMNY(JCP,JCPM) AMMM=UTAMNY(JCMP,JCM) R = RANGEN() IF ( IFLTT .EQ. 1 ) THEN IF ( IOPTF .EQ. 1 ) THEN PT=UTINVT(NPTF,XPTF,QPTFU ,R*QPTFU(NPTF)) C## WRITE(IFCH,*)'JAMBR2:PT(OLD)=',PT ELSE RPT = R*FPTFU AUXIL=-4.*PTF**2/PI PT=SQRT(AUXIL*LOG(1.+RPT*2./AUXIL)) ENDIF ELSEIF ( IFLTT .EQ. 2 ) THEN IF ( IOPTF .EQ. 1 ) THEN PT=UTINVT(NPTF,XPTF,QPTFS ,R*QPTFS(NPTF)) ELSE RPT = R*FPTFS AUXIL=-4.*PTF**2/PI PT=SQRT(AUXIL*LOG(EXP(SMAS **2/AUXIL)+RPT*2./AUXIL)-SMAS **2) ENDIF ELSEIF ( IFLTT .EQ. 11 ) THEN IF ( IOPTF .EQ. 1 ) THEN PT=UTINVT(NPTF,XPTF,QPTFUU,R*QPTFUU(NPTF)) ELSE RPT = R*FPTFUU AUXIL=-4.*PTF**2/PI PT=SQRT(AUXIL*LOG(EXP(UUMAS**2/AUXIL)+RPT*2./AUXIL)-UUMAS**2) ENDIF ELSEIF ( IFLTT .EQ. 12 .OR. IFLTT .EQ. 21 ) THEN IF ( IOPTF .EQ. 1 ) THEN PT=UTINVT(NPTF,XPTF,QPTFUS,R*QPTFUS(NPTF)) ELSE RPT = R*FPTFUS AUXIL=-4.*PTF**2/PI PT=SQRT(AUXIL*LOG(EXP(USMAS**2/AUXIL)+RPT*2./AUXIL)-USMAS**2) ENDIF ELSEIF ( IFLTT .EQ. 22 ) THEN IF ( IOPTF .EQ. 1 ) THEN PT=UTINVT(NPTF,XPTF,QPTFSS,R*QPTFSS(NPTF)) ELSE RPT = R*FPTFSS AUXIL=-4.*PTF**2/PI PT=SQRT(AUXIL*LOG(EXP(SSMAS**2/AUXIL)+RPT*2./AUXIL)-SSMAS**2) ENDIF ENDIF IF ( IBR .EQ. 1 ) THEN RMX=AMMM**2+PT**2 ELSE RMX=0.001D0 ENDIF RMY=AMMP**2+PT**2 IF ( RMY .GT. XP*(YTD-YP) ) GOTO 8 C SINGLE ARTRU-MENNESSIER BREAK (SAMB) C ------------------------------------ C IN: XP,YP,YTD,RMX,RMY C IN: DALFA C OUT: XBR,YBR DYT=YTD-YP C Y-STEPPING RANGE AMAM=1.D0+(RMX-RMY)/(XP*DYT) A=(1.D0-4.D0*RMX/(AMAM*AMAM*XP*DYT)) IF ( A .LT. 0.D0 ) GOTO 8 A=SQRT(A) DY1=DYT*AMAM*(1.D0-A)*0.5D0 DY2=DYT*AMAM*(1.D0+A)*0.5D0 DYST=0.0001D0*(DYT-DY2) 3 CONTINUE DR=DBLE(1.-RANGEN()) AMAX=XP*DYT*A*AMAM+RMX*LOG(DY1/DY2)+RMY*LOG((DYT-DY2)/(DYT-DY1)) RA=-LOG(DR)/DALFA IF ( RA .GT. AMAX .AND. IBR .GT. 1 ) GOTO 8 RA=MOD(RA,AMAX) DY=DYT*SQRT(RMX)/(SQRT(RMX)+SQRT(RMY)) DATWID=XP*(DY-DY1)+RMX*LOG(DY1/DY)+RMY*LOG((DYT-DY)/(DYT-DY1)) ANEW=RA-DATWID ICOUNT=0 IF ( ANEW .GT. 0.D0 ) GOTO 1 2 CONTINUE DA=XP - RMX/DY - RMY/(DYT-DY) YNEW=DY+ANEW/DA DY=INT(YNEW/DYST)*DYST IF ( DY .LT. DY1 ) THEN WRITE(IFCH,*) 'DY,DY1',DY,DY1 GOTO 4 ENDIF ANEW=RA-XP*(DY-DY1)-RMX*LOG(DY1/DY)-RMY*LOG((DYT-DY)/(DYT-DY1)) IF ( ANEW .LT. 0.D0 ) GOTO 2 GOTO 4 1 CONTINUE DA=XP - RMX/DY - RMY/(DYT-DY) YNEW=DY+ANEW/DA DY=(INT(YNEW/DYST)+1)*DYST ANEW=RA-XP*(DY-DY1)-RMX*LOG(DY1/DY)-RMY*LOG((DYT-DY)/(DYT-DY1)) IF ( ANEW .GT. 0.D0 ) GOTO 1 DY=DY-DYST ANEW=RA-XP*(DY-DY1)-RMX*LOG(DY1/DY)-RMY*LOG((DYT-DY)/(DYT-DY1)) 4 CONTINUE YBR=MIN( DY+RANGEN()*DYST, DY2 ) X2=(XP-RMX/YBR) XBR=MIN( ANEW/DYST+RMY/(DYT-YBR), X2 ) C BETTER: SOLVE FOR YBR FROM ANEW=0 C FIND XBR FROM HOMOGENEOUS (NOT EXP) DISTR, X1NBRM ') ENDIF IBR=IBR+1 XBREAK(IBR)=XBR YBREAK(IBR)=YBR PHI=2.D0*PI*RANGEN() PXBRAK(IBR)=PT*COS(PHI) PYBRAK(IBR)=PT*SIN(PHI) ICPMBR(1,IBR)=ICPM(1) ICPMBR(2,IBR)=ICPM(2) ICMPBR(1,IBR)=ICMP(1) ICMPBR(2,IBR)=ICMP(2) XP=XBR YP=YBR AMLEFT=SQRT(YBR*(XT-XBR)) AMRIGT=SQRT(XBR*(YT-YBR)) GOTO 9 8 CONTINUE IF ( IBR .EQ. 1 ) GOTO 9994 C INITIALIZE TAIL END C ------------------- XBREAK(IBR+1)=0. YBREAK(IBR+1)=YT PXBRAK(IBR+1)=0. PYBRAK(IBR+1)=0. ICMPBR(1,IBR+1)=ICP(1) ICMPBR(2,IBR+1)=ICP(2) C PRINT C ----- IF ( ISH .GE. 92 ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,*)'ICMPBR(1/2,) X/YBREAK PX/YBREAK:' DO 52 IB=1,IBR+1 WRITE(IFCH,100)ICMPBR(1,IB),ICMPBR(2,IB) * ,XBREAK(IB),YBREAK(IB),PXBRAK(IB),PYBRAK(IB) 100 FORMAT(1X,I10,I10,2E11.3,7X,2E11.3) WRITE(IFCH,100)ICPMBR(1,IB),ICPMBR(2,IB) 52 CONTINUE WRITE(IFCH,*)' ' ENDIF C TIME ORDER BREAKPOINTS C ---------------------- T1=0. DO 203 J=2,IBR T2=2. DO 20 I=2,IBR C T=XBREAK(I)/XT+YBREAK(I)/YT T=XBREAK(I)*YBREAK(I)/(XT*YT) IF ( T .LE. T1 .OR. T .GT. T2 ) GOTO 20 T2=T NT=I 20 CONTINUE T1=T2 ITRD(J)=NT 203 CONTINUE C PRINT C ----- IF ( ISH .GE. 92 ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,*)'ITRD:' WRITE(IFCH,*)(ITRD(IB),IB=2,IBR) WRITE(IFCH,*)' ' ENDIF C CHECK ACCEPTANCE CRITERIUM C -------------------------- NBR=0 DO 12 J=2,IBR I=ITRD(J) XBRI=XBREAK(I) YBRI=YBREAK(I) C FIND NEIGHBORING EARLIER BREAK POINTS IR=IBR+1 IL=1 DO 204 JN=2,J IN=ITRD(JN) IF ( IN .GT. I .AND. IN .LT. IR ) IR=IN IF ( IN .LT. I .AND. IN .GT. IL ) IL=IN 204 CONTINUE PML=(XBREAK(IL)-XBRI) PPL=(YBRI-YBREAK(IL)) PMR=(XBRI-XBREAK(IR)) PPR=(YBREAK(IR)-YBRI) PX=PXBRAK(I) PY=PYBRAK(I) PXL=PX-PXBRAK(IL) PYL=PY-PYBRAK(IL) AMMM=PML*PPL-(PXL*PXL+PYL*PYL) PXR=PXBRAK(IR)-PX PYR=PYBRAK(IR)-PY AMMP=PMR*PPR-(PXR*PXR+PYR*PYR) IF ( AMMP .LE. 0. ) GOTO 13 IF ( AMMM .LE. 0. ) GOTO 13 AMMP=SQRT(AMMP) AMMM=SQRT(AMMM) AMP=AMMP AMM=AMMM CALL UTRESM(ICMPBR(1,IR),ICMPBR(2,IR) * ,ICPMBR(1,I),ICPMBR(2,I),AMP,IDPR,IADJP,IRETEN) CALL UTRESM(ICPMBR(1,IL),ICPMBR(2,IL) * ,ICMPBR(1,I),ICMPBR(2,I),AMM,IDMR,IADJM,IRETEN) IF ( AMP .GT. AMMP ) GOTO 13 IF ( AMM .GT. AMMM ) GOTO 13 PT2=PX*PX+PY*PY PTL2=PXBRAK(IL)**2+PYBRAK(IL)**2 PTR2=PXBRAK(IR)**2+PYBRAK(IR)**2 D=(PML*PPL-PTL2-PT2)*0.5 D=D*D-PT2*PTL2 IF ( D .LE. 0. ) GOTO 13 D=(PMR*PPR-PTR2-PT2)*0.5 D=D*D-PT2*PTR2 IF ( D .LE. 0. ) GOTO 13 NBR=NBR+1 GOTO 12 13 CONTINUE ITRD(J)=-1 XBREAK(I)=-1. YBREAK(I)=-1. 12 CONTINUE IF ( NBR .EQ. 0 ) GOTO 9994 C PRINT C ----- IF ( ISH .GE. 92 ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,*)'ICMPBR(1/2,) X/YBREAK PX/YBREAK:' DO 53 IB=1,IBR+1 WRITE(IFCH,100)ICMPBR(1,IB),ICMPBR(2,IB) * ,XBREAK(IB),YBREAK(IB),PXBRAK(IB),PYBRAK(IB) WRITE(IFCH,100)ICPMBR(1,IB),ICPMBR(2,IB) 53 CONTINUE WRITE(IFCH,*)' ' ENDIF C BUILD NEW STRINGS C ----------------- NBREAK=0 TAUAVE=0. IL=1 IN=IL IR=1 LAST=.FALSE. 11 CONTINUE IR=IR+1 IF ( IR .EQ. IBR+1 ) LAST=.TRUE. IF ( XBREAK(IR) .LT. 0. ) GOTO 11 IF ( IN .EQ. 1 ) GOTO 14 15 CONTINUE IF ( ISH .GE. 92 ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,*)'IL IN IR: ',IL,IN,IR WRITE(IFCH,*)' ' ENDIF PML=XBREAK(IL)-XBREAK(IN) PPL=YBREAK(IN)-YBREAK(IL) PMR=(XBREAK(IN)-XBREAK(IR)) PPR=(YBREAK(IR)-YBREAK(IN)) PX=PXBRAK(IN) PY=PYBRAK(IN) PXL=PX-PXBRAK(IL) PYL=PY-PYBRAK(IL) PTL2=(PXL*PXL+PYL*PYL) AMM=SQRT(PML*PPL-PTL2) PXR=PXBRAK(IR)-PX PYR=PYBRAK(IR)-PY PTR2=(PXR*PXR+PYR*PYR) AMP=SQRT(PMR*PPR-PTR2) CALL UTRESM(ICMPBR(1,IR),ICMPBR(2,IR) * ,ICPMBR(1,IN),ICPMBR(2,IN),AMP,IDPR,IADJP,IRETEN) CALL UTRESM(ICPMBR(1,IL),ICPMBR(2,IL) * ,ICMPBR(1,IN),ICMPBR(2,IN),AMM,IDMR,IADJM,IRETEN) AREA=PPL*PMR P0P=PPL+PPR P0M=PML+PMR TMM2=(PTL2+AMM**2) TMP2=(PTR2+AMP**2) IF(ISH.GE.90)THEN IF ( TMP2 .GT. PPR*PMR+1.E-4 ) THEN CALL UTMSG('JAMBR2') WRITE(IFCH,*)'***** TMP*TMP.GT.PPR*PMR' WRITE(IFCH,*)'TMP*TMP PPR*PMR: ',TMP2,PPR*PMR CALL UTMSGF ENDIF IF ( TMM2. GT. PPL*PML+1.E-4 ) THEN CALL UTMSG('JAMBR2') WRITE(IFCH,*)'***** TMM*TMM.GT.PPL*PML' WRITE(IFCH,*)'TMM*TMM PPL*PML: ',TMM2,PPL*PML CALL UTMSGF ENDIF ENDIF ETA=0.5*LOG(PPL/PMR) C ------ ADJUST P NOT M IF ( IADJP .EQ. 1 .AND. IADJM .NE. 1 ) THEN IF ( ISH .GE. 92 ) WRITE(IFCH,*)'ADJUST P NOT M' ETANEW=LOG((SQRT(AREA)*P0P)/(TMP2+AREA)) IF ( ETANEW .LT. ETA-1.E-4 ) THEN CALL UTMSG('JAMBR2') WRITE(IFCH,*)'***** ETANEW.LT.ETA' WRITE(IFCH,*)'ETANEW ETA: ',ETANEW,ETA CALL UTMSGF ETANEW=ETA ENDIF XBREAK(IN)=SQRT(AREA)*EXP(-ETANEW)+XBREAK(IR) YBREAK(IN)=SQRT(AREA)*EXP(ETANEW)+YBREAK(IL) C ------ ADJUST M NOT P ELSEIF ( IADJM .EQ. 1 .AND. IADJP .NE. 1 ) THEN IF ( ISH .GE. 92 ) WRITE(IFCH,*)'ADJUST M NOT P' ETANEW=-LOG((SQRT(AREA)*P0M)/(TMM2+AREA)) IF ( ETANEW .GT. ETA+1.E-4 ) THEN IF(ISH.GE.90)THEN CALL UTMSG('JAMBR2') WRITE(IFCH,*)'***** ETANEW.GT.ETA' WRITE(IFCH,*)'ETANEW ETA: ',ETANEW,ETA CALL UTMSGF ENDIF ETANEW=ETA ENDIF XBREAK(IN)=SQRT(AREA)*EXP(-ETANEW)+XBREAK(IR) YBREAK(IN)=SQRT(AREA)*EXP(ETANEW)+YBREAK(IL) C ------ ADJUST BOTH ELSEIF ( IADJP .EQ. 1 .AND. IADJM .EQ. 1 ) THEN IF ( ISH .GE. 92 ) WRITE(IFCH,*)'ADJUST BOTH' D=(P0P*P0M-TMP2-TMM2)**2-4*TMP2*TMM2 IF ( D .LT. 0. ) THEN IF(ISH.GE.90)THEN CALL UTMSG('JAMBR2') WRITE(IFCH,*)'***** NEGATIVE D' WRITE(IFCH,*)'D: ',D CALL UTMSGF ENDIF D=0. ENDIF D=SQRT(D) T=P0P*P0M-TMP2+TMM2 P1=(T+D)/(2.*P0M) P2=(T-D)/(2.*P0M) IF ( (P1+P2)*0.5 .GT. PPL ) THEN P=P2 ELSE P=P1 ENDIF XBREAK(IN)=P0M-TMM2/P+XBREAK(IR) YBREAK(IN)=P+YBREAK(IL) ENDIF C ------ IF ( ISH .GE. 92 ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,*)'X/YBREAK:',XBREAK(IN),YBREAK(IN) WRITE(IFCH,*)' ' ENDIF C WRITE SG C -------- NBREAK=NBREAK+1 TAUAVE=TAUAVE+XBREAK(IN)*YBREAK(IN) MM=1 IF ( LAST ) MM=2 DO 9998 M=1,MM NSG=NSG+1 IF ( NSG .GT. MXSG ) THEN CALL UTSTOP('JAMBR2: NSG>MXSG ') ENDIF IF ( ISH .GE. 92 ) WRITE(IFCH,*)'NSG LAST: ',NSG,LAST ISG(NSG)=NPTLC IF ( M .EQ. 2 ) THEN IL=IN IN=IR ENDIF XOR2(1)=0.D0 XOR2(2)=0.D0 XOR2(3)=(YBREAK(IL)-XBREAK(IN))*0.5D0/TENSN XOR2(4)=(YBREAK(IL)+XBREAK(IN))*0.5D0/TENSN IF ( ISH .GE. 92 ) WRITE(IFCH,119)XOR2 119 FORMAT(/' ORIGIN: ',13X,4F7.2/) CALL UTROT2(-1,ROTSG(1,NS),ROTSG(2,NS),ROTSG(3,NS) * ,XOR2(1),XOR2(2),XOR2(3)) CALL UTLOB2(-1,PSG(1,NS),PSG(2,NS),PSG(3,NS),PSG(4,NS),PSG(5,NS) * ,XOR2(1),XOR2(2),XOR2(3),XOR2(4)) XOR2(1)=XOR2(1)+XORSG(1,NS) XORSG(1,NSG)=XOR2(1) XOR2(2)=XOR2(2)+XORSG(2,NS) XORSG(2,NSG)=XOR2(2) XOR2(3)=XOR2(3)+XORSG(3,NS) XORSG(3,NSG)=XOR2(3) XOR2(4)=XOR2(4)+XORSG(4,NS) XORSG(4,NSG)=XOR2(4) C IF ( ISH .GE. 92 ) WRITE(IFCH,117)XOR2 PP=YBREAK(IN)-YBREAK(IL) PM=XBREAK(IL)-XBREAK(IN) PSG(1,NSG)=PXBRAK(IN)-PXBRAK(IL) PSG(2,NSG)=PYBRAK(IN)-PYBRAK(IL) PSG(3,NSG)=(PP-PM)*0.5D0 PSG(4,NSG)=(PP+PM)*0.5D0 SS=PSG(4,NSG)**2-PSG(3,NSG)**2-PSG(2,NSG)**2-PSG(1,NSG)**2 PSG(5,NSG)=SQRT(SS) IF ( ISH .GE. 92 ) WRITE(IFCH,110)NSG,NS,(PSG(J,NSG),J=1,5) 110 FORMAT(1X,I5,I4,16X,1P,5E10.2) PW(1)=PSG(1,NSG) PW(2)=PSG(2,NSG) PW(3)=PSG(3,NSG) PW(4)=PSG(4,NSG) CALL UTROT2(-1,ROTSG(1,NS),ROTSG(2,NS),ROTSG(3,NS) * ,PSG(1,NSG),PSG(2,NSG),PSG(3,NSG)) CALL UTLOB2(-1,PSG(1,NS),PSG(2,NS),PSG(3,NS),PSG(4,NS),PSG(5,NS) * ,PSG(1,NSG),PSG(2,NSG),PSG(3,NSG),PSG(4,NSG)) IORSG(NSG)=NS IF ( ISH .GE. 92 ) THEN WRITE(IFCH,102)NSG,IORSG(NSG),(PSG(J,NSG),J=1,5) 102 FORMAT(1X,I5,I4,16X,1P,5E10.2) WRITE(IFCH,*)' ' ENDIF C WRITE JT C -------- ICJT(1,2*NSG-1)=ICMPBR(1,IN) ICJT(2,2*NSG-1)=ICMPBR(2,IN) DO 41 NF=1,NFLAV CDH ######## JCMS IST NICHT GESETZT!!!! JC(NF,1)=JCMS(NF,1) JC(NF,2)=JCMS(NF,2) 41 CONTINUE ICJT(1,2*NSG)=ICPMBR(1,IL) ICJT(2,2*NSG)=ICPMBR(2,IL) IF ( M .EQ. 2 ) THEN IDX=IADJP ELSE IDX=IADJM ENDIF IF ( IDX .EQ. 0 ) THEN PJT(1,2*NSG-1)=PXBRAK(IN) PJT(2,2*NSG-1)=PYBRAK(IN) PTJR2=PXBRAK(IN)**2+PYBRAK(IN)**2 PTJL2=PXBRAK(IL)**2+PYBRAK(IL)**2 AA=PM*PP-PTJL2-PTJR2 AUXIL=SQRT(AA*AA*0.25-PTJL2*PTJR2) PRM=(AA*0.5+PTJR2-AUXIL)/PP PLP=(AA*0.5+PTJL2-AUXIL)/PM PJT(3,2*NSG-1)=(PP-PLP-PRM)*0.5D0 PJT(4,2*NSG-1)=(PP-PLP+PRM)*0.5D0 PJT(5,2*NSG-1)=0.D0 PJT(1,2*NSG)=-PXBRAK(IL) PJT(2,2*NSG)=-PYBRAK(IL) PJT(3,2*NSG)=(PLP-PM+PRM)*0.5D0 PJT(4,2*NSG)=(PLP+PM-PRM)*0.5D0 PJT(5,2*NSG)=0.D0 IF ( ISH .GE. 92 ) THEN WRITE(IFCH,108)NSG,NS * ,(ICJT(J,2*NSG-1),J=1,2),(SNGL(PJT(J,2*NSG-1)),J=1,5) 108 FORMAT(2X,I3,I4,2X,2I7,5(E10.2)) WRITE(IFCH,108)NSG,NS * ,(ICJT(J,2*NSG ),J=1,2),(SNGL(PJT(J,2*NSG )),J=1,5) ENDIF ERR= (PW(1)-PJT(1,2*NSG-1)-PJT(1,2*NSG))**2 ERR=ERR+(PW(2)-PJT(2,2*NSG-1)-PJT(2,2*NSG))**2 ERR=ERR+(PW(3)-PJT(3,2*NSG-1)-PJT(3,2*NSG))**2 ERR=ERR+(PW(4)-PJT(4,2*NSG-1)-PJT(4,2*NSG))**2 ENDIF ICPZ(1)=ICJT(1,2*NSG-1) ICPZ(2)=ICJT(2,2*NSG-1) ICMZ(1)=ICJT(1,2*NSG) ICMZ(2)=ICJT(2,2*NSG) CALL IDDECO(ICPZ,JCPZ) CALL IDDECO(ICMZ,JCMZ) DO 57 NF=1,NFLAV JCZ(NF,1)=JCPZ(NF,1)+JCMZ(NF,1) JCZ(NF,2)=JCPZ(NF,2)+JCMZ(NF,2) 57 CONTINUE CALL IDENCO(JCZ,ICZ,IRETEN) IDZ=IDTRA(ICZ,0,0,3) AMZ=PSG(5,NSG) CALL IDRES(IDZ,AMZ,IDRZ,IADJ) IF ( IDRZ .EQ. 110 .AND. RANGEN() .LT. 0.5 ) GOTO 9993 9998 CONTINUE 14 CONTINUE IF ( LAST ) GOTO 10 IL=IN IN=IR GOTO 11 10 CONTINUE C C DETERMINE BREAK PNT C ----------------------------------- TAUAVE=TAUAVE/NBREAK XBK(1)=0.D0 XBK(2)=0.D0 AUXIL1=SQRT(TAUAVE*YT/XT) AUXIL2=SQRT(TAUAVE*XT/YT) XBK(3)=(AUXIL1-AUXIL2)*0.5D0/TENSN XBK(4)=(AUXIL1+AUXIL2)*0.5D0/TENSN IF ( ISH .GE. 92 ) WRITE(IFCH,116) XBK 116 FORMAT(' BREAKING PNT: ',13X,4F7.2) CALL UTROT2(-1,ROTSG(1,NS),ROTSG(2,NS),ROTSG(3,NS) * ,XBK(1),XBK(2),XBK(3)) CALL UTLOB2(-1,PSG(1,NS),PSG(2,NS),PSG(3,NS),PSG(4,NS),PSG(5,NS) * ,XBK(1),XBK(2),XBK(3),XBK(4)) XBK(1)=XBK(1)+XORSG(1,NS) XBK(2)=XBK(2)+XORSG(2,NS) XBK(3)=XBK(3)+XORSG(3,NS) XBK(4)=XBK(4)+XORSG(4,NS) IF ( ISH .GE. 92 ) WRITE(IFCH,117)XBK 117 FORMAT(28X,4F7.2/) C XBKPTL(1,NPTLC-NPTL2)=XBK(3) XBKPTL(2,NPTLC-NPTL2)=XBK(4) ISPTL(NPTLC-NPTL2)=1 RETURN END C======================================================================= SUBROUTINE JAMFRA(JS,NEWEVT) C----------------------------------------------------------------------- C FRAGMENTS STRING JS ACCORDING TO A-M MODEL. C VERSION MAR-92 (CALLS JAMBR1 OR JAMBR2) C----------------------------------------------------------------------- PARAMETER (MXPC=500) PARAMETER (MXPTL=70000) PARAMETER (MXSG=500) PARAMETER (MXJT=2*MXSG) PARAMETER (MXSTR=3000) PARAMETER (NFLAV=6) COMMON /ACCUM/ AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT * ,NRPTL,NRSTR,NTEVT COMMON /CDELRE/ DELRER COMMON /CEVT/ BIMEVT,COLEVT,EGYEVT,PHIEVT,PMXEVT * ,KOLEVT,NEVT,NPJEVT,NTGEVT COMMON /CJAMBR/ NPTLC,NPTL2 COMMON /CNSTA/ AINFIN,PI,PIOM,PROM DOUBLE PRECISION XBKPTL COMMON /CPC/ XBKPTL(2,MXPC),ISPTL(MXPC) COMMON /CPTL/ PPTL(5,MXPTL),TIVPTL(2,MXPTL),XORPTL(4,MXPTL) * ,IBPTL(4,MXPTL),ICLPTL(MXPTL),IDPTL(MXPTL) * ,IFRPTL(2,MXPTL),IORPTL(MXPTL),ISTPTL(MXPTL) * ,JORPTL(MXPTL),NPTL,NQJPTL(MXPTL) DOUBLE PRECISION PJT,PSG,ROTSG,XORSG COMMON /CSG/ PJT(5,MXJT),PSG(5,MXSG),ROTSG(3,MXSG) * ,XORSG(4,MXSG) * ,ICJT(2,MXJT),IORSG(MXSG),ISG(MXSG) COMMON /CSTR/ PSTR(5,MXSTR),ROTSTR(3,MXSTR),XORSTR(4,MXSTR) * ,ICSTR(4,MXSTR),IORSTR(MXSTR),IRLSTR(MXSTR),NSTR COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT DOUBLE PRECISION ARM(4),ARP(4),TOR,ZOR INTEGER IC(2),ICJ1(2),ICJ2(2) * ,ICM(2),ICP(2),ICUM(2),ICUP(2) * ,JC(NFLAV,2) ,JCJ1(NFLAV,2),JCJ2(NFLAV,2) * ,JCM(NFLAV,2),JCP(NFLAV,2) SAVE C----------------------------------------------------------------------- DELREC=0.600 DELREX=0.050 NEWEVT=0 PSG(1,1)=PSTR(1,JS) PSG(2,1)=PSTR(2,JS) PSG(3,1)=PSTR(3,JS) PSG(4,1)=PSTR(4,JS) PSG(5,1)=PSTR(5,JS) ROTSG(1,1)=ROTSTR(1,JS) ROTSG(2,1)=ROTSTR(2,JS) ROTSG(3,1)=ROTSTR(3,JS) XORSG(1,1)=XORSTR(1,JS) XORSG(2,1)=XORSTR(2,JS) XORSG(3,1)=XORSTR(3,JS) XORSG(4,1)=XORSTR(4,JS) SQRTS=ABS(PSTR(5,JS)) S=PSTR(5,JS)**2 ISG(1)=IORSTR(JS) IORSG(1)=0 PJT(1,1)=0.D0 PJT(1,2)=0.D0 PJT(2,1)=0.D0 PJT(2,2)=0.D0 PJT(3,1)=SQRTS*0.5D0 PJT(3,2)=-SQRTS*0.5D0 PJT(4,1)=SQRTS*0.5D0 PJT(4,2)=SQRTS*0.5D0 PJT(5,1)=0.D0 PJT(5,2)=0.D0 IF ( ROTSTR(3,JS) .LT. 0. ) THEN ICJT(1,1)=ICSTR(3,JS) ICJT(2,1)=ICSTR(4,JS) ICJT(1,2)=ICSTR(1,JS) ICJT(2,2)=ICSTR(2,JS) ELSE ICJT(1,1)=ICSTR(1,JS) ICJT(2,1)=ICSTR(2,JS) ICJT(1,2)=ICSTR(3,JS) ICJT(2,2)=ICSTR(4,JS) ENDIF ICJ1(1)=ICJT(1,1) ICJ1(2)=ICJT(2,1) ICJ2(1)=ICJT(1,2) ICJ2(2)=ICJT(2,2) CALL IDDECO(ICJ1,JCJ1) CALL IDDECO(ICJ2,JCJ2) NQJ1=0 NQJ2=0 DO 4 NF=1,NFLAV NQJ1=NQJ1+JCJ1(NF,1)-JCJ1(NF,2) NQJ2=NQJ2+JCJ2(NF,1)-JCJ2(NF,2) 4 CONTINUE IF ( NQJ1 .GE. 0 ) THEN IF ( NQJ2 .GE. 0 ) THEN ISI = 0 ELSE ISI = 1 ENDIF ELSE IF ( NQJ2 .GE. 0 ) THEN ISI = 2 ELSE ISI = 3 ENDIF ENDIF NQJSTR=ISI*1000000+ABS(NQJ1)*1000+ABS(NQJ2) C ENTRY STRING FRAGMENTATION C -------------------------- NPTL2=NPTL NCNT2=0 9996 NCNT2=NCNT2+1 NPTL=NPTL2 NSG=1 IF ( NCNT2 .GT. 1000 ) GOTO 1001 C ENTRY SUBSTRING PROCESSING C -------------------------- NS=0 9999 NS=NS+1 IF ( NS .GT. NSG ) GOTO 9997 IF ( ISH .GE. 92 ) THEN WRITE(IFCH,*)'ENTRY SUBSTRING PROCESSING' WRITE(IFCH,*)' ' WRITE(IFCH,107)NS * ,(ICJT(J,2*NS-1 ),J=1,2),(SNGL(PJT(J,2*NS-1 )),J=1,5) 107 FORMAT(2X,I3,3X,3X,2I7,5(E10.2)) WRITE(IFCH,107)NS * ,(ICJT(J,2*NS ),J=1,2),(SNGL(PJT(J,2*NS )),J=1,5) WRITE(IFCH,101)NS,(PSG(J,NS),J=1,5) 101 FORMAT(2X,I3,23X,5(E10.2)/) 114 FORMAT(' LEFT BREAKING PNT: ',8X,4F7.2/) ENDIF C DETERMINE ID AND MIN.MASS C ------------------------- DELRER=DELREX+RANGEN()*(DELREM-DELREX) ICP(1)=ICJT(1,2*NS-1) ICP(2)=ICJT(2,2*NS-1) ICM(1)=ICJT(1,2*NS) ICM(2)=ICJT(2,2*NS) CALL IDCOMK(ICP) CALL IDCOMK(ICM) ICJT(1,2*NS-1)=ICP(1) ICJT(2,2*NS-1)=ICP(2) ICJT(1,2*NS)=ICM(1) ICJT(2,2*NS)=ICM(2) CALL IDDECO(ICP,JCP) CALL IDDECO(ICM,JCM) AMMS=UTAMNX(JCM,JCP) NUBAR=0 DO 7 NF=1,NFLAV JC(NF,1)=JCP(NF,1)+JCM(NF,1) JC(NF,2)=JCP(NF,2)+JCM(NF,2) IF ( NF .GT. 4 .AND. (JC(NF,1).NE.0 .OR. JC(NF,2).NE.0) ) THEN CALL UTSTOP('JAMFRA: FLAVOUR > 4 ') ENDIF NUBAR=NUBAR+JC(NF,1)-JC(NF,2) 7 CONTINUE IF ( NS .EQ. 1 ) NUMBAR=NUBAR CALL IDENCO(JC,IC,IRETEN) CALL IDCOMK(IC) ID=IDTRA(IC,0,0,3) IDK=ID AM=PSG(5,NS) IREMN=0 IF ( ICP(1)+ICP(2) .EQ. 0 .OR. ICM(1)+ICM(2) .EQ. 0 ) IREMN=1 IF ( AM .GT. AMMS+DELRER .AND. IREMN .EQ. 0 ) ID=0 C MASS ADJUSTMENT => FRAGMENT AGAIN C --------------------------------- AMC=PSG(5,NS) CALL IDRES(ID,AMC,IDR,IADJ) IF ( ABS(AMC-PSG(5,NS)) .GT. 1.E-3 ) THEN IF ( ISH .GE. 90 ) THEN CALL UTMSG('JAMFRA') WRITE(IFCH,*)'***** MASS CHANGED. FRAGMENT AGAIN.' WRITE(IFCH,*)'MASS BEFORE, AFTER: ',PSG(5,NS),AMC WRITE(IFCH,*)'IC,ID,IDR: ',IC,ID,IDR CALL UTMSGF ENDIF GOTO 9996 ENDIF C IF MASS < MIN.MASS ==> AGAIN C ---------------------------- C-C IF ( IDR.EQ.0.AND.AM.LT.AMMS-1.E-3 ) THEN C-C IF ( ISH .GE. 90 ) THEN C-C CALL UTMSG('JAMFRA') C-C WRITE(IFCH,*)'***** MASS < MIN MASS. ',AM,AMMS C-C WRITE(IFCH,*)'IDK,ID,IDR,PSG(5,NS):' C-C WRITE(IFCH,*)IDK,ID,IDR,PSG(5,NS) C-C WRITE(IFCH,*)'P_JET:' C-C WRITE(IFCH,107)NS C-C * ,(ICJT(J,2*NS-1 ),J=1,2),(SNGL(PJT(J,2*NS-1 )),J=1,5) C-C WRITE(IFCH,107)NS C-C * ,(ICJT(J,2*NS ),J=1,2),(SNGL(PJT(J,2*NS )),J=1,5) C-C WRITE(IFCH,*)'P_STR:' C-C WRITE(IFCH,101)NS,(PSG(J,NS),J=1,5) C-C CALL UTMSGF C-C ENDIF C-C IF ( NS .EQ. 1 ) GOTO 1001 C-C GOTO 9996 C-C ENDIF C WRITE ON /CPTL/ (1) C ------------------- IORI=ISG(NS) NPTLB=NPTL 9995 NPTL=NPTL+1 NPTLC=NPTL IF ( NPTL .GT. MXPTL ) THEN CALL UTSTOP('JAMFRA: NPTL>MXPTL ') ENDIF IF ( NPTL-NPTL2 .GT. MXPC ) THEN CALL UTSTOP('JAMFRA: NPTL-NPTL2>MXPC ') ENDIF PPTL(1,NPTL)=PSG(1,NS) PPTL(2,NPTL)=PSG(2,NS) PPTL(3,NPTL)=PSG(3,NS) PPTL(4,NPTL)=PSG(4,NS) PPTL(5,NPTL)=PSG(5,NS) XORPTL(1,NPTL)=XORSG(1,NS) XORPTL(2,NPTL)=XORSG(2,NS) XORPTL(3,NPTL)=XORSG(3,NS) XORPTL(4,NPTL)=XORSG(4,NS) XBKPTL(1,NPTL-NPTL2)=AINFIN XBKPTL(2,NPTL-NPTL2)=AINFIN TIVPTL(1,NPTL)=-AINFIN TIVPTL(2,NPTL)=AINFIN IFRPTL(1,NPTL)=0 IFRPTL(2,NPTL)=0 ICLPTL(NPTL)=0 ISPTL(NPTL-NPTL2)=0 IORPTL(NPTL)=IORI JORPTL(NPTL)=0 IF ( NPTL .GT. NPTL2+1 ) THEN NQJPTL(NPTL)=-NQJSTR ELSEIF ( NPTL .EQ. NPTL2+1 ) THEN NQJPTL(NPTL)= NQJSTR ENDIF IDPTL(NPTL)=IDR IF ( IDR .EQ. 0 ) THEN IF ( IC(1) .EQ. 0 .AND. IC(2) .EQ. 0 ) THEN IDPTL(NPTL)=700000000 CALL IDTRBI(JC,IBPTL(1,NPTL),IBPTL(2,NPTL) * ,IBPTL(3,NPTL),IBPTL(4,NPTL)) ELSE IB5=JC(5,1)*10000+JC(5,2) IB6=JC(6,1)*10000+JC(6,2) IF ( IB5 .NE. 0 .OR. IB6 .NE. 0 ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,*)'***** ERROR IN JAMFRA: BOTTOM OR TOP QUARKS' WRITE(IFCH,*)'JC:' WRITE(IFCH,*)JC CALL UTSTOP('JAMFRA: BOTTOM OR TOP QUARKS ') ENDIF IDPTL(NPTL)=800000000+IC(1)*100+IC(2)/100 ENDIF ENDIF IF ( ISH .GE. 91 ) THEN WRITE(IFCH,115)NPTL,IORPTL(NPTL),IDPTL(NPTL) * ,(PPTL(J,NPTL),J=1,5) 115 FORMAT(1X,'/CPTL/',I6,I7,I10,5(E10.2)) IF ( IDPTL(NPTL) .EQ. 700000000 ) * WRITE(IFCH,*)(IBPTL(I,NPTL),I=1,4) IF ( ISH .GE. 92 ) WRITE(IFCH,*)' ' ENDIF IF ( IDR .NE. 0 ) GOTO 9999 NQP=0 NQM=0 NAP=0 NAM=0 DO 23 NF=1,NFLAV NQP=NQP+JCP(NF,1) NQM=NQM+JCM(NF,1) NAP=NAP+JCP(NF,2) NAM=NAM+JCM(NF,2) 23 CONTINUE NP=NQP-NAP NM=NQM-NAM JP=NQP+NAP JM=NQM+NAM C QUARK-CLUSTER C ------------- IF ( ICP(1)+ICP(2) .EQ. 0 .OR. ICM(1)+ICM(2) .EQ. 0 ) GOTO 78 IF ( AM .GT. AMMS+DELRER ) GOTO 77 IF ( IDK .EQ. 0 .AND. AM .GT. AMMS+DELREC ) GOTO 77 IF ( IDK .NE. 0 .AND. AM .GT. AMMS+DELREX ) GOTO 77 78 CONTINUE IF ( ISH .GE. 92 ) THEN WRITE(IFCH,*)'QUARK-CLUSTER' WRITE(IFCH,*)' ' ENDIF IF ( ICP(1)+ICP(2) .EQ. 0 .AND. ICM(1)+ICM(2) .EQ. 0 ) THEN CALL UTSTOP('JAMFRA: ZERO STRING. ') ENDIF GOTO 9999 77 CONTINUE C JET TRAFOS C ---------- IF ( ISH .GE. 92 ) THEN WRITE(IFCH,*)'JET TRAFOS' WRITE(IFCH,*)' ' ENDIF ARP(1)=PJT(1,2*NS-1) ARP(2)=PJT(2,2*NS-1) ARP(3)=PJT(3,2*NS-1) ARP(4)=PJT(4,2*NS-1) ARM(1)=PJT(1,2*NS) ARM(2)=PJT(2,2*NS) ARM(3)=PJT(3,2*NS) ARM(4)=PJT(4,2*NS) IF ( ISH .GE. 90 ) CALL UTCHM(ARP,ARM,1) NSO=IORSG(NS) IF ( NSO .GT. 0 ) THEN CALL UTROT2(-1,ROTSG(1,NSO),ROTSG(2,NSO),ROTSG(3,NSO) * ,ARP(1),ARP(2),ARP(3)) CALL UTLOB2(-1,PSG(1,NSO),PSG(2,NSO),PSG(3,NSO),PSG(4,NSO) * ,PSG(5,NSO),ARP(1),ARP(2),ARP(3),ARP(4)) CALL UTROT2(-1,ROTSG(1,NSO),ROTSG(2,NSO),ROTSG(3,NSO) * ,ARM(1),ARM(2),ARM(3)) CALL UTLOB2(-1,PSG(1,NSO),PSG(2,NSO),PSG(3,NSO),PSG(4,NSO) * ,PSG(5,NSO),ARM(1),ARM(2),ARM(3),ARM(4)) IF ( ISH .GE. 90 ) CALL UTCHM(ARP,ARM,2) CALL UTLOB2(1,PSG(1,NS),PSG(2,NS),PSG(3,NS),PSG(4,NS),PSG(5,NS) * ,ARP(1),ARP(2),ARP(3),ARP(4)) CALL UTLOB2(1,PSG(1,NS),PSG(2,NS),PSG(3,NS),PSG(4,NS),PSG(5,NS) * ,ARM(1),ARM(2),ARM(3),ARM(4)) IF ( ISH .GE. 90 ) CALL UTCHM(ARP,ARM,3) ROTSG(1,NS)=(ARP(1)-ARM(1))*0.5D0 ROTSG(2,NS)=(ARP(2)-ARM(2))*0.5D0 ROTSG(3,NS)=(ARP(3)-ARM(3))*0.5D0 CALL UTROT2(1,ROTSG(1,NS),ROTSG(2,NS),ROTSG(3,NS) * ,ARP(1),ARP(2),ARP(3)) CALL UTROT2(1,ROTSG(1,NS),ROTSG(2,NS),ROTSG(3,NS) * ,ARM(1),ARM(2),ARM(3)) ENDIF ICUP(1)=ICJT(1,2*NS-1) ICUP(2)=ICJT(2,2*NS-1) ICUM(1)=ICJT(1,2*NS) ICUM(2)=ICJT(2,2*NS) IF ( ARP(3) .LT. 0.D0 ) THEN ICJT(1,2*NS-1)=ICUM(1) ICJT(2,2*NS-1)=ICUM(2) PJT(1,2*NS-1)=ARM(1) PJT(2,2*NS-1)=ARM(2) PJT(3,2*NS-1)=ARM(3) PJT(4,2*NS-1)=ARM(4) ICJT(1,2*NS)=ICUP(1) ICJT(2,2*NS)=ICUP(2) PJT(1,2*NS)=ARP(1) PJT(2,2*NS)=ARP(2) PJT(3,2*NS)=ARP(3) PJT(4,2*NS)=ARP(4) ELSE ICJT(1,2*NS-1)=ICUP(1) ICJT(2,2*NS-1)=ICUP(2) PJT(1,2*NS-1)=ARP(1) PJT(2,2*NS-1)=ARP(2) PJT(3,2*NS-1)=ARP(3) PJT(4,2*NS-1)=ARP(4) ICJT(1,2*NS)=ICUM(1) ICJT(2,2*NS)=ICUM(2) PJT(1,2*NS)=ARM(1) PJT(2,2*NS)=ARM(2) PJT(3,2*NS)=ARM(3) PJT(4,2*NS)=ARM(4) ENDIF S=PSG(5,NS)**2 IF ( ISH .GE. 90 ) THEN AUXIL=100.*ABS( SNGL(PJT(3,2*NS-1)-PJT(3,2*NS))-ABS(PSG(5,NS)) ) IF ( AUXIL .GT. 1. .AND. AUXIL .GT. ABS(PSG(5,NS)) ) THEN CALL UTMSG('JAMFRA') WRITE(IFCH,*)'***** PZ1-PZ2-SQRT(S) NONZERO' WRITE(IFCH,*)'VALUE: ' * ,SNGL(PJT(3,2*NS-1)-PJT(3,2*NS))-SQRT(S) WRITE(IFCH,*)'SQRT(S): ',SQRT(S) WRITE(IFCH,*)(SNGL(PJT(I,2*NS-1)),I=1,4) WRITE(IFCH,*)(SNGL(PJT(I,2*NS)),I=1,4) CALL UTMSGF ENDIF IF ( ISH .GE. 92 ) THEN WRITE(IFCH,103)NS,NSO * ,(ICJT(J,2*NS-1 ),J=1,2),(SNGL(PJT(J,2*NS-1 )),J=1,5) 103 FORMAT(2X,I3,I3,3X,2I7,5(E10.2)) WRITE(IFCH,104) * (ICJT(J,2*NS ),J=1,2),(SNGL(PJT(J,2*NS )),J=1,5) 104 FORMAT(2X,9X,2I7,5(E10.2)/) ENDIF ENDIF IF ( IOPBRK .EQ. 1 ) THEN CALL JAMBR1(NS,NSG,IRET) ELSEIF ( IOPBRK .EQ. 2 ) THEN CALL JAMBR2(NS,NSG,IRET) ENDIF IF ( IRET .EQ. 9996 ) GOTO 9996 GOTO 9999 C WRITE ON /CPTL/ (2) C ------------------- 9997 CONTINUE IF ( NPTL .LE. NPTL2 ) THEN CALL UTSTOP('JAMFRA: NPTL<=NPTL2 ') ENDIF IF ( ISH .GE. 91 ) WRITE(IFCH,*)' ' DO 67 I=NPTL2+1,NPTL ISTPTL(I)=ISPTL(I-NPTL2) IO=IORPTL(I) IF ( IO .GT. 0 ) THEN IF ( IFRPTL(1,IO) .EQ. 0 ) IFRPTL(1,IO)=I IFRPTL(2,IO)=I ELSE IORPTL(I)=0 ENDIF ZOR=XORSG(3,1) TOR=XORSG(4,1) R=RANGEN() TAURAN=-TAUREA*LOG(R) CALL UTTAIX(I,TAURAN,ZOR,TOR,ZIS,TIS) TIVPTL(1,I)=MAX(TIS,XORPTL(4,I)) IF ( ISTPTL(I) .NE. 0 ) THEN TAUBR=SQRT * ((XBKPTL(2,I-NPTL2)-TOR)**2-(XBKPTL(1,I-NPTL2)-ZOR)**2) CALL UTTAIX(I,TAUBR,ZOR,TOR,ZIS,TIS) TIVPTL(2,I)=TIS ELSEIF ( IO .GT. 0 ) THEN TAUBR=SQRT * ((XBKPTL(2,IO-NPTL2)-TOR)**2-(XBKPTL(1,IO-NPTL2)-ZOR)**2) CALL UTTAIX(I,TAUBR,XORSG(3,1),XORSG(4,1),ZISBR,TISBR) CALL IDTAU(IDPTL(I),PPTL(4,I),PPTL(5,I),TAUGM) TIVPTL(2,I)=TISBR+TAUGM ELSE CALL IDTAU(IDPTL(I),PPTL(4,I),PPTL(5,I),TAUGM) TIVPTL(2,I)=XORPTL(4,I)+TAUGM ENDIF IF ( ISH .GE. 92 ) WRITE(IFCH,120)I,IORPTL(I),IDPTL(I) * ,(SNGL(XBKPTL(J,I-NPTL2)),J=1,2) * ,(XORPTL(J,I),J=3,4),(TIVPTL(J,I),J=1,2) 120 FORMAT(1X,'/CPTL/',I6,I7,I10 * ,E10.2,E10.2,E10.2,E10.2,E10.2,E10.2) 67 CONTINUE 1000 RETURN 1001 NEWEVT=1 GOTO 1000 END C======================================================================= SUBROUTINE JCENTD C---------------------------------------------------------------------- PARAMETER (KPARX=15) PARAMETER (NQUAX=12) COMMON /CENTRO/ ENTRO(1+KPARX,1+NQUAX) REAL ENTROX(1+KPARX,1+NQUAX) DATA (ENTROX( 1,1+N),N=0,12)/ *.00000E+00,.00000E+00,.00000E+00,.00000E+00,.00000E+00,.00000E+00, *.00000E+00,.00000E+00,.00000E+00,.00000E+00,.00000E+00,.00000E+00, *.00000E+00/ DATA (ENTROX( 4,1+N),N=0,12)/ *.40254E+01,.59349E+01,.74855E+01,.87464E+01,.98267E+01,.10770E+02, *.11611E+02,.12368E+02,.13058E+02,.13691E+02,.14277E+02,.14822E+02, *.15332E+02/ DATA (ENTROX( 7,1+N),N=0,12)/ *.61944E+01,.89306E+01,.11114E+02,.12969E+02,.14595E+02,.16054E+02, *.17380E+02,.18599E+02,.19728E+02,.20780E+02,.21767E+02,.22696E+02, *.23574E+02/ DATA (ENTROX(10,1+N),N=0,12)/ *.68876E+01,.10183E+02,.12855E+02,.15159E+02,.17201E+02,.19046E+02, *.20734E+02,.22296E+02,.23751E+02,.25115E+02,.26400E+02,.27616E+02, *.28771E+02/ DATA (ENTROX(13,1+N),N=0,12)/ *.61944E+01,.99602E+01,.13068E+02,.15784E+02,.18208E+02,.20406E+02, *.22425E+02,.24295E+02,.26041E+02,.27681E+02,.29228E+02,.30696E+02, *.32092E+02/ DATA (ENTROX(16,1+N),N=0,12)/ *.40254E+01,.82375E+01,.11781E+02,.14923E+02,.17745E+02,.20311E+02, *.22669E+02,.24853E+02,.26890E+02,.28803E+02,.30609E+02,.32320E+02, *.33948E+02/ SAVE C---------------------------------------------------------------------- KPH=KPARX NQH=NQUAX DO 2 N=1,1+NQUAX DO 1 K=1,1+KPARX ENTRO(K,N)=ENTROX(K,N) 1 CONTINUE 2 CONTINUE IF ( KPH .NE. 15 ) THEN CALL UTSTOP('ICENTD: INSUFFICIENT INITIALIZATION; K') ENDIF IF ( NQH .NE. 12 ) THEN CALL UTSTOP('ICENTD: INSUFFICIENT INITIALIZATION; N') ENDIF RETURN END C======================================================================= SUBROUTINE JCENTP C---------------------------------------------------------------------- C PLOTS ENTRO(,) AND FTN SJCENT C---------------------------------------------------------------------- PARAMETER (KPARX=15) PARAMETER (NQUAX=12) COMMON /CENTRO/ ENTRO(1+KPARX,1+NQUAX) COMMON /CJCENT/ IGX,NSYMX COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT REAL XPLOT(101),YPLOT(101) INTEGER IPLOT(5) CHARACTER TEXT*50 DATA IPLOT/0,0,0,1,1/ SAVE C---------------------------------------------------------------------- ISH0=ISH IF ( ISHSUB/100 .EQ. 13 ) ISH=MOD(ISHSUB,100) IF ( ISH .LT. 95 ) GOTO 1000 IF ( IPLOT(1) .EQ. 1 ) THEN TEXT='TITLE IG= NSYM= K= 3,6,9,12,15$ ' WRITE(TEXT(10:11),122)IGX WRITE(TEXT(20:21),122)NSYMX 122 FORMAT(I2) DO 54 KX=1,5 K=3*KX DO 55 N=1,13 XPLOT(N)=N-1 YPLOT(N)=ENTRO(1+K,N) 55 CONTINUE CALL UTHIST(0.,12.,0.,40.,1+12,XPLOT,YPLOT,'LIN','LINLIN' * ,'XAXIS ENERGY / OMEGA $ ' * ,'YAXIS ENTROPY $ ',TEXT) 54 CONTINUE ENDIF IF ( IPLOT(2) .EQ. 1 ) THEN TEXT='TITLE IG= NSYM= K= 3,6,9,12,15$ ' WRITE(TEXT(10:11),122)IGX WRITE(TEXT(20:21),122)NSYMX DO 64 KX=1,5 K=3*KX DO 65 N=1,13 XPLOT(N)=(N-1.)/FLOAT(K) YPLOT(N)=ENTRO(1+K,N)/K 65 CONTINUE CALL UTHIST(0.,5.,0.,6.,1+12,XPLOT,YPLOT,'LIN','LINLIN' * ,'XAXIS ENERGY / OMEGA / PARTICLE $ ' * ,'YAXIS ENTROPY / PARTICLE $ ',TEXT) 64 CONTINUE ENDIF IF ( IPLOT(3) .EQ. 1 ) THEN DO 62 KX=1,10 K=3*KX DO 63 N=0,100 X=N*0.05 XPLOT(1+N)=X YPLOT(1+N)=SJCENT(K,K,K*X)/K 63 CONTINUE CALL UTHIST(0.,5.,0.,6.,101,XPLOT,YPLOT,'LIN','LINLIN' * ,'XAXIS ENERGY / OMEGA / PARTICLE $ ' * ,'YAXIS ENTROPY / PARTICLE $ ' * ,'TITLE INTER(EXTRA)POLATED $ ') 62 CONTINUE ENDIF IF ( IPLOT(4) .EQ. 1 ) THEN DO 58 KX=1,10 K=3*KX DO 59 N=0,100 X=N*0.5 XPLOT(1+N)=X YPLOT(1+N)=SJCENT(K,K,X) 59 CONTINUE CALL UTHIST(0.,50.,0.,80.,101,XPLOT,YPLOT,'LIN','LINLIN' * ,'XAXIS ENERGY / OMEGA $ ' * ,'YAXIS ENTROPY $ ' * ,'TITLE INTER(EXTRA)POLATED KU=K $ ') 58 CONTINUE ENDIF IF ( IPLOT(5) .EQ. 1 ) THEN DO 48 KX=1,10 K=3*KX DO 49 N=0,100 X=N*0.5 XPLOT(1+N)=X YPLOT(1+N)=SJCENT(K,0,X) 49 CONTINUE CALL UTHIST(0.,50.,0.,80.,101,XPLOT,YPLOT,'LIN','LINLIN' * ,'XAXIS ENERGY / OMEGA $ ' * ,'YAXIS ENTROPY $ ' * ,'TITLE INTER(EXTRA)POLATED KU=0 $ ') 48 CONTINUE ENDIF 1000 CONTINUE ISH=ISH0 RETURN END C======================================================================= SUBROUTINE JCENTR(NSYM,IG,IDI,INIT) C---------------------------------------------------------------------- C FILLS ARRAY DEGEN(1+K,1+N) CONTAINING C THE NUMBER OF MIXED SYMMETRIC (BOX OF WIDTH NSYM) C K-PARTICLE STATES WITH ENERGY N (UNITS OF OMEGA), BASED ON C OSCILLATOR (DIM: IDI) WAVEFUNCTIONS (ADDIT. DEGENERACY: IG) . C FILLS ARRAY ENTRO(1+K,1+N) = LOG( DEGEN(1+K,1+N) ) . C ENTRO(,) WRITTEN IN FORM OF DATA FOR JCENTD IF ISH=95 C (ISHSUB=12.. SELECTS THIS). C INIT MUST BE SET 1 FOR THE FIRST CALL OF JCENTR C (INIT=1 CALLS UTTUCL, UTPART, UTOVEL) C---------------------------------------------------------------------- PARAMETER (IOVMAX=100) PARAMETER (ITAMAX=1000) PARAMETER (JOVMAX=100) PARAMETER (KPARX=15) PARAMETER (KTUMAX=100) PARAMETER (NQUAX=12) PARAMETER (JPAMAX=NQUAX*NQUAX*NQUAX) PARAMETER (KKPMAX=NQUAX*NQUAX*2) PARAMETER (NSYMAX=20) PARAMETER (NTUMAX=100) PARAMETER (NYMAX=1000) COMMON /CDEGEN/ DEGEN(1+KPARX,1+NQUAX) COMMON /CENTRO/ ENTRO(1+KPARX,1+NQUAX) COMMON /CJCENT/ IGX,NSYMX COMMON /COVEL/ OVEL(1+IOVMAX,1+JOVMAX) COMMON /CPARTA/ PARTA(NQUAX),IPART(NQUAX,JPAMAX) DOUBLE PRECISION TUCL COMMON /CTUCL/ TUCL(1+KTUMAX,1+NTUMAX) COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT REAL YOFA(ITAMAX) INTEGER IYO(NYMAX,KPARX),IYOL(ITAMAX),IYOM(ITAMAX),IYOO(ITAMAX) * ,IYOR(NSYMAX),IYOX(KPARX),IYOZ(ITAMAX,NSYMAX,2) * ,JYO(NYMAX),KKK(KPARX) CHARACTER CIGA*7 CHARACTER*1 CYOX(1+NQUAX,KPARX),DELI(1+KPARX,1+NQUAX) SAVE C---------------------------------------------------------------------- IF ( INIT .EQ. 1 ) THEN CALL UTTUCL CALL UTPART CALL UTOVEL ENDIF WRITE(IFMT,*)'EXECUTE SR JCENTR ...' IF ( NSYM .GE. NSYMAX ) THEN CALL UTSTOP('JCENTR: DIMENSION NSYMAX TOO SMALL ') ENDIF IF ( MOD(KPARX,NSYM) .NE. 0 ) THEN CALL UTSTOP('JCENTR: KPARX SHOULD BE MULTIPLE OF NSYM') ENDIF MMAX=1+(KPARX-1)/NSYM IZERO=0 NSYMX=NSYM IGX=IG C LOOP OVER ENERGY C ---------------- DO 6000 N=0,NQUAX WRITE(IFMT,*)'SR JCENTR: N=',N IF ( N .EQ. 0 ) THEN KKP=1 ELSE KKP=-IPART(N,1) IF ( KKP .GT. KKPMAX ) THEN CALL UTSTOP('JCENTR: DIMENSION KKPMAX TOO SMALL ') ENDIF IF ( -IPART(N,1) .NE. NINT(PARTA(N)) ) THEN CALL UTSTOP('JCENTR: # OF PARTITIONS DISAGREE ') ENDIF ENDIF IF ( ISH .GE. 93 ) THEN WRITE(IFCH,103)('-',IC=1,79),N,KKP,('-',IC=1,79) 103 FORMAT(/1X,79A1/7X,'N = ',I2, * ' ---> ',I4,' PARTITION(S)'/1X,79A1/) JJ=2 DO 8 KK=1,KKP IF ( N .EQ. 0 ) THEN WRITE(IFCH,102)KK,IZERO ELSEIF ( N .GT. 0 ) THEN LL=-IPART(N,JJ) WRITE(IFCH,102)KK,(IPART(N,I),I=JJ+1,JJ+MIN(20,LL)) 102 FORMAT(2X,I2,'. PARTITION:',3X,20I3) ENDIF JJ=JJ+LL+1 8 CONTINUE ENDIF C ZERO PARTICLES C -------------- DEGEN(1,1+N)=1. ENTRO(1,1+N)=0. IF ( N .EQ. NQUAX ) THEN DELI(1,1+N)='/' ELSE DELI(1,1+N)=',' ENDIF C LOOP OVER PARTICLE NUMBER C ------------------------- DO 6001 KX=1,KPARX/3 K=3*KX IF ( K .GT. KPARX ) THEN CALL UTSTOP('JCENTR: DIMENSION KPARX TOO SMALL ') ENDIF DEGEN(1+K,1+N)=0. IF ( N .EQ. NQUAX ) THEN DELI(1+K,1+N)='/' ELSE DELI(1+K,1+N)=',' ENDIF KKK(K)=KKP MMAXK=1+(K-1)/NSYM IF ( K .LT. KPARX ) THEN DO 5 L=K+1,KPARX DO 5 NY=1,NYMAX IYO(NY,L)=-1 5 CONTINUE ENDIF IF ( ISH.GE.93 ) WRITE(IFCH,100)('-',IC=1,11),K,('-',IC=1,11) 100 FORMAT(/1X,11A1/3X,'K = ',I2/1X,11A1/) C LOOP OVER PARTITIONS C -------------------- JJ=2 DO 6002 KK=1,KKP IF ( N .GT. 0 ) THEN LL=-IPART(N,JJ) ELSEIF ( N .EQ. 0 ) THEN LL=1 ENDIF IF ( LL .GT. K ) THEN KKK(K)=KK-1 GOTO 6003 ENDIF IF ( ISH .GE. 93 ) THEN IF ( N .EQ. 0 ) THEN WRITE(IFCH,102)KK,IZERO ELSEIF ( N .GT. 0 ) THEN WRITE(IFCH,102)KK,(IPART(N,I),I=JJ+1,JJ+MIN(20,LL)) ENDIF WRITE(IFCH,*)' ' ENDIF C CONSTRUCT YOUNG TABLEAUS C ------------------------ NY1=1 NY2=1 JYO(NY1)=1 DO 46 L=1,K IYO(NY1,L)=0 46 CONTINUE IF ( N .GT. 0 ) THEN IYO(NY1,K)=IPART(N,JJ+1) NY1=NY1-1 45 NY1=NY1+1 IF ( JYO(NY1) .EQ. LL ) GOTO 51 DO 43 LX=1,NSYM L=NSYM+1-LX DO 44 MX=1,MMAXK M=MMAXK+1-MX IF ( IYO(NY1,(M-1)*NSYM+L) .EQ. 0 ) THEN IF ( L.EQ.NSYM .OR. (L.NE.NSYM.AND. * IYO(NY1,(M-1)*NSYM+L+1).NE.0) ) THEN NY2=NY2+1 IF ( NY2 .GT. NYMAX ) THEN CALL UTSTOP * ('JCENTR: DIMENSION NYMAX TOO SMALL ') ENDIF JY=JYO(NY1)+1 JYO(NY2)=JY DO 50 LP=1,K IYO(NY2,LP)=IYO(NY1,LP) 50 CONTINUE IYO(NY2,(M-1)*NSYM+L)=IPART(N,JJ+JY) IF ( NY2 .GT. 1 ) THEN DO 47 NY3=1,NY2-1 IF ( JYO(NY3) .NE. JYO(NY2) ) GOTO 47 DO 48 LP=1,K IF ( IYO(NY3,LP) .NE. IYO(NY2,LP) ) GOTO 47 48 CONTINUE NY2=NY2-1 GOTO 49 47 CONTINUE 49 CONTINUE ENDIF ENDIF GOTO 43 ENDIF 44 CONTINUE 43 CONTINUE GOTO 45 51 CONTINUE ENDIF C LOOP OVER YOUNG TABLEAUS C ------------------------ DO 6005 NY=NY1,NY2 IF ( ISH .GE. 93 .AND. NSYM .EQ. 3 ) THEN WRITE(IFCH,117)NY-NY1+1,((IYO(NY,(M-1)*NSYM+I), * I=1,NSYM),M=1,1) 117 FORMAT(2X,I2,'. TABLEAU:',5X,3I2) IF ( MMAXK .GT. 1 ) WRITE(IFCH,110) * ((IYO(NY,(M-1)*NSYM+I),I=1,NSYM),M=2,MMAXK) 110 FORMAT(19X,3I2) WRITE(IFCH,*)' ' ENDIF C SELECT NN-SUBTABLEAUS C --------------------- DITAB=1 DO 6004 NN=0,N IGA=IG*NINT(EXP(TUCL(1+IDI,1+NN))) DO 15 L=1,KPARX IYOX(L)=-1 15 CONTINUE DO 11 M=1,MMAXK MEMP=M-1 MS=(M-1)*NSYM DO 11 I=1,NSYM IF ( IYO(NY,MS+I) .EQ. NN ) GOTO 12 11 CONTINUE 12 CONTINUE MMAXKS=MMAXK-MEMP DO 13 L=MS+1,K IF ( IYO(NY,L) .EQ. NN ) IYOX(L-MS)=IYO(NY,L) 13 CONTINUE IF ( NSYM .GT. 1 ) THEN DO 17 I=1,NSYM-1 DO 16 M=1,MMAXK MS=(M-1)*NSYM IF ( IYOX(MS+1) .NE. -1 ) GOTO 18 16 CONTINUE DO 19 M=1,MMAXK MS=(M-1)*NSYM DO 20 L=1,NSYM-1 IYOX(MS+L)=IYOX(MS+L+1) 20 CONTINUE IYOX(MS+NSYM)=-1 19 CONTINUE 17 CONTINUE 18 CONTINUE ENDIF DO 38 L=1,KPARX CYOX(1+NN,L)=' ' IF ( IYOX(L) .GE. 0 ) CYOX(1+NN,L)='X' 38 CONTINUE C SKIP FOR EMPTY TABLEAUS C ----------------------- DO 21 L=1,K IF ( IYOX(L) .NE. -1 ) GOTO 22 21 CONTINUE GOTO 6004 22 CONTINUE C PRINT C ----- IF ( ISH .GE. 93 .AND. NSYM .EQ .3 ) THEN IF ( IGA.GE. 1.AND.IGA.LT. 10 ) WRITE(CIGA,107)IGA 107 FORMAT('GL(',I1,') ') IF ( IGA.GT. 10.AND.IGA.LT. 100 ) WRITE(CIGA,108)IGA 108 FORMAT('GL(',I2,') ') IF ( IGA.GT.100.AND.IGA.LT.1000 ) WRITE(CIGA,109)IGA 109 FORMAT('GL(',I3,')') WRITE(IFCH,116)NN,((CYOX(1+NN,(M-1)*NSYM+I) * ,I=1,NSYM),M=1,1),CIGA 116 FORMAT(2X,I2,'-SUBTABLEAU:',3X,3(1X,A1),3X,A7) IF ( MMAXKS .GT. 1 ) THEN DO 39 M=2,MMAXKS WRITE(IFCH,106)(CYOX(1+NN,(M-1)*NSYM+I),I=1,NSYM) 106 FORMAT(19X,3(1X,A1)) 39 CONTINUE ENDIF IF ( ISH .GE. 94 ) WRITE(IFCH,*)' ' ENDIF C REDUCTIONS OF TABLEAUS 1+IYOX() C ------------------------------- DISUTA=0. N1=1 N3=1 N300=1 DO 24 I=1,NSYM MA=0 ME=0 DO 25 M=1,MMAXK IF ( 1+IYOX((M-1)*NSYM+I) .LE. 0 ) GOTO 25 IF ( MA .EQ. 0 ) MA=M ME=M 25 CONTINUE IYOZ(N1,I,1)=MA IYOZ(N1,I,2)=ME 24 CONTINUE IYOL(N1)=0 YOFA(N1)=1. IYOO(N1)=0 IYOM(N1)=1 N1=N1-1 5000 N1=N1+1 N30=N3 IF ( N1.GT.1 .AND. IYOL(N1).GT.IYOL(N1-1) ) N300=N3 N2=N1 DO 26 I=1,NSYM IYOR(I)=MAX(0,IYOZ(N1,I,2)-1) 26 CONTINUE LEV=IYOL(N1) FAC=YOFA(N1) IF ( IGA-1.LE.IOVMAX .AND. LEV.LE.JOVMAX * .AND. LEV.LE.IGA-1 ) THEN FACX=EXP(OVEL(IGA,1+LEV)) IF ( ABS(FACX-FAC) .GT. 1.E-5*FAC ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,*)'N=',N,' K=',K,' KK=',KK * ,' NY=',NY WRITE(IFCH,*)'FACX=',FACX,' FAC=',FAC CALL UTSTOP * ('JCENTR: BINOMIALS DIFFER ') ENDIF ENDIF IF ( LEV .GT. IGA-1 ) GOTO 5003 IHEIM=0 DO 32 I=1,NSYM IHEI=IYOZ(N1,I,2)-IYOZ(N1,I,1) IF ( IHEI .GT. IHEIM ) IHEIM=IHEI 32 CONTINUE IF ( IHEIM .EQ. 0 ) DISUTA=DISUTA+FAC*IYOM(N1) IF ( ISH.GE.94 .AND. NSYM.EQ.3 ) THEN WRITE(IFCH,112)N1,(IYOZ(N1,I,1),I=1,NSYM),IYOO(N1) * ,LEV,FAC,IYOM(N1),IHEIM,DISUTA * ,(IYOZ(N1,I,2),I=1,NSYM) 112 FORMAT(3X,I3,2X,3I2,2X,'ORI:',I3,3X * ,'LEV:',I2,3X,'FAC:',F8.1 * ,3X,'MUL:',I2,3X,'HEI:',I2,3X,'SUM:',F8.1/8X,3I2/) ENDIF N2=N2-1 5001 N2=N2+1 DO 27 I=1,NSYM IF ( IYOZ(N2,I,2)-1 .LT. IYOR(I) ) GOTO 27 IF ( I.LT.NSYM .AND. * IYOZ(N2,I,2)-1.LT.IYOZ(N2,I+1,2) ) GOTO27 N3=N3+1 IF ( N3 .GT. ITAMAX ) THEN CALL UTSTOP * ('JCENTR: DIMENSION ITAMAX TOO SMALL ') ENDIF IYOL(N3)=IYOL(N1)+1 YOFA(N3)=( YOFA(N1)*(IGA-IYOL(N3)) )/IYOL(N3) IYOO(N3)=N1 IYOM(N3)=IYOM(N1) DO 28 J=1,NSYM IYOZ(N3,J,1)=IYOZ(N2,J,1) IYOZ(N3,J,2)=IYOZ(N2,J,2) 28 CONTINUE IYOZ(N3,I,2)=IYOZ(N3,I,2)-1 IF ( IYOZ(N3,I,2) .LT. IYOZ(N3,I,1) ) THEN IYOZ(N3,I,1)=0 IYOZ(N3,I,2)=0 ENDIF IF ( N30+1 .LT. N3 ) THEN DO 30 NCH=N30+1,N3-1 DO 31 IJ=1,NSYM IF ( IYOZ(NCH,IJ,1).NE.IYOZ(N3,IJ,1) .OR. * IYOZ(NCH,IJ,2).NE.IYOZ(N3,IJ,2) ) GOTO 30 31 CONTINUE N3=N3-1 GOTO 27 30 CONTINUE ENDIF IF ( ISH .GE. 95 .AND. NSYM .EQ. 3 ) THEN WRITE(IFCH,113)N1,(IYOZ(N1,IJ,1),IJ=1,NSYM),N2 * ,(IYOZ(N2,IJ,1),IJ=1,NSYM),N3,(IYOZ(N3,IJ,1),IJ=1,NSYM) * ,(IYOZ(N1,IJ,2),IJ=1,NSYM) * ,(IYOZ(N2,IJ,2),IJ=1,NSYM),(IYOZ(N3,IJ,2),IJ=1,NSYM) 113 FORMAT(3X,'N1: ',I2,3X,3I2,4X,'N2: ',I2,3X,3I2,4X * ,'N3: ',I2,3X,3I2/12X,3I2,13X,3I2,13X,3I2/) ENDIF 27 CONTINUE IF ( N2 .EQ. N1 ) N2=N30 IF ( N2 .LT. N3 ) GOTO 5001 IF ( N30 .LT. N3 .AND. N300 .LT. N30 ) THEN N3S=N3 N3M=N3 N3=N30 DO 33 NCH3=N30+1,N3S N3=N3+1 DO 34 NCH=N300+1,N30 DO 35 IJ=1,NSYM IF ( IYOZ(NCH,IJ,1).NE.IYOZ(N3,IJ,1) .OR. * IYOZ(NCH,IJ,2).NE.IYOZ(N3,IJ,2) ) GOTO 34 35 CONTINUE IYOM(NCH)=IYOM(NCH)+IYOM(N3) N3=N3-1 N3M=N3M-1 IF ( N3+1 .LE. N3M ) THEN DO 36 NM=N3+1,N3M IYOL(NM)=IYOL(NM+1) YOFA(NM)=YOFA(NM+1) IYOO(NM)=IYOO(NM+1) IYOM(NM)=IYOM(NM+1) DO 37 J=1,NSYM IYOZ(NM,J,1)=IYOZ(NM+1,J,1) IYOZ(NM,J,2)=IYOZ(NM+1,J,2) 37 CONTINUE 36 CONTINUE ENDIF GOTO 33 34 CONTINUE 33 CONTINUE ENDIF IF ( N1 .LT. N3 ) GOTO 5000 5003 CONTINUE DIALT=-99999. IF ( IYOZ(1,1,1) .EQ. 1 ) THEN DIALT=1. DO 40 I=1,NSYM IF ( IYOZ(1,I,1) .GT. 1 ) THEN CALL UTSTOP * ('JCENTR: IYOZ(,,1).GT.1 ') ELSEIF ( IYOZ(1,I,1) .EQ. 0 ) THEN GOTO 40 ENDIF DO 41 M=1,IYOZ(1,I,2) HAK=IYOZ(1,I,2)-M+1 IF ( I .LT. NSYM ) THEN DO 42 J=I+1,NSYM IF ( IYOZ(1,J,2) .GE. M ) HAK=HAK+1 42 CONTINUE ENDIF DIALT=DIALT*(IGA+I-M)/HAK 41 CONTINUE 40 CONTINUE ENDIF IF ( DIALT.NE.-99999. .AND. * ABS(DIALT-DISUTA).GT.1.E-5*DIALT ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,*)'N=',N,' K=',K,' KK=',KK * ,' NY=',NY WRITE(IFCH,*)'DISUTA=',DISUTA,' DIALT=',DIALT CALL UTSTOP * ('JCENTR: DIMENSIONS DIFFER ') ENDIF IF ( ISH .GE. 93 ) WRITE(IFCH,118)DISUTA 118 FORMAT(28X,'SUBTAB.-DIMENSION:',F8.1/) DITAB=DITAB*DISUTA 6004 CONTINUE IF ( ISH .GE. 93 ) WRITE(IFCH,119)DITAB 119 FORMAT(35X,'TABLEAU-DIMENSION:',F11.1/) DEGEN(1+K,1+N)=DEGEN(1+K,1+N)+DITAB 6005 CONTINUE JJ=JJ+LL+1 6002 CONTINUE 6003 CONTINUE IF ( KKK(K) .EQ. 0 ) THEN CALL UTSTOP('JCENTR: NO ALLOWED PARTITION ') ENDIF ENTRO(1+K,1+N)=-9999999. IF ( DEGEN(1+K,1+N) .GT. 0. ) * ENTRO(1+K,1+N)=LOG(DEGEN(1+K,1+N)) IF ( ISH .GE. 93 ) WRITE(IFCH,120)DEGEN(1+K,1+N) 120 FORMAT(49X,'DEGENERACY:',F11.1/) 6001 CONTINUE 6000 CONTINUE IF ( ISH .GE. 92 ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,121)('-',IC=1,79) 121 FORMAT(1X,79A1) WRITE(IFCH,*)' DEGENERACY(K,N) IG=',IG,' ' * ,'NSYM=',NSYM WRITE(IFCH,121)('-',IC=1,79) WRITE(IFCH,*)' K:',' 3',' 6',' 9',' 12' WRITE(IFCH,121)('-',IC=1,79) DO 52 N=0,NQUAX WRITE(IFCH,*)N,(DEGEN(1+3*K,1+N),K=1,4) 52 CONTINUE WRITE(IFCH,*)' ' WRITE(IFCH,121)('-',IC=1,79) WRITE(IFCH,*)' ENTROPY(K,N) IG=',IG,' ' * ,'NSYM=',NSYM WRITE(IFCH,121)('-',IC=1,79) WRITE(IFCH,*)' K:',' 3',' 6',' 9',' 12' WRITE(IFCH,121)('-',IC=1,79) DO 53 N=0,NQUAX WRITE(IFCH,*)N,(ENTRO(1+3*K,1+N),K=1,4) 53 CONTINUE ENDIF ISH0=ISH IF ( ISHSUB/100 .EQ. 12 ) ISH=MOD(ISHSUB,100) IF ( ISH .GE. 95 ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,121)('-',IC=1,79) WRITE(IFCH,*)' ENTROPY(K,N) IG=',IG * ,' NSYM=',NSYM WRITE(IFCH,121)('-',IC=1,79) WRITE(IFCH,125)KPARX 125 FORMAT(6X,'IF(KPARX.NE.',I2,')'/5X, * 56H*CALL UTSTOP('JCENTD: INSUFFICIENT INITIALIZATION; K')) WRITE(IFCH,126)NQUAX 126 FORMAT(6X,'IF(NQUAX.NE.',I2,')'/5X, * 56H*CALL UTSTOP('JCENTD: INSUFFICIENT INITIALIZATION; N')) DO 58 KX=0,KPARX/3 K=3*KX WRITE(IFCH,123)K+1,NQUAX 123 FORMAT(6X,'DATA (ENTRO(',I2,',1+N),N=0,',I2,')/') WRITE(IFCH,124)(ENTRO(1+K,1+N),DELI(1+K,1+N), N=0,NQUAX) 124 FORMAT(10(5X,'*',6(E10.5,A1)/)) 58 CONTINUE ENDIF ISH=ISH0 RETURN END C======================================================================= SUBROUTINE JCLUDE(IP,IRET) C----------------------------------------------------------------------- C DECAYS CLUSTER IP FROM /CPTL/ . C REQIRES JCENTR OR JCENTD TO BE CALLED BEFORE. C----------------------------------------------------------------------- PARAMETER (IOMAX=54) PARAMETER (IOMAXM=25) PARAMETER (MOXMAX=30) PARAMETER (MOMAX=MOXMAX*IOMAX) PARAMETER (MXPTL=70000) PARAMETER (NFLAV=6) COMMON /CENTEX/ ENTEXP COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /CPTL/ PPTL(5,MXPTL),TIVPTL(2,MXPTL),XORPTL(4,MXPTL) * ,IBPTL(4,MXPTL),ICLPTL(MXPTL),IDPTL(MXPTL) * ,IFRPTL(2,MXPTL),IORPTL(MXPTL),ISTPTL(MXPTL) * ,JORPTL(MXPTL),NPTL,NQJPTL(MXPTL) COMMON /CSCAL/ SCAL COMMON /CSJCGA/ AMEGAM,AMNULL,ASUHA(7),ENTRPY,NOPHA,NSUHA(7) COMMON /CTIMEL/ NTC COMMON /CUTINV/ LUTINV COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT DOUBLE PRECISION PA(5),PE(5),PPT(5) REAL OO(1+MOMAX),PA0(5),POL(IOMAX) * ,QO(1+MOMAX),U(3),XO(1+MOMAX),YO(1+MOMAX) INTEGER ICA(2),IDOL(IOMAX),IDOLIS(IOMAX),IFOLIS(IOMAX) * ,JCA(NFLAV,2),JCA0(NFLAV,2),JCE(NFLAV,2) * ,JCO(NFLAV,2),KO(1+MOMAX) DATA IDOLIS/ * 110, 120,-120, 220, 130, -130, 230, -230, 330 * ,1120,-1120,1220,-1220,1130,-1130,1230,-1230,2130,-2130 * ,2230,-2230,1330,-1330,2330,-2330 * ,1111,-1111,2221,-2221,3331,-3331 * ,111, 121,-121, 221, 131, -131, 231, -231, 331 * ,1121,-1121,1221,-1221,1131,-1131,1231,-1231 * ,2231,-2231,1331,-1331,2331,-2331/ DATA IFOLIS/9*1,16*2,6*4,9*3,14*4/ SAVE C----------------------------------------------------------------------- ISH0=ISH IF ( ISHSUB/100 .EQ. 1 ) ISH=MOD(ISHSUB,100) IF ( ISH .GE. 92 ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,*)('-',L=1,79) WRITE(IFCH,*)' CLUSTER DECAY OF',IP,IDPTL(IP),PPTL(5,IP) WRITE(IFCH,*)('-',L=1,79) WRITE(IFCH,*)' ' ENDIF DELPOX=.01 NPTLB=NPTL LOOP=0 IRET=0 IPOXRA=0 ISTPFL=0 EBAMIN=1.5 LOOPMX=20 NOPHAX=20 C ORIGINAL CLUSTER --> PA,JCA C --------------------------- 6010 CONTINUE PA(1)=PPTL(1,IP) PA(2)=PPTL(2,IP) PA(3)=PPTL(3,IP) PA(4)=PPTL(4,IP) PA(5)=PPTL(5,IP) CALL IDQUAC(IP,NDU,NDU,NDU,JCA) IF ( ISH .GE. 92 ) THEN WRITE(IFCH,*)'INITIAL JCA:' WRITE(IFCH,*)JCA ENDIF CALL IDCOMJ(JCA) IF ( ISH .GE. 92 ) THEN WRITE(IFCH,*)'INITIAL JCA AFTER COMPACTIFICATION:' WRITE(IFCH,*)JCA ENDIF PA0(1)=PA(1) PA0(2)=PA(2) PA0(3)=PA(3) PA0(4)=PA(4) PA0(5)=PA(5) NQN=0 DO 2 NF=1,NFLAV NQN=NQN+JCA(NF,1)-JCA(NF,2) JCA0(NF,1)=JCA(NF,1) JCA0(NF,2)=JCA(NF,2) 2 CONTINUE NBA=ABS(NQN)/3 IF ( NBA .GT. 0 ) THEN EBA=PA(5)/NBA ELSE EBA=AINFIN ENDIF ISH00=ISH C INITIALIZATION FOR REDO C ----------------------- 6001 LOOP=LOOP+1 IF ( ISH00 .EQ. 90 ) THEN IF ( LOOP .EQ. LOOPMX ) THEN ISH=92 WRITE(IFCH,117)('-',L=1,75),LOOP,ISH 117 FORMAT(//1X,75A1/1X,I2,'. ATTEMPT TO DECAY THIS CLUSTER!' * /1X,'ISH SET TO: ',I2) ENDIF ENDIF IF ( LOOP .GT. LOOPMX ) THEN ISH=ISH00 GOTO 1001 ENDIF NOPHA=0 ISMALL=0 NPTL=NPTLB PA(1)=PA0(1) PA(2)=PA0(2) PA(3)=PA0(3) PA(4)=PA0(4) PA(5)=PA0(5) DO 3 NF=1,NFLAV JCA(NF,1)=JCA0(NF,1) JCA(NF,2)=JCA0(NF,2) 3 CONTINUE C LOOP OVER SEQUENTIAL DECAYS C --------------------------- 6002 NPTL=NPTL+1 IF ( NPTL .GT. MXPTL ) THEN CALL UTSTOP('JCLUDE: NPTL>MXPTL ') ENDIF ISJCA=0 DO 210 NF=1,NFLAV ISJCA=ISJCA+ABS(JCA(NF,1))+ABS(JCA(NF,2)) 210 CONTINUE IF ( ISJCA .EQ. 0 ) THEN JCA(1,1)=1 JCA(1,2)=1 ENDIF CALL IDCOMJ(JCA) CALL IDENCO(JCA,ICA,IRETEN) IF ( ISH .GE. 92 ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,100)(PA(K),K=1,5) 100 FORMAT(1X,'PA:',20X,5(E10.3,1X)) WRITE(IFCH,116)JCA 116 FORMAT(1X,'JCA: ',6I5/6X,6I5) ENDIF KAU=JCA(1,1)-JCA(1,2) KAD=JCA(2,1)-JCA(2,2) KAS=JCA(3,1)-JCA(3,2) KAC=JCA(4,1)-JCA(4,2) AMICL=UTAMNU(KAU,KAD,KAS,KAC,5) IF ( NOPHA.EQ.NOPHAX .OR. NOPHA.GT.1.AND.PA(5).GT.2.*AMICL ) THEN IF ( ISH .GE. 90 ) THEN CALL UTMSG('JCLUDE') IF ( ISMALL .EQ. 0 ) THEN WRITE(IFCH,*)'***** NO PHASE SPACE --> REDO DECAY' ELSEIF ( ISMALL .EQ. 1 ) THEN WRITE(IFCH,*)'***** SMALL PHASE SP --> REDO DECAY' ELSE WRITE(IFCH,*)'***** SMALL/NO PHASE SPACE --> REDO DECAY' WRITE(IFCH,*)'ISMALL=',ISMALL ENDIF WRITE(IFCH,*)'NT=',NTC,' LOOP=',LOOP,' NOPHA=',NOPHA IF ( ISMALL .EQ. 1 ) * WRITE(IFCH,*)'YO_HIT=',YOHIT,' YO_MAX=',YOMAX WRITE(IFCH,*)'M_MIN=',AMICL,' M=',PA(5) WRITE(IFCH,100)(PA(K),K=1,5) WRITE(IFCH,116)JCA CALL UTMSGF ENDIF GOTO 6001 ENDIF IF ( NOPHA .GT. 1 ) THEN IF ( ISH .GE. 90 ) THEN CALL UTMSG('JCLUDE') IF ( ISMALL .EQ. 0 ) THEN WRITE(IFCH,*)'***** NO PHASE SPACE --> INCRS MASS' ELSEIF ( ISMALL .EQ. 1 ) THEN WRITE(IFCH,*)'***** SMALL PHASE SP --> INCRS MASS' ELSE WRITE(IFCH,*)'***** SMALL/NO PHASE SPACE --> INCRS MASS' WRITE(IFCH,*)'ISMALL=',ISMALL ENDIF WRITE(IFCH,*)'NT=',NTC,' LOOP=',LOOP,' NOPHA=',NOPHA IF ( ISMALL .EQ. 1 ) * WRITE(IFCH,*)'YO_HIT=',YOHIT,' YO_MAX=',YOMAX WRITE(IFCH,*)'M_MIN=',AMICL,' M=',PA(5) WRITE(IFCH,100)(PA(K),K=1,5) WRITE(IFCH,116)JCA ENDIF PA(5)=PA(5)*1.05 PA(4)=SQRT(PA(1)**2+PA(2)**2+PA(3)**2+PA(5)**2) IF ( ISH .GE. 90 ) THEN WRITE(IFCH,100)(PA(K),K=1,5) CALL UTMSGF ENDIF ENDIF IDAR=0 IF ( NOPHA .EQ. 0 ) THEN ICH=0 IF ( IRETEN .EQ. 0 ) THEN IDA=IDTRA(ICA,0,0,3) ELSE IDA=0 ENDIF AMA=PA(5) CALL IDRES(IDA,AMA,IDAR,IADJ) IF ( IDAR .NE. 0 .AND. EBA .LT. EBAMIN ) THEN AMA=0. CALL IDRES(IDA,AMA,IDAR,IADJ) IF ( MOD(IDAR,10) .NE. 0 .AND. LOOP .LT. LOOPMX/2 ) GOTO 6001 ENDIF IF ( IDAR .NE. IDPTL(IP) ) ICH=1 ENDIF IF ( IDAR .NE. 0 ) THEN IF ( NPTL .GT. NPTLB+1 .OR. ICH .EQ. 1 ) THEN IDPTL(NPTL)=IDAR PA(5)=AMA PA(4)=SQRT(AMA**2+PA(1)**2+PA(2)**2+PA(3)**2) PPTL(1,NPTL)=PA(1) PPTL(2,NPTL)=PA(2) PPTL(3,NPTL)=PA(3) PPTL(4,NPTL)=PA(4) PPTL(5,NPTL)=PA(5) IF ( ISH .GE. 92 ) * WRITE(IFCH,101)NPTL,IDPTL(NPTL),(PPTL(K,NPTL),K=1,5) 101 FORMAT(1X,'/CPTL/',I6,I11,2X,5(E10.3,1X)) ELSE NPTL=NPTL-1 ENDIF GOTO 7001 ENDIF AMA=PA(5) C LOOP OVER HADRONS C ----------------- MO=1 PO=0. XO(1)=0. QO(1)=0. YO(1)=0. OO(1)=0. KO(1)=0 IOM=0 QOL=0. IF ( ISH .GE. 92 ) WRITE(IFCH,106) 106 FORMAT(' PARTIAL DECAY WIDTHS:') DO 6003 IO=1,IOMAX IF ( EBA .LT. EBAMIN .AND. IO .GT. IOMAXM ) GOTO 6003 IDO=IDOLIS(IO) IOM=IOM+1 POL(IOM)=PO IDOL(IOM)=IDO CALL IDMASS(IDO,AMO) IDPTL(NPTL)=IDO CALL IDQUAC(NPTL,NDU,NDU,NDU,JCO) DO 22 NF=1,NFLAV JCE(NF,1)=JCA(NF,1)-JCO(NF,1) JCE(NF,2)=JCA(NF,2)-JCO(NF,2) IF ( JCE(NF,1) .LT. 0 ) THEN JCE(NF,2)=JCE(NF,2)-JCE(NF,1) JCE(NF,1)=0 ENDIF IF ( JCE(NF,2) .LT. 0 ) THEN JCE(NF,1)=JCE(NF,1)-JCE(NF,2) JCE(NF,2)=0 ENDIF 22 CONTINUE DO 13 I=5,NFLAV IF ( JCE(I,1).NE.0 .OR. JCE(I,2).NE.0 .OR. ISTPFL.GT.0 ) THEN IF ( ISTPFL .EQ. 2 ) THEN CALL UTSTOP('JCLUDE: MORE THAN 4 FLAVOURS ') ENDIF ISTPFL=ISTPFL+1 ISH=93 IF ( ISTPFL .EQ. 2 ) GOTO 6010 GOTO 6001 ENDIF 13 CONTINUE KEU=JCE(1,1)-JCE(1,2) KED=JCE(2,1)-JCE(2,2) KES=JCE(3,1)-JCE(3,2) KEC=JCE(4,1)-JCE(4,2) C LOOP OVER HADRON MOMENTA C ------------------------ IF ( MO+MOXMAX .GT. 1+MOMAX ) THEN CALL UTSTOP('JCLUDE: DIMENSION MOMAX TOO SMALL ') ENDIF POX=0. MOM=MO POM=PO QOM=QO(MO) GAMXM=0. POXM=0. GAMY=0. DELPO=DELPOX YOINT=0. DO 6004 MOX=1,MOXMAX MO=MO+1 DELPO=DELPO*1.2 POX=POX+DELPO PO=PO+DELPO XO(MO)=PO IF ( MOX .GT. 1 ) THEN KO(MO)=0 ELSE KO(MO)=IDO ENDIF GAMX=SJCGAM(KEU,KED,KES,KEC,AMA,AMO,POX,MOX) YO(MO)=IFOLIS(IO)*DELPO*GAMX OO(MO)=ENTEXP YOINT=YOINT+IFOLIS(IO)*DELPO*(GAMX+GAMY)*0.5 IF ( GAMX .EQ. 0. ) THEN I6005=1 ELSE IF ( GAMX .LT. 1.E-2*GAMXM .AND. GAMXM .GT. 0. * .AND. MOX .GT. 1 ) THEN I6005=1 ELSE I6005=0 ENDIF ENDIF IF ( ISH.GE.93 .AND. (I6005.EQ.0 .OR. MOX.GT.1) ) THEN IF ( MOX .EQ. 1 ) * WRITE(IFCH,109)KEU,KED,KES,NSUHA,AMA,ASUHA,AMNULL,IDO,AMO 109 FORMAT(/' U_D_S:',3I3,' N:',7I5,11X,' A:',F10.2 * /18X,'M:',7F5.2,' M0:',F6.2,' O:',I5,F5.2 * /' MO XO POX EO AMA-EO ENTRPY ' * ,' GAMX YO OO ') WRITE(IFCH,105)MO,XO(MO),POX,SQRT(POX**2+AMO**2) * ,AMA-SQRT(POX**2+AMO**2),ENTRPY,GAMX * ,YO(MO),OO(MO) 105 FORMAT(1X,I5,1X,F6.2,F6.2,2X,F6.2,F6.2 * ,E12.3,E11.3,E11.3,E11.3) ENDIF IF ( I6005 .EQ. 1 ) GOTO 6005 IF ( GAMX .GT. GAMXM ) THEN GAMXM=GAMX POXM=POX ENDIF GAMY=GAMX 6004 CONTINUE IF ( ISH .GE. 90 .AND. IPOXRA .EQ. 0 ) THEN IPOXRA=1 CALL UTMSG('JCLUDE') WRITE(IFCH,*)'***** POX-RANGE TOO SMALL' WRITE(IFCH,100)(PA(K),K=1,5) WRITE(IFCH,*)'JCA:' WRITE(IFCH,*)JCA WRITE(IFCH,*)'POX= ',POX, ' GAMX= ',GAMX WRITE(IFCH,*)'POXM=',POXM,' GAMXM=',GAMXM CALL UTMSGF ENDIF 6005 CONTINUE IF ( YOINT .EQ. 0. ) THEN IF ( ISH .GE. 94 ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,*)'NO PHASE SPACE FOR',IDO ENDIF MO=MOM PO=POM IOM=IOM-1 ELSE IF ( ISH .GE. 92 ) WRITE(IFCH,107)IDO,POXM,YOINT,OO(MO) 107 FORMAT(' IDO,POXM,YOINT,OO:',I6,3X,F5.2,E12.3,E12.3) ENDIF 6003 CONTINUE IF ( ISH .GE. 92 ) WRITE(IFCH,*)' ' C NO PHASE SPACE C -------------- IF ( IOM .EQ. 0 ) THEN IF ( ISH .GE. 92 ) WRITE(IFCH,*)'NO PHASE SPACE' NPTL=NPTL-1 NOPHA=NOPHA+1 GOTO 6002 ENDIF C DETERMINE QO(M) C --------------- OOMAX=0. DO 211 M=1,MO IF ( OO(M) .GT. OOMAX ) OOMAX=OO(M) 211 CONTINUE OOX=OOMAX-10. DO 212 M=1,MO IF ( OO(M) .LT. OOX ) THEN YO(M)=0. ELSE YO(M)=YO(M)*EXP(OO(M)-OOX) ENDIF 212 CONTINUE QO(1)=0. DO 213 M=2,MO IF ( KO(M) .NE. 0 ) YOM=0. QO(M)=QO(M-1)+(YOM+YO(M))*0.5 YOM=YO(M) 213 CONTINUE YOMAX=0. DO 214 M=1,MO IF ( YO(M) .GT. YOMAX ) YOMAX=YO(M) 214 CONTINUE IF ( ISH .GE. 93 ) THEN IDO=0 XOX=0. WRITE(IFCH,*)' ' WRITE(IFCH,*)'ACCUMULATED DECAY PROBABILITIES:' WRITE(IFCH,*)' ' DO 215 M=1,MO IF ( KO(M) .NE. 0 ) THEN WRITE(IFCH,*)' ' IDO=KO(M) ENDIF WRITE(IFCH,110)M,IDO,XO(M)-XOX,QO(M) 110 FORMAT(1X,'M,IDO,XO,QO: ',I6,I6,3X,F6.2,E12.3) IF ( M .LT. MO .AND. KO(M+1) .NE. 0 ) XOX=XO(M) 215 CONTINUE ENDIF C SELECT RANDOMLY HADRON+MOMENTUM C ------------------------------- LO=0 24 LO=LO+1 IF ( LO .GT. 10 ) THEN IF ( ISH.GE.92 ) WRITE(IFCH,*)'SMALL PHASE SPACE:',YOHIT,YOMAX NPTL=NPTL-1 NOPHA=NOPHA+1 ISMALL=1 GOTO 6002 ENDIF XOS=UTINVT(MO,XO,QO,RANGEN()*QO(MO)) MHIT=LUTINV DO 28 I=2,IOM IX=I-1 IF ( XOS .LT. POL(I) ) GOTO 29 28 CONTINUE IX=IOM 29 CONTINUE POS=XOS-POL(IX) IDS=IDOL(IX) CALL IDMASS(IDS,AMS) IDPTL(NPTL)=IDS CALL IDQUAC(NPTL,NDU,NDU,NDU,JCO) DO 26 NF=1,NFLAV JCE(NF,1)=JCA(NF,1)-JCO(NF,1) JCE(NF,2)=JCA(NF,2)-JCO(NF,2) IF ( JCE(NF,1) .LT. 0 ) THEN JCE(NF,2)=JCE(NF,2)-JCE(NF,1) JCE(NF,1)=0 ENDIF IF ( JCE(NF,2) .LT. 0 ) THEN JCE(NF,1)=JCE(NF,1)-JCE(NF,2) JCE(NF,2)=0 ENDIF 26 CONTINUE DO 27 I=5,NFLAV IF ( JCE(I,1) .NE. 0 .OR. JCE(I,2) .NE. 0 ) THEN CALL UTSTOP('JCLUDE: FLAVOUR > 4 ') ENDIF 27 CONTINUE KEU=JCE(1,1)-JCE(1,2) KED=JCE(2,1)-JCE(2,2) KES=JCE(3,1)-JCE(3,2) KEC=JCE(4,1)-JCE(4,2) GAMXHT=SJCGAM(KEU,KED,KES,KEC,AMA,AMS,POS,1) YOHIT=GAMXHT*(XO(MHIT+1)-XO(MHIT))*4. IF ( YOHIT .LT. 1.E-5 .AND. YOHIT .LT. 1.E-5*YOMAX ) GOTO 24 PPTL(5,NPTL)=AMS U(3)=2.*RANGEN()-1. PHI=2.*PI*RANGEN() U(1)=SQRT(1.-U(3)**2)*COS(PHI) U(2)=SQRT(1.-U(3)**2)*SIN(PHI) PPT(1)=POS*U(1) PPTL(1,NPTL)=PPT(1) PPT(2)=POS*U(2) PPTL(2,NPTL)=PPT(2) PPT(3)=POS*U(3) PPTL(3,NPTL)=PPT(3) PPT(4)=SQRT(PPTL(5,NPTL)**2+POS**2) PPTL(4,NPTL)=PPT(4) IF ( ISH .GE. 93 ) * WRITE(IFCH,101)NPTL,IDPTL(NPTL),(PPTL(K,NPTL),K=1,5) CALL UTLOB2(-1,PA(1),PA(2),PA(3),PA(4),PA(5) * ,PPT(1),PPT(2),PPT(3),PPT(4)) PPTL(1,NPTL)=PPT(1) PPTL(2,NPTL)=PPT(2) PPTL(3,NPTL)=PPT(3) PPTL(4,NPTL)=PPT(4) IF ( ISH .GE. 92 ) * WRITE(IFCH,101)NPTL,IDPTL(NPTL),(PPTL(K,NPTL),K=1,5) PE(5)=AMEGAM PE(1)=-POS*U(1) PE(2)=-POS*U(2) PE(3)=-POS*U(3) PE(4)=SQRT(PE(5)**2+POS**2) CALL UTLOB2(-1,PA(1),PA(2),PA(3),PA(4),PA(5) * ,PE(1),PE(2),PE(3),PE(4)) PA(1)=PE(1) PA(2)=PE(2) PA(3)=PE(3) PA(4)=PE(4) PA(5)=PE(5) DO 23 NF=1,NFLAV JCA(NF,1)=JCE(NF,1) JCA(NF,2)=JCE(NF,2) 23 CONTINUE NOPHA=0 GOTO 6002 7001 CONTINUE C CHECK ENERGY CONSERVATION C ------------------------- IF ( NPTL .LE. NPTLB ) GOTO 1000 IFAIL=1 IF ( NPTL .GT. NPTLB+1 ) THEN ISHRSC=ISH ISH=0 CALL JRESCL(NPTLB+1,NPTL,PA0,IFAIL) ISH=ISHRSC C-C IF ( IFAIL.NE.0 .AND. ISH.GE.90 ) THEN C-C CALL UTMSG('JCLUDE') C-C WRITE(IFCH,*)'***** IFAIL_JRESCL=',IFAIL C-C CALL UTMSGF C-C ENDIF ENDIF C-C DO 114 N=NPTLB+1,NPTL C-C P=PPTL(3,N) C-C E=PPTL(4,N) C-C Y=100. C-C DY=3. C-C IF ( E-P.NE.0. .AND. E+P.NE.0. ) Y=.5*LOG((E+P)/(E-P))+DY C-C IDA=ABS(IDPTL(N)) C-C IF ( IDA.GT.1000 .AND. MOD(IDA,10).NE.0 .AND. Y.LT.10. ) THEN C-C WRITE(6,*)('-',K=1,69) C-C P=PPTL(3,IP) C-C E=PPTL(4,IP) C-C Y=100. C-C DY=3. C-C IF ( E-P.NE.0. .AND. E+P.NE.0. ) Y=.5*LOG((E+P)/(E-P))+DY C-C WRITE(6,115)IP,IDPTL(IP) C-C * ,(PPTL(K,IP),K=3,5),Y C-C WRITE(6,*)'-------> ' C-C DO 113 M=NPTLB+1,NPTL C-C P=PPTL(3,M) C-C E=PPTL(4,M) C-C Y=100. C-C DY=3. C-C IF ( E-P.NE.0. .AND. E+P.NE.0. ) Y=.5*LOG((E+P)/(E-P))+DY C-C WRITE(6,115)M,IDPTL(M) C-C * ,(PPTL(K,M),K=3,5),Y C113 CONTINUE C-C ENDIF C114 CONTINUE 115 FORMAT(1X,'/CPTL/',I6,I10 *,3(E10.2),2(E10.2)) IF ( ISH .GE. 0 ) THEN PX=0. PY=0. PZ=0. E=0. DO 10 N=NPTLB+1,NPTL PX=PX+PPTL(1,N) PY=PY+PPTL(2,N) PZ=PZ+PPTL(3,N) E=E+ PPTL(4,N) 10 CONTINUE ENDIF IF ( ISH .GE. 90 ) THEN IF ( ISH .GE. 92 ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,*)'CHECK ENERGY CONSERVATION' DO 11 N=NPTLB+1,NPTL WRITE(IFCH,101)N,IDPTL(N),(PPTL(K,N),K=1,5) 11 CONTINUE AM=SQRT(E**2-PX**2-PY**2-PZ**2) WRITE(IFCH,103)PX,PY,PZ,E,AM 103 FORMAT(1X,'P_SUM: ',15X,5(E10.3,1X)) WRITE(IFCH,104)(PA0(K),K=1,5) 104 FORMAT(1X,'P_CLU: ',15X,5(E10.3,1X)) ENDIF IF ( IFAIL.EQ.0 .AND. * (ABS(PX-PA0(1)).GT.1.E-2*ABS(PX).AND.ABS(PX-PA0(1)).GT.1.E-2 *.OR.ABS(PY-PA0(2)).GT.1.E-2*ABS(PY).AND.ABS(PY-PA0(2)).GT.1.E-2 *.OR.ABS(PZ-PA0(3)).GT.1.E-2*ABS(PZ).AND.ABS(PZ-PA0(3)).GT.1.E-2 *.OR.ABS(E -PA0(4)).GT.1.E-2*ABS(E ).AND.ABS(E -PA0(4)).GT.1.E-2) *.OR. * IFAIL.NE.0 .AND. * (ABS(PX-PA0(1)).GT.1.E-2*ABS(PX).AND.ABS(PX-PA0(1)).GT.1.E-2 *.OR.ABS(PY-PA0(2)).GT.1.E-2*ABS(PY).AND.ABS(PY-PA0(2)).GT.1.E-2 *.OR.ABS(PZ-PA0(3)).GT.1.E-2*ABS(PZ).AND.ABS(PZ-PA0(3)).GT.1.E-2 *.OR.ABS(E -PA0(4)).GT.35.E-1*ABS(E ).AND.ABS(E -PA0(4)).GT.35.E-1) * ) THEN CALL UTMSG('JCLUDE') WRITE(IFCH,*)'***** P_SUM /= P_CLU' WRITE(IFCH,*)'IFAIL_JRESCL:',IFAIL,' SCAL:',SCAL DO 30 N=NPTLB+1,NPTL WRITE(IFCH,101)N,IDPTL(N),(PPTL(K,N),K=1,5) 30 CONTINUE WRITE(IFCH,103)PX,PY,PZ,E WRITE(IFCH,104)(PA0(K),K=1,4) CALL UTMSGF ENDIF ENDIF 1000 CONTINUE IF ( ISH .GE. 92 ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,*)('-',L=1,25) WRITE(IFCH,*)' RETURN FROM JCLUDE ' WRITE(IFCH,*)('-',L=1,25) WRITE(IFCH,*)' ' ENDIF ISH=ISH0 RETURN 1001 IRET=1 IF ( ISH .GE. 90 ) THEN CALL UTMSG('JCLUDE') WRITE(IFCH,*)'***** CLUSTER DECAY NOT POSSIBLE --> IRET=1' WRITE(IFCH,100)(PA0(K),K=1,5) WRITE(IFCH,*)'JCA:' WRITE(IFCH,*)JCA0 CALL UTMSGF ENDIF RETURN END C======================================================================= SUBROUTINE JDECA(I,IRET) C----------------------------------------------------------------------- C DECAYS I (CALLS JDECAYV) C----------------------------------------------------------------------- PARAMETER (MXPTL=70000) PARAMETER (NFLAV=6) COMMON /CCLUDE/ KCLUDE COMMON /CPTL/ PPTL(5,MXPTL),TIVPTL(2,MXPTL),XORPTL(4,MXPTL) * ,IBPTL(4,MXPTL),ICLPTL(MXPTL),IDPTL(MXPTL) * ,IFRPTL(2,MXPTL),IORPTL(MXPTL),ISTPTL(MXPTL) * ,JORPTL(MXPTL),NPTL,NQJPTL(MXPTL) DOUBLE PRECISION DETAP,DETAT,TPRO,TTAR,TTAUS,TTP,TTT * ,ZPRO,ZTAR,ZZP,ZZT COMMON /CTTAUS/ DETAP,DETAT,TPRO,TTAR,TTAUS,TTP,TTT * ,ZPRO,ZTAR,ZZP,ZZT COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT DOUBLE PRECISION TOR,ZOR INTEGER JCDU(NFLAV,2) SAVE C----------------------------------------------------------------------- IRET=0 ISH0=ISH IF ( ISHSUB/100 .EQ. 5 ) ISH=MOD(ISHSUB,100) IF ( ISH .GE. 93 ) THEN WRITE(IFCH,*)('-',L=1,79) WRITE(IFCH,*)'ENTRY JDECA. DECAY OF',I,IDPTL(I),PPTL(5,I) ENDIF CDH CALL IDMASS(111,AMRHO0) CDH CALL IDMASS(221,AMOMEG) IOI=IORPTL(I) IF ( .NOT.( IOI.GT.0 .AND. ABS(IDPTL(IOI)).LT.10000 * .AND. JORPTL(I).EQ.0 ) ) THEN IF ( IDPTL(I) .EQ. 111 ) IDPTL(I)=221 IF ( IDPTL(I) .EQ. 221 .AND. RANGEN() .GT. 0.5 ) IDPTL(I)=111 ENDIF IF ( MOD(NDECAY ,10) .EQ.1 ) GOTO 1000 IDA=ABS(IDPTL(I)) IF ( MOD(NDECAY/10 ,10) .EQ.1 .AND. IDA .EQ. 20 ) GOTO 1000 IF ( MOD(NDECAY/100 ,10) .EQ.1 .AND. IDA .EQ.2130 ) GOTO 1000 IF ( MOD(NDECAY/1000 ,10) .EQ.1 ) THEN IF ( IDA .EQ.1130 ) GOTO 1000 IF ( IDA .EQ.2230 ) GOTO 1000 ENDIF IF ( MOD(NDECAY/10000 ,10) .EQ.1 ) THEN IF ( IDA .EQ.2330 ) GOTO 1000 IF ( IDA .EQ.1330 ) GOTO 1000 ENDIF IF ( MOD(NDECAY/100000 ,10) .EQ.1 .AND. IDA .EQ.3331 ) GOTO 1000 IF ( MOD(NDECAY/1000000,10) .EQ.1 .AND. IDA .EQ. 110 ) GOTO 1000 IF ( MOD(NDECAX ,10) .EQ.1 .AND. IDA .EQ. 441 ) GOTO 1000 IF ( MOD(NDECAX/10 ,10) .EQ.1 .AND. IDA .EQ. 230 ) GOTO 1000 IF ( MOD(NDECAX/100 ,10) .EQ.1 ) THEN IF ( IDA .EQ.1111 ) GOTO 1000 IF ( IDA .EQ.1121 ) GOTO 1000 IF ( IDA .EQ.1221 ) GOTO 1000 IF ( IDA .EQ.2221 ) GOTO 1000 ENDIF IF ( MOD(NDECAX/1000 ,10) .EQ.1 ) THEN IF ( IDA .EQ. 111 ) GOTO 1000 IF ( IDA .EQ. 121 ) GOTO 1000 IF ( IDA .EQ. 221 ) GOTO 1000 IF ( IDA .EQ. 331 ) GOTO 1000 ENDIF IF ( MOD(NDECAX/10000 ,10) .EQ.1 .AND. IDA .EQ. 220 ) GOTO 1000 IF ( MOD(NDECAX/100000 ,10) .EQ.1 .AND. IDA .EQ. 330 ) GOTO 1000 IF ( MOD(NDECAX/1000000,10) .EQ.1 ) THEN IF ( IDA .EQ. 112 ) GOTO 1000 IF ( IDA .EQ. 122 ) GOTO 1000 ENDIF IF ( MOD(NDECAW ,10) .EQ.1 .AND. IDA .EQ. 332 ) GOTO 1000 IF ( MOD(NDECAW/10 ,10) .EQ.1 ) THEN IF ( IDA .EQ. 131 ) GOTO 1000 IF ( IDA .EQ.-131 ) GOTO 1000 IF ( IDA .EQ. 231 ) GOTO 1000 IF ( IDA .EQ.-231 ) GOTO 1000 ENDIF T=TIVPTL(2,I) NPTLB=NPTL IF ( NPTL .GT. MXPTL-10 ) THEN CALL UTSTOP('JDECA: MXPTL TOO SMALL ') ENDIF ISH=ISH0 CALL JDECAYV(I,IRET) IF ( ISHSUB/100 .EQ. 5 ) ISH=MOD(ISHSUB,100) IF ( IRET .EQ. 1 ) GOTO 1000 IF ( NPTL .LE. NPTLB ) GOTO 1000 ISH00=ISH IF ( ISHSUB/100.EQ.14 .AND. KCLUDE.EQ.1 ) ISH=MOD(ISHSUB,100) IF ( ISH .GE. 91 ) THEN WRITE(IFCH,101)SNGL(TTAUS) 101 FORMAT(1X,'DECAY AT TAU =',E10.3) WRITE(IFCH,115)I,IDPTL(I) * ,(PPTL(K,I),K=3,5),(TIVPTL(K,I),K=1,2) 115 FORMAT(1X,'/CPTL/',I6,I10 * ,1X,3(E10.2),1X,2(E10.2)) ENDIF ISTPTL(I)=1 IFRPTL(1,I)=NPTLB+1 IFRPTL(2,I)=NPTL X=XORPTL(1,I)+(T-XORPTL(4,I))*PPTL(1,I)/PPTL(4,I) Y=XORPTL(2,I)+(T-XORPTL(4,I))*PPTL(2,I)/PPTL(4,I) Z=XORPTL(3,I)+(T-XORPTL(4,I))*PPTL(3,I)/PPTL(4,I) IF ( ISH .GE. 93 ) WRITE(IFCH,*) * 'LOOP OVER DECAY PRODUCTS ',NPTLB+1,' - ',NPTL,' :' DO 20 N=NPTLB+1,NPTL IF ( ISH .GE. 93 ) WRITE(IFCH,*)'PARTICLE: ',N,IDPTL(N) IORPTL(N)=I JORPTL(N)=0 ISTPTL(N)=0 IFRPTL(1,N)=0 IFRPTL(2,N)=0 XORPTL(1,N)=X XORPTL(2,N)=Y XORPTL(3,N)=Z XORPTL(4,N)=T NQJPTL(N)=NQJPTL(I) IO=N 1 IO=IORPTL(IO) IF ( ISH .GE. 93 ) WRITE(IFCH,*)'IO = ',IO IF ( IORPTL(IO) .GT. 0 ) GOTO 1 IF ( ISH.GE. 93 ) WRITE(IFCH,*)'ORIGIN: ',IO,IDPTL(IO) ZOR=XORPTL(3,IO) TOR=XORPTL(4,IO) CALL IDQUAC(IO,NQ,NDU,NDU,JCDU) R=RANGEN() TAURAN=-TAUREA*LOG(R) CALL UTTAIX(N,TAURAN,ZOR,TOR,ZIS,TIS) TIVPTL(1,N)=MAX(T,TIS) CALL IDTAU(IDPTL(N),PPTL(4,N),PPTL(5,N),TAUGM) TIVPTL(2,N)=T+TAUGM ICLPTL(N)=1 IF ( ISH .GE. 91 ) WRITE(IFCH,115)N,IDPTL(N) * ,(PPTL(K,N),K=3,5),(TIVPTL(K,N),K=1,2) 20 CONTINUE ISH=ISH00 1000 CONTINUE IF ( ISH .GE. 93 ) WRITE(IFCH,*)('-',L=1,79) ISH=ISH0 RETURN END C======================================================================= SUBROUTINE JDECAYV(IP,IRET) C----------------------------------------------------------------------- C DECAYS PARTICLE IP FROM /CPTL/ C----------------------------------------------------------------------- PARAMETER (MXDKY=2000) PARAMETER (MXLOOK=10000) PARAMETER (MXPTL=70000) COMMON /CCLUDE/ KCLUDE COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /CPTL/ PPTL(5,MXPTL),TIVPTL(2,MXPTL),XORPTL(4,MXPTL) * ,IBPTL(4,MXPTL),ICLPTL(MXPTL),IDPTL(MXPTL) * ,IFRPTL(2,MXPTL),IORPTL(MXPTL),ISTPTL(MXPTL) * ,JORPTL(MXPTL),NPTL,NQJPTL(MXPTL) COMMON /DKYTAB/ CBR(MXDKY),LOOK(MXLOOK),MODE(5,MXDKY) COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT COMMON /WCO/ WGAM2,WMASS2 REAL BETA(3),PGEN(5,5),PREST(4,5) * ,REDUCE(5),RND(5),U(3) DATA REDUCE/1.,1.,2.,5.,15./,TWOME/1.022006E-3/ SAVE C----------------------------------------------------------------------- C FCTN DEFINITIONS DOT(I1,I2)=PREST(4,I1)*PREST(4,I2)-PREST(1,I1)*PREST(1,I2) * -PREST(2,I1)*PREST(2,I2)-PREST(3,I1)*PREST(3,I2) C CHARGED W PROPAGATOR. WPROP(Z)=(Z-WMASS2**2)**2+(WMASS2*WGAM2)**2 C----------------------------------------------------------------------- ISH0=ISH IF ( ISHSUB/100 .EQ. 4 ) ISH=MOD(ISHSUB,100) IF ( ISH .GE. 93 ) THEN WRITE(IFCH,*)('-',L=1,79) WRITE(IFCH,*)'DECAY OF',IP,IDPTL(IP),PPTL(5,IP) ENDIF ISH=ISH0 IRET=0 KCLUDE=0 C NO K_LONG DECAY C --------------- IF ( IDPTL(IP) .EQ. -20 ) GOTO 1000 C CLUSTER DECAY C ------------- IF ( ABS(IDPTL(IP)) .GT. 100000000 ) THEN KCLUDE=1 CALL JCLUDE(IP,IRET) GOTO 1000 ENDIF IF ( ISHSUB/100 .EQ. 4 ) ISH=MOD(ISHSUB,100) IF ( ISH .GE. 93 ) WRITE(IFCH,*)'ORDINARY DECAY' C SELECT DECAY MODE C ----------------- NTRY=0 2 NTRY=NTRY+1 IF ( NTRY .GT. 100 ) THEN IF ( ISH .GE. 90 ) THEN CALL UTMSG('JDECAYV') WRITE(IFCH,*)'***** DECAY NOT POSSIBLE. IRET = 1.' WRITE(IFCH,*)'ID,MASS: ',IDPTL(IP),PPTL(5,IP) CALL UTMSGF ENDIF IRET=1 GOTO 1000 ENDIF IDLV1=IDPTL(IP) AMSS=PPTL(5,IP) 1 CONTINUE IPOINT=LOOK(IABS(IDLV1))-1 IF ( IPOINT .LT. 0 ) GOTO 1000 TRY=RANGEN() 100 IPOINT=IPOINT+1 IF ( ISH .GE. 93 ) WRITE(IFCH,*)'IPOINT,CBR,TRY' * ,IPOINT,CBR(IPOINT),TRY IF ( TRY .GT. CBR(IPOINT) ) GOTO 100 NADD=0 SUM=0. NSTART=NPTL+1 DO 110 I=1,5 IF ( MODE(I,IPOINT) .EQ. 0 ) GOTO 110 IF ( NPTL+NADD+1 .GT. MXPTL ) GOTO 9999 NADD=NADD+1 NEW=NPTL+NADD IDPTL(NEW)=MODE(I,IPOINT) IDLV1=IDPTL(NEW) CALL IDMASS(IDLV1,PPTL(5,NEW)) SUM=SUM+PPTL(5,NEW) 110 CONTINUE IF ( NADD .NE. 1 .AND. SUM+1.E-2 .GE. AMSS ) GOTO 2 NADD1=NADD-1 DO 120 J=1,5 PGEN(J,1)=PPTL(J,IP) 120 CONTINUE PGEN(5,NADD)=PPTL(5,NPTL+NADD) IF ( NADD .EQ. 1 ) GOTO 700 IF ( NADD .EQ. 2 ) GOTO 400 C USE KROLL-WADA DISTRIBUTION FOR DALITZ DECAYS. C ---------------------------------------------- IF ( ISH .GE. 93 ) WRITE(IFCH,*)'>= 3 BODY DECAY' IF ( .NOT. ( (IDPTL(IP).EQ.110 .OR. IDPTL(IP).EQ.220) .AND. * ABS(IDPTL(NPTL+2)).EQ.12 ) ) GOTO 130 NTRY=0 125 NTRY=NTRY+1 IF ( NTRY .GT. 10 ) THEN IF ( ISH .GE. 90 ) THEN CALL UTMSG('JDECAYV') WRITE(IFCH,*)'***** NTRY > 10. IRET = 1.' WRITE(IFCH,*)'AMEE,REE,WTEE',AMEE,REE,WTEE CALL UTMSGF ENDIF IRET=1 GOTO 1000 ENDIF AMEE=TWOME*(PPTL(5,IP)/TWOME)**RANGEN() REE=(TWOME/AMEE)**2 WTEE=(1.-(AMEE/PPTL(5,IP))**2)**3*SQRT(1.-REE)*(1.+.5*REE) IF ( WTEE .LT. RANGEN() ) GOTO 125 PGEN(5,2)=AMEE GOTO 400 130 CONTINUE C CALCULATE MAXIMUM PHASE-SPACE WEIGHT C ------------------------------------ WTMAX=1./REDUCE(NADD) SUM1=PGEN(5,1) SUM2=SUM-PPTL(5,NPTL+1) DO 200 I=1,NADD1 WTMAX=WTMAX*UTPCM(SUM1,SUM2,PPTL(5,NPTL+I)) SUM1=SUM1-PPTL(5,NPTL+I) SUM2=SUM2-PPTL(5,NPTL+I+1) 200 CONTINUE C GENERATE UNIFORM NADD-BODY PHASE SPACE C -------------------------------------- NTRY=0 300 NTRY=NTRY+1 IF ( NTRY .GT. 10000 ) THEN IF ( ISH .GE. 90 ) THEN CALL UTMSG('JDECAYV') WRITE(IFCH,*)'***** INFINITE LOOP (2). IRET = 1.' WRITE(IFCH,*)'IP,IDPTL(IP),PPTL(5,IP):' * ,IP,IDPTL(IP),PPTL(5,IP) WRITE(IFCH,*)'WT,WTMAX:',WT,WTMAX WRITE(IFCH,*)'I,PGEN(5,I),PPTL(5,NPTL+I),IDPTL(NPTL+I):' DO 305 I=1,NADD WRITE(IFCH,*)I,PGEN(5,I),PPTL(5,NPTL+I),IDPTL(NPTL+I) 305 CONTINUE CALL UTMSGF ENDIF IRET=1 GOTO 1000 ENDIF RND(1)=1. DO 310 I=2,NADD1 RNEW=RANGEN() I1=I-1 DO 320 JJ1=1,I1 J=I-JJ1 JSAVE=J+1 IF ( RNEW .LE. RND(J) ) GOTO 315 RND(JSAVE)=RND(J) 320 CONTINUE 315 RND(JSAVE)=RNEW 310 CONTINUE RND(NADD)=0. WT=1. SUM1=SUM DO 330 I=2,NADD SUM1=SUM1-PPTL(5,NPTL+I-1) PGEN(5,I)=SUM1+RND(I)*(PGEN(5,1)-SUM) A=PGEN(5,I-1) B=PGEN(5,I) C=PPTL(5,NPTL+I-1) WT=WT*UTPCM(A,B,C) 330 CONTINUE IF ( WT .LT. RANGEN()*WTMAX ) GOTO 300 C CARRY OUT TWO-BODY DECAYS IN PGEN FRAMES C ---------------------------------------- 400 CONTINUE IF ( ISH .GE. 93 ) WRITE(IFCH,*)'2 BODY DECAY' DO 410 I=1,NADD1 QCM=UTPCM(PGEN(5,I),PGEN(5,I+1),PPTL(5,NPTL+I)) U(3)=2.*RANGEN()-1. PHI=2.*PI*RANGEN() U(1)=SQRT(1.-U(3)**2)*COS(PHI) U(2)=SQRT(1.-U(3)**2)*SIN(PHI) PPTL(1,NPTL+I)=QCM*U(1) PGEN(1,I+1)=-PPTL(1,NPTL+I) PPTL(2,NPTL+I)=QCM*U(2) PGEN(2,I+1)=-PPTL(2,NPTL+I) PPTL(3,NPTL+I)=QCM*U(3) PGEN(3,I+1)=-PPTL(3,NPTL+I) PPTL(4,NPTL+I)=SQRT(QCM**2+PPTL(5,NPTL+I)**2) PGEN(4,I+1)=SQRT(QCM**2+PGEN(5,I+1)**2) 410 CONTINUE PPTL(1,NPTL+NADD)=PGEN(1,NADD) PPTL(2,NPTL+NADD)=PGEN(2,NADD) PPTL(3,NPTL+NADD)=PGEN(3,NADD) PPTL(4,NPTL+NADD)=PGEN(4,NADD) C BOOST PGEN FRAMES TO LAB FRAME C ALSO SAVE MOMENTA IN REST FRAME (LAST FRAME) C ------------------------------------------------- DO 500 II=1,NADD1 I=NADD-II BETA(1)=1./PGEN(4,I)*PGEN(1,I) BETA(2)=1./PGEN(4,I)*PGEN(2,I) BETA(3)=1./PGEN(4,I)*PGEN(3,I) GAMMA=PGEN(4,I)/PGEN(5,I) DO 520 K=I,NADD K1=NPTL+K BP=BETA(1)*PPTL(1,K1)+BETA(2)*PPTL(2,K1)+BETA(3)*PPTL(3,K1) AUXIL=GAMMA*(PPTL(4,K1)+BP*GAMMA/(GAMMA+1.)) PREST(1,K)=PPTL(1,K1) PPTL(1,K1)=PPTL(1,K1)+BETA(1)*AUXIL PREST(2,K)=PPTL(2,K1) PPTL(2,K1)=PPTL(2,K1)+BETA(2)*AUXIL PREST(3,K)=PPTL(3,K1) PPTL(3,K1)=PPTL(3,K1)+BETA(3)*AUXIL PREST(4,K)=PPTL(4,K1) PPTL(4,K1)=GAMMA*(PPTL(4,K1)+BP) 520 CONTINUE 500 CONTINUE C MATRIX ELEMENTS C --------------- IF ( NADD .EQ. 3 ) THEN IF ( IDPTL(IP) .EQ. 221 .OR. IDPTL(IP) .EQ. 331 ) GOTO 610 IF ( ABS(IDPTL(NPTL+1)) .LT. 20 .AND. * IDPTL(NPTL+1) .NE. 10 ) GOTO 620 ENDIF GOTO 800 C OMEG AND PHI DECAY C USE VECTORS IN REST FRAME C ------------------------------ 610 WT=(PPTL(5,NPTL+1)*PPTL(5,NPTL+2)*PPTL(5,NPTL+3))**2 * -(PPTL(5,NPTL+1)*DOT(2,3))**2 * -(PPTL(5,NPTL+2)*DOT(1,3))**2 * -(PPTL(5,NPTL+3)*DOT(1,2))**2 * +2.*DOT(1,2)*DOT(2,3)*DOT(1,3) IF ( WT .LT. RANGEN()*PPTL(5,IP)**6/108. ) GOTO 300 GOTO 800 C SEMILEPTONIC AND QUARK DECAYS C USE VECTORS IN REST FRAME, WHERE IP HAS (M,0,0,0) C INCLUDE W PROPAGATOR C ------------------------------------------------------ 620 WT=(PPTL(5,IP)*PREST(4,2))*DOT(1,3) S12=PPTL(5,NPTL+1)**2+PPTL(5,NPTL+2)**2+2.*DOT(1,2) S12MAX=PPTL(5,IP)**2 WT=WT*WPROP(S12MAX)/WPROP(S12) IF ( WT .LT. RANGEN()*PPTL(5,IP)**4/16. ) GOTO 300 GOTO 800 C ONE-PARTICLE DECAYS C ------------------- 700 CONTINUE DO 710 J=1,5 PPTL(J,NPTL+1)=PPTL(J,IP) 710 CONTINUE C SWAP PARTICLES AND ANTIPARTICLES IF IDPTL(IP)<0 C ----------------------------------------------- 800 CONTINUE IF ( IDPTL(IP).GE.0 .OR. ABS(IDPTL(IP)).EQ.20 ) GOTO 900 DO 810 I=1,NADD IDABS=ABS(IDPTL(NPTL+I)) IFL1=IDABS/1000 IFL2=MOD(IDABS/100,10) IFL3=MOD(IDABS/10,10) IF ( IFL1.EQ.0 .AND. IFL2.NE.0 .AND. IFL2.EQ.IFL3 ) GOTO 810 IF ( IDABS.EQ.9 .OR. IDABS.EQ.10 .OR. IDABS.EQ.20 ) GOTO 810 IF ( IDABS.EQ.29 .OR. IDABS.EQ.30 .OR. IDABS.EQ.40 ) GOTO 810 IDPTL(NPTL+I)=-IDPTL(NPTL+I) 810 CONTINUE 900 CONTINUE NPTL=NPTL+NADD IF ( NPTL .GT. MXPTL ) THEN CALL UTSTOP('JDECAYV: NPTL>MXPTL ') ENDIF NQK=0 IF ( ABS(IDPTL(NPTL)).LT.10 .OR. MOD(IDPTL(NPTL),100).EQ.0 ) THEN CALL UTSTOP('JDECAYV: DECAY PTCL IS PARTON ') ENDIF 1000 CONTINUE IF ( ISH .GE. 93 ) WRITE(IFCH,*)('-',L=1,79) ISH=ISH0 RETURN 9999 CALL UTSTOP('JDECAYV: MXPTL TOO SMALL ') RETURN END C======================================================================= SUBROUTINE JDECIN(LPRINT) C----------------------------------------------------------------------- C SETS UP /DKYTAB/ C----------------------------------------------------------------------- PARAMETER (MXDKY=2000) PARAMETER (MXLOOK=10000) PARAMETER (NDECTB=1171) COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /DKYTAB/ CBR(MXDKY),LOOK(MXLOOK),MODE(5,MXDKY) COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP LOGICAL NODCAY,NOETA,NOEVOL,NOHADR,NONUNU,NOPI0 COMMON /NODCAY/ NODCAY,NOETA,NOEVOL,NOHADR,NONUNU,NOPI0 COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT COMMON /WCO/ WGAM2,WMASS2 REAL DECTAB(7,NDECTB) INTEGER IMODE(6) CHARACTER*8 IBLANK,IDLABL,LMODE(6),LRES LOGICAL LPRINT DATA IBLANK/' '/ DATA ((DECTAB(I,J),I=1,7),J= 1, 18)/ * 110., .98850, 10., 10., 0., 0., 0. *, 110.,1.00000, 10., 12., -12., 0., 0. *, 220., .38000, 10., 10., 0., 0., 0. *, 220., .71000, 110., 110., 110., 0., 0. *, 220., .94600, 120.,-120., 110., 0., 0. *, 220., .99500, 120.,-120., 10., 0., 0. *, 220.,1.00000, 10., 12., -12., 0., 0. *, 330., .44100, 220., 120.,-120., 0., 0. *, 330., .66100, 220., 110., 110., 0., 0. *, 330., .95900, 111., 10., 0., 0., 0. *, 330., .98000, 221., 10., 0., 0., 0. *, 330.,1.00000, 10., 10., 0., 0., 0. *, 121.,1.00000, 120., 110., 0., 0., 0. *, 111., .99989, 120.,-120., 0., 0., 0. *, 111., .99993, 12., -12., 0., 0., 0. *, 111.,1.00000, 14., -14., 0., 0., 0. *, 221., .89900, 120.,-120., 110., 0., 0. *, 221., .91200, 120.,-120., 0., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J= 19, 36)/ * 221., .99992, 110., 10., 0., 0., 0. *, 221.,1.00000, 12., -12., 0., 0., 0. *, 331., .48600, 130.,-130., 0., 0., 0. *, 331., .83700, 230.,-230., 0., 0., 0. *, 331., .98400, 120.,-120., 110., 0., 0. *, 331., .99944, 220., 10., 0., 0., 0. *, 331., .99975, 12., -12., 0., 0., 0. *, 331.,1.00000, 14., -14., 0., 0., 0. *, 230., .50000, 20., 0., 0., 0., 0. *, 230.,1.00000, -20., 0., 0., 0., 0. *, 131., .66670, 230., 120., 0., 0., 0. *, 131.,1.00000, 130., 110., 0., 0., 0. *, 231., .66670, 130.,-120., 0., 0., 0. *, 231.,1.00000, 230., 110., 0., 0., 0. *, 240., .11000, 12., -11., 230., 0., 0. *, 240., .17000, 12., -11., 231., 0., 0. *, 240., .28000, 14., -13., 230., 0., 0. *, 240., .34000, 14., -13., 231., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J= 37, 54)/ * 240., .37800, 230.,-120., 0., 0., 0. *, 240., .56300, 230.,-121., 0., 0., 0. *, 240., .60800, 231.,-120., 0., 0., 0. *, 240., .62100, 230.,-120., 110., 0., 0. *, 240., .71000, 130.,-120.,-120., 0., 0. *, 240., .80100, 230.,-120.,-120., 120., 0. *, 240., .87900, 130.,-120.,-120., 110., 0. *, 240., .95400, 230.,-120., 110., 110., 0. *, 240., .96600, 230.,-130., 0., 0., 0. *, 240., .97600, 331.,-120., 0., 0., 0. *, 240., .98800,-130., 231., 0., 0., 0. *, 240.,1.00000,-131., 230., 0., 0., 0. *, 140., .04500, 12., -11., 130., 0., 0. *, 140., .07500, 12., -11., 131., 0., 0. *, 140., .12000, 14., -13., 130., 0., 0. *, 140., .15000, 14., -13., 131., 0., 0. *, 140., .20300, 130.,-120., 0., 0., 0. *, 140., .22700, 230., 110., 0., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J= 55, 72)/ * 140., .24700, 230., 220., 0., 0., 0. *, 140., .28900, 230., 221., 0., 0., 0. *, 140., .45100, 130.,-121., 0., 0., 0. *, 140., .53600, 131.,-120., 0., 0., 0. *, 140., .56200, 231., 110., 0., 0., 0. *, 140., .57600, 230., 111., 0., 0., 0. *, 140., .58700, 130.,-120., 110., 0., 0. *, 140., .60300, 230.,-120., 120., 0., 0. *, 140., .72700, 130.,-120.,-120., 120., 0. *, 140., .87600, 230.,-120., 120., 110., 0. *, 140., .96900, 130.,-120., 110., 110., 0. *, 140.,1.00000, 230., 110., 110., 110., 0. *, 340., .03250, 12., -11., 220., 0., 0. *, 340., .06500, 12., -11., 331., 0., 0. *, 340., .09750, 14., -13., 220., 0., 0. *, 340., .13000, 14., -13., 331., 0., 0. *, 340., .17900,-130., 230., 0., 0., 0. *, 340., .22800,-120., 220., 0., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J= 73, 90)/ * 340., .33800,-131., 230., 0., 0., 0. *, 340., .44800,-130., 231., 0., 0., 0. *, 340., .55800,-120., 331., 0., 0., 0. *, 340., .57500,-130., 230., 110., 0., 0. *, 340., .59200,-230., 230.,-120., 0., 0. *, 340., .69400,-130., 230.,-120., 120., 0. *, 340., .79600,-130., 230., 110., 110., 0. *, 340., .89800,-130., 130.,-120., 110., 0. *, 340.,1.00000,-230., 230.,-120., 110., 0. *, 241., .64000, 140.,-120., 0., 0., 0. *, 241., .92000, 240., 110., 0., 0., 0. *, 241.,1.00000, 240., 10., 0., 0., 0. *, 141., .55000, 140., 110., 0., 0., 0. *, 141.,1.00000, 140., 10., 0., 0., 0. *, 341.,1.00000, 340., 10., 0., 0., 0. *, 441., .07400, 12., -12., 0., 0., 0. *, 441., .14800, 14., -14., 0., 0., 0. *, 441., .15210,-121., 120., 0., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J= 91,108)/ * 441., .15620, 111., 110., 0., 0., 0. *, 441., .16020, 121.,-120., 0., 0., 0. *, 441., .16300,-121., 111., 120., 0., 0. *, 441., .16580, 121.,-121., 110., 0., 0. *, 441., .16860, 121., 111.,-120., 0., 0. *, 441., .28740, 120.,-120., 130.,-130., 0. *, 441., .40620, 110., 110., 130.,-130., 0. *, 441., .52500, 120.,-120., 120.,-120., 0. *, 441., .64380, 120.,-120., 110., 110., 0. *, 441., .76260, 110., 110., 110., 110., 0. *, 441., .88130, 120.,-120., 230.,-230., 0. *, 441.,1.00000, 110., 110., 230., 230., 0. *, 150., .06000, -12., 11., 140., 0., 0. *, 150., .12000, -12., 11., 141., 0., 0. *, 150., .18000, -14., 13., 140., 0., 0. *, 150., .24000, -14., 13., 141., 0., 0. *, 150., .25500, -16., 15., 140., 0., 0. *, 150., .27000, -16., 15., 141., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=109,126)/ * 150., .28050, 140., 120., 0., 0., 0. *, 150., .29100, 140., 121., 0., 0., 0. *, 150., .30150, 141., 120., 0., 0., 0. *, 150., .31200, 141., 121., 0., 0., 0. *, 150., .32650, 140.,-340., 0., 0., 0. *, 150., .34100, 140.,-341., 0., 0., 0. *, 150., .35550, 141.,-340., 0., 0., 0. *, 150., .37000, 141.,-341., 0., 0., 0. *, 150., .39800, 140., 120., 110., 0., 0. *, 150., .42600, 140., 120., 220., 0., 0. *, 150., .45400, 140., 120., 111., 0., 0. *, 150., .48200, 140., 120., 221., 0., 0. *, 150., .51000, 140., 121., 110., 0., 0. *, 150., .53800, 140., 121., 220., 0., 0. *, 150., .56600, 140., 121., 111., 0., 0. *, 150., .59400, 140., 121., 221., 0., 0. *, 150., .62200, 141., 120., 110., 0., 0. *, 150., .65000, 141., 120., 220., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=127,144)/ * 150., .67800, 141., 120., 111., 0., 0. *, 150., .70600, 141., 120., 221., 0., 0. *, 150., .73400, 141., 121., 110., 0., 0. *, 150., .76200, 141., 121., 220., 0., 0. *, 150., .79000, 141., 121., 111., 0., 0. *, 150., .81800, 141., 121., 221., 0., 0. *, 150., .83200, 140., 130.,-230., 0., 0. *, 150., .84600, 140., 130.,-231., 0., 0. *, 150., .86000, 140., 131.,-230., 0., 0. *, 150., .87400, 140., 131.,-231., 0., 0. *, 150., .88800, 141., 130.,-230., 0., 0. *, 150., .90200, 141., 130.,-231., 0., 0. *, 150., .91600, 141., 131.,-230., 0., 0. *, 150., .93000, 141., 131.,-231., 0., 0. *, 150., .93300, 140.,-140., 130., 0., 0. *, 150., .93600, 140.,-140., 131., 0., 0. *, 150., .93900, 140.,-141., 130., 0., 0. *, 150., .94200, 140.,-141., 131., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=145,162)/ * 150., .94500, 141.,-140., 130., 0., 0. *, 150., .94800, 141.,-140., 131., 0., 0. *, 150., .95100, 141.,-141., 130., 0., 0. *, 150., .95400, 141.,-141., 131., 0., 0. *, 150., .95700, 140.,-240., 230., 0., 0. *, 150., .96000, 140.,-240., 231., 0., 0. *, 150., .96300, 140.,-241., 230., 0., 0. *, 150., .96600, 140.,-241., 231., 0., 0. *, 150., .96900, 141.,-240., 230., 0., 0. *, 150., .97200, 141.,-240., 231., 0., 0. *, 150., .97500, 141.,-241., 230., 0., 0. *, 150., .97800, 141.,-241., 231., 0., 0. *, 150., .97950, 140.,-340., 330., 0., 0. *, 150., .98100, 140.,-340., 331., 0., 0. *, 150., .98250, 140.,-341., 331., 0., 0. *, 150., .98400, 140.,-341., 331., 0., 0. *, 150., .98550, 141.,-340., 330., 0., 0. *, 150., .98700, 141.,-340., 331., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=163,180)/ * 150., .98850, 141.,-341., 331., 0., 0. *, 150., .99000, 141.,-341., 331., 0., 0. *, 150., .99200, 441., 130., 110., 0., 0. *, 150., .99400, 441., 131., 110., 0., 0. *, 150., .99600, 441., 230., 120., 0., 0. *, 150., .99800, 441., 231., 120., 0., 0. *, 150., .99900, 441., 330., 130., 0., 0. *, 150.,1.00000, 441., 331., 130., 0., 0. *, 250., .06000, -12., 11., 240., 0., 0. *, 250., .12000, -12., 11., 241., 0., 0. *, 250., .18000, -14., 13., 240., 0., 0. *, 250., .24000, -14., 13., 241., 0., 0. *, 250., .25500, -16., 15., 240., 0., 0. *, 250., .27000, -16., 15., 241., 0., 0. *, 250., .28050, 240., 120., 0., 0., 0. *, 250., .29100, 240., 121., 0., 0., 0. *, 250., .30150, 241., 120., 0., 0., 0. *, 250., .31200, 241., 121., 0., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=181,198)/ * 250., .32650, 240.,-340., 0., 0., 0. *, 250., .34100, 240.,-341., 0., 0., 0. *, 250., .35550, 241.,-340., 0., 0., 0. *, 250., .37000, 241.,-341., 0., 0., 0. *, 250., .39800, 240., 120., 110., 0., 0. *, 250., .42600, 240., 120., 220., 0., 0. *, 250., .45400, 240., 120., 111., 0., 0. *, 250., .48200, 240., 120., 221., 0., 0. *, 250., .51000, 240., 121., 110., 0., 0. *, 250., .53800, 240., 121., 220., 0., 0. *, 250., .56600, 240., 121., 111., 0., 0. *, 250., .59400, 240., 121., 221., 0., 0. *, 250., .62200, 241., 120., 110., 0., 0. *, 250., .65000, 241., 120., 220., 0., 0. *, 250., .67800, 241., 120., 111., 0., 0. *, 250., .70600, 241., 120., 221., 0., 0. *, 250., .73400, 241., 121., 110., 0., 0. *, 250., .76200, 241., 121., 220., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=199,216)/ * 250., .79000, 241., 121., 111., 0., 0. *, 250., .81800, 241., 121., 221., 0., 0. *, 250., .83200, 240., 130.,-230., 0., 0. *, 250., .84600, 240., 130.,-231., 0., 0. *, 250., .86000, 240., 131.,-230., 0., 0. *, 250., .87400, 240., 131.,-231., 0., 0. *, 250., .88800, 241., 130.,-230., 0., 0. *, 250., .90200, 241., 130.,-231., 0., 0. *, 250., .91600, 241., 131.,-230., 0., 0. *, 250., .93000, 241., 131.,-231., 0., 0. *, 250., .93300, 240.,-140., 130., 0., 0. *, 250., .93600, 240.,-140., 131., 0., 0. *, 250., .93900, 240.,-141., 130., 0., 0. *, 250., .94200, 240.,-141., 131., 0., 0. *, 250., .94500, 241.,-140., 130., 0., 0. *, 250., .94800, 241.,-140., 131., 0., 0. *, 250., .95100, 241.,-141., 130., 0., 0. *, 250., .95400, 241.,-141., 131., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=217,234)/ * 250., .95700, 240.,-240., 230., 0., 0. *, 250., .96000, 240.,-240., 231., 0., 0. *, 250., .96300, 240.,-241., 230., 0., 0. *, 250., .96600, 240.,-241., 231., 0., 0. *, 250., .96900, 241.,-240., 230., 0., 0. *, 250., .97200, 241.,-240., 231., 0., 0. *, 250., .97500, 241.,-241., 230., 0., 0. *, 250., .97800, 241.,-241., 231., 0., 0. *, 250., .97950, 240.,-340., 330., 0., 0. *, 250., .98100, 240.,-340., 331., 0., 0. *, 250., .98250, 240.,-341., 331., 0., 0. *, 250., .98400, 240.,-341., 331., 0., 0. *, 250., .98550, 241.,-340., 330., 0., 0. *, 250., .98700, 241.,-340., 331., 0., 0. *, 250., .98850, 241.,-341., 331., 0., 0. *, 250., .99000, 241.,-341., 331., 0., 0. *, 250., .99200, 441., 130.,-120., 0., 0. *, 250., .99400, 441., 131.,-120., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=235,252)/ * 250., .99600, 441., 230., 220., 0., 0. *, 250., .99800, 441., 231., 221., 0., 0. *, 250., .99900, 441., 330., 230., 0., 0. *, 250.,1.00000, 441., 331., 230., 0., 0. *, 350., .06000, -12., 11., 340., 0., 0. *, 350., .12000, -12., 11., 341., 0., 0. *, 350., .18000, -14., 13., 340., 0., 0. *, 350., .24000, -14., 13., 341., 0., 0. *, 350., .25500, -16., 15., 340., 0., 0. *, 350., .27000, -16., 15., 341., 0., 0. *, 350., .28050, 340., 120., 0., 0., 0. *, 350., .29100, 340., 121., 0., 0., 0. *, 350., .30150, 341., 120., 0., 0., 0. *, 350., .31200, 341., 121., 0., 0., 0. *, 350., .32650, 340.,-340., 0., 0., 0. *, 350., .34100, 340.,-341., 0., 0., 0. *, 350., .35550, 341.,-340., 0., 0., 0. *, 350., .37000, 341.,-341., 0., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=253,270)/ * 350., .39800, 340., 120., 110., 0., 0. *, 350., .42600, 340., 120., 220., 0., 0. *, 350., .45400, 340., 120., 111., 0., 0. *, 350., .48200, 340., 120., 221., 0., 0. *, 350., .51000, 340., 121., 110., 0., 0. *, 350., .53800, 340., 121., 220., 0., 0. *, 350., .56600, 340., 121., 111., 0., 0. *, 350., .59400, 340., 121., 221., 0., 0. *, 350., .62200, 341., 120., 110., 0., 0. *, 350., .65000, 341., 120., 220., 0., 0. *, 350., .67800, 341., 120., 111., 0., 0. *, 350., .70600, 341., 120., 221., 0., 0. *, 350., .73400, 341., 121., 110., 0., 0. *, 350., .76200, 341., 121., 220., 0., 0. *, 350., .79000, 341., 121., 111., 0., 0. *, 350., .81800, 341., 121., 221., 0., 0. *, 350., .83200, 340., 130.,-230., 0., 0. *, 350., .84600, 340., 130.,-231., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=271,288)/ * 350., .86000, 340., 131.,-230., 0., 0. *, 350., .87400, 340., 131.,-231., 0., 0. *, 350., .88800, 341., 130.,-230., 0., 0. *, 350., .90200, 341., 130.,-231., 0., 0. *, 350., .91600, 341., 131.,-230., 0., 0. *, 350., .93000, 341., 131.,-231., 0., 0. *, 350., .93300, 340.,-140., 130., 0., 0. *, 350., .93600, 340.,-140., 131., 0., 0. *, 350., .93900, 340.,-141., 130., 0., 0. *, 350., .94200, 340.,-141., 131., 0., 0. *, 350., .94500, 341.,-140., 130., 0., 0. *, 350., .94800, 341.,-140., 131., 0., 0. *, 350., .95100, 341.,-141., 130., 0., 0. *, 350., .95400, 341.,-141., 131., 0., 0. *, 350., .95700, 340.,-240., 230., 0., 0. *, 350., .96000, 340.,-240., 231., 0., 0. *, 350., .96300, 340.,-241., 230., 0., 0. *, 350., .96600, 340.,-241., 231., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=289,306)/ * 350., .96900, 341.,-240., 230., 0., 0. *, 350., .97200, 341.,-240., 231., 0., 0. *, 350., .97500, 341.,-241., 230., 0., 0. *, 350., .97800, 341.,-241., 231., 0., 0. *, 350., .97950, 340.,-340., 330., 0., 0. *, 350., .98100, 340.,-340., 331., 0., 0. *, 350., .98250, 340.,-341., 331., 0., 0. *, 350., .98400, 340.,-341., 331., 0., 0. *, 350., .98550, 341.,-340., 330., 0., 0. *, 350., .98700, 341.,-340., 331., 0., 0. *, 350., .98850, 341.,-341., 331., 0., 0. *, 350., .99000, 341.,-341., 331., 0., 0. *, 350., .99200, 441., 130.,-130., 0., 0. *, 350., .99400, 441., 131.,-130., 0., 0. *, 350., .99600, 441., 230.,-230., 0., 0. *, 350., .99800, 441., 231.,-230., 0., 0. *, 350., .99900, 441., 330., 330., 0., 0. *, 350.,1.00000, 441., 331., 331., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=307,324)/ * 160., .33330, -1., 2., -5., 0., 0. *, 160., .66660, -4., 3., -5., 0., 0. *, 160., .77770, -11., 12., -5., 0., 0. *, 160., .88880, -13., 14., -5., 0., 0. *, 160.,1.00000, -15., 16., -5., 0., 0. *, 260., .33330, -1., 2., -5., 0., 0. *, 260., .66660, -4., 3., -5., 0., 0. *, 260., .77770, -11., 12., -5., 0., 0. *, 260., .88880, -13., 14., -5., 0., 0. *, 260.,1.00000, -15., 16., -5., 0., 0. *, 360., .33330, -1., 2., -5., 0., 0. *, 360., .66660, -4., 3., -5., 0., 0. *, 360., .77770, -11., 12., -5., 0., 0. *, 360., .88880, -13., 14., -5., 0., 0. *, 360.,1.00000, -15., 16., -5., 0., 0. *, 151.,1.00000, 150., 10., 0., 0., 0. *, 251.,1.00000, 250., 10., 0., 0., 0. *, 351.,1.00000, 350., 10., 0., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=325,342)/ * 161.,1.00000, 160., 10., 0., 0., 0. *, 261.,1.00000, 260., 10., 0., 0., 0. *, 361.,1.00000, 360., 10., 0., 0., 0. *,1230.,1.00000,2130., 10., 0., 0., 0. *,1111.,1.00000,1120., 120., 0., 0., 0. *,1121., .66670,1120., 110., 0., 0., 0. *,1121.,1.00000,1220., 120., 0., 0., 0. *,1221., .66670,1220., 110., 0., 0., 0. *,1221.,1.00000,1120.,-120., 0., 0., 0. *,2221.,1.00000,1220.,-120., 0., 0., 0. *,1131., .88000,2130., 120., 0., 0., 0. *,1131., .94000,1130., 110., 0., 0., 0. *,1131.,1.00000,1230., 120., 0., 0., 0. *,1231., .88000,2130., 110., 0., 0., 0. *,1231., .94000,1130.,-120., 0., 0., 0. *,1231.,1.00000,2230., 120., 0., 0., 0. *,2231., .88000,2130.,-120., 0., 0., 0. *,2231., .94000,1230.,-120., 0., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=343,360)/ * 2231.,1.00000,2230., 110., 0., 0., 0. *,1331., .66670,2330., 120., 0., 0., 0. *,1331.,1.00000,1330., 110., 0., 0., 0. *,2331., .66670,1330.,-120., 0., 0., 0. *,2331.,1.00000,2330., 110., 0., 0., 0. *, 16., .18000, 12., -11., 15., 0., 0. *, 16., .36000, 14., -13., 15., 0., 0. *, 16., .45100,-120., 15., 0., 0., 0. *, 16., .66000,-121., 15., 0., 0., 0. *, 16., .78000, 110., 110.,-120., 15., 0. *, 16., .83600, 120.,-120.,-120., 15., 0. *, 16.,1.00000, 120., 110.,-120.,-120., 15. *,2140., .03750, -12., 11.,2130., 0., 0. *,2140., .07500, -12., 11.,1231., 0., 0. *,2140., .11250, -14., 13.,2130., 0., 0. *,2140., .15000, -14., 13.,1231., 0., 0. *,2140., .18200,2130., 120., 0., 0., 0. *,2140., .21300,1230., 110., 0., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=361,378)/ * 2140., .24400,1120.,-230., 0., 0., 0. *,2140., .29500,1131., 110., 0., 0., 0. *,2140., .34600,1231., 120., 0., 0., 0. *,2140., .39700,1121.,-230., 0., 0., 0. *,2140., .44800,1111.,-130., 0., 0., 0. *,2140., .49900,1130., 111., 0., 0., 0. *,2140., .55000,1230., 121., 0., 0., 0. *,2140., .60100,1120.,-231., 0., 0., 0. *,2140., .65800,1120.,-230., 120.,-120., 0. *,2140., .71500,1120.,-230., 110., 110., 0. *,2140., .77200,1120.,-130., 120., 110., 0. *,2140., .82900,1220.,-230., 120., 110., 0. *,2140., .88600,1220.,-130., 120., 120., 0. *,2140., .94300,2130., 120., 120.,-120., 0. *,2140.,1.00000,2130., 120., 110., 110., 0. *,1140.,1.00000,2140., 120., 0., 0., 0. *,1240.,1.00000,2140., 110., 0., 0., 0. *,2240.,1.00000,2140.,-120., 0., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=379,396)/ * 1340., .03750, -12., 11.,1330., 0., 0. *,1340., .07500, -12., 11.,1331., 0., 0. *,1340., .11250, -14., 13.,1330., 0., 0. *,1340., .15000, -14., 13.,1331., 0., 0. *,1340., .19900,1330., 120., 0., 0., 0. *,1340., .24800,1231.,-230., 0., 0., 0. *,1340., .28800,1330., 120., 0., 0., 0. *,1340., .32800,1131.,-230., 0., 0., 0. *,1340., .36800,1330., 121., 0., 0., 0. *,1340., .40800,1130.,-230., 0., 0., 0. *,1340., .44800,1330., 120., 110., 0., 0. *,1340., .48800,2330., 120., 120., 0., 0. *,1340., .52800,1130.,-130., 120., 0., 0. *,1340., .56800,1130.,-230., 110., 0., 0. *,1340., .60800,1230.,-230., 120., 0., 0. *,1340., .66400,2130.,-230., 120., 110., 0. *,1340., .72000,2130.,-130., 120., 120., 0. *,1340., .77600,1130.,-230., 120., 120., 0./ DATA ((DECTAB(I,J),I=1,7),J=397,414)/ * 1340., .83200,1130.,-230., 110., 110., 0. *,1340., .88800,1330., 120., 120.,-120., 0. *,1340., .94400,1330., 120., 110., 110., 0. *,1340.,1.00000,2330., 120., 120., 110., 0. *,3140., .03750, -12., 11.,1330., 0., 0. *,3140., .07500, -12., 11.,1331., 0., 0. *,3140., .11250, -14., 13.,1330., 0., 0. *,3140., .15000, -14., 13.,1331., 0., 0. *,3140., .19900,1330., 120., 0., 0., 0. *,3140., .24800,1231.,-230., 0., 0., 0. *,3140., .28800,1330., 120., 0., 0., 0. *,3140., .32800,1131.,-230., 0., 0., 0. *,3140., .36800,1330., 121., 0., 0., 0. *,3140., .40800,1130.,-230., 0., 0., 0. *,3140., .44800,1330., 120., 110., 0., 0. *,3140., .48800,2330., 120., 120., 0., 0. *,3140., .52800,1130.,-130., 120., 0., 0. *,3140., .56800,1130.,-230., 110., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=415,432)/ * 3140., .60800,1230.,-230., 120., 0., 0. *,3140., .66400,2130.,-230., 120., 110., 0. *,3140., .72000,2130.,-130., 120., 120., 0. *,3140., .77600,1130.,-230., 120., 120., 0. *,3140., .83200,1130.,-230., 110., 110., 0. *,3140., .88800,1330., 120., 120.,-120., 0. *,3140., .94400,1330., 120., 110., 110., 0. *,3140.,1.00000,2330., 120., 120., 110., 0. *,2340., .03750, -12., 11.,2330., 0., 0. *,2340., .07500, -12., 11.,2331., 0., 0. *,2340., .11250, -14., 13.,2330., 0., 0. *,2340., .15000, -14., 13.,2331., 0., 0. *,2340., .17500,2330., 120., 0., 0., 0. *,2340., .20000,1330., 110., 0., 0., 0. *,2340., .22500,1130.,-130., 0., 0., 0. *,2340., .25000,1230.,-230., 0., 0., 0. *,2340., .29500,2331., 120., 0., 0., 0. *,2340., .34000,1331., 110., 0., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=433,450)/ * 2340., .38500,1131.,-130., 0., 0., 0. *,2340., .43000,1231.,-230., 0., 0., 0. *,2340., .47500,2330., 121., 0., 0., 0. *,2340., .52000,1330., 111., 0., 0., 0. *,2340., .56500,1130.,-131., 0., 0., 0. *,2340., .61000,1230.,-231., 0., 0., 0. *,2340., .64900,2130.,-230., 120.,-120., 0. *,2340., .68800,2130.,-230., 110., 110., 0. *,2340., .72700,2130.,-130., 120., 110., 0. *,2340., .76600,1130.,-230.,-120., 110., 0. *,2340., .80500,1130.,-130., 120.,-120., 0. *,2340., .84400,1130.,-130., 110., 110., 0. *,2340., .88300,1330., 120.,-120., 110., 0. *,2340., .92200,1330., 110., 110., 110., 0. *,2340., .96100,2330., 120., 120.,-120., 0. *,2340.,1.00000,2330., 120., 110., 110., 0. *,3240., .03750, -12., 11.,2330., 0., 0. *,3240., .07500, -12., 11.,2331., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=451,468)/ * 3240., .11250, -14., 13.,2330., 0., 0. *,3240., .15000, -14., 13.,2331., 0., 0. *,3240., .17500,2330., 120., 0., 0., 0. *,3240., .20000,1330., 110., 0., 0., 0. *,3240., .22500,1130.,-130., 0., 0., 0. *,3240., .25000,1230.,-230., 0., 0., 0. *,3240., .29500,2331., 120., 0., 0., 0. *,3240., .34000,1331., 110., 0., 0., 0. *,3240., .38500,1131.,-130., 0., 0., 0. *,3240., .43000,1231.,-230., 0., 0., 0. *,3240., .47500,2330., 121., 0., 0., 0. *,3240., .52000,1330., 111., 0., 0., 0. *,3240., .56500,1130.,-131., 0., 0., 0. *,3240., .61000,1230.,-231., 0., 0., 0. *,3240., .64900,2130.,-230., 120.,-120., 0. *,3240., .68800,2130.,-230., 110., 110., 0. *,3240., .72700,2130.,-130., 120., 110., 0. *,3240., .76600,1130.,-230.,-120., 110., 0./ DATA ((DECTAB(I,J),I=1,7),J=469,486)/ * 3240., .80500,1130.,-130., 120.,-120., 0. *,3240., .84400,1130.,-130., 110., 110., 0. *,3240., .88300,1330., 120.,-120., 110., 0. *,3240., .92200,1330., 110., 110., 110., 0. *,3240., .96100,2330., 120., 120.,-120., 0. *,3240.,1.00000,2330., 120., 110., 110., 0. *,3340., .07500, -12., 11.,3331., 0., 0. *,3340., .15000, -12., 11.,3331., 0., 0. *,3340., .25000,1330.,-230., 0., 0., 0. *,3340., .31000,3331., 120., 0., 0., 0. *,3340., .37000,1331.,-230., 0., 0., 0. *,3340., .43000,1330.,-231., 0., 0., 0. *,3340., .49000,2330.,-230., 120., 0., 0. *,3340., .55000,1330.,-230., 110., 0., 0. *,3340., .61000,1330.,-130., 120., 0., 0. *,3340., .67500,3331., 120., 120.,-120., 0. *,3340., .74000,3331., 120., 110., 110., 0. *,3340., .80500,1330.,-230., 120.,-120., 0./ DATA ((DECTAB(I,J),I=1,7),J=487,504)/ * 3340., .87000,1330.,-230., 110., 110., 0. *,3340., .93500,2330.,-230., 120., 110., 0. *,3340.,1.00000,2330.,-130., 120., 120., 0. *,1141.,1.00000,2140., 120., 0., 0., 0. *,1241.,1.00000,2140., 110., 0., 0., 0. *,2241.,1.00000,2140.,-120., 0., 0., 0. *,1341., .66670,2340., 120., 0., 0., 0. *,1341.,1.00000,1340., 110., 0., 0., 0. *,2341., .66670,1340.,-120., 0., 0., 0. *,2341.,1.00000,2340., 110., 0., 0., 0. *,3341.,1.00000,3340., 110., 0., 0., 0. *,1150., .06000, 12., -11.,1140., 0., 0. *,1150., .12000, 12., -11.,1141., 0., 0. *,1150., .18000, 14., -13.,1140., 0., 0. *,1150., .24000, 14., -13.,1141., 0., 0. *,1150., .25500, 16., -15.,1140., 0., 0. *,1150., .27000, 16., -15.,1141., 0., 0. *,1150., .28925,1140.,-120., 0., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=505,522)/ * 1150., .30850,1140.,-121., 0., 0., 0. *,1150., .32775,1141.,-120., 0., 0., 0. *,1150., .34700,1141.,-121., 0., 0., 0. *,1150., .35775,1140., 340., 0., 0., 0. *,1150., .36850,1140., 341., 0., 0., 0. *,1150., .37925,1141., 340., 0., 0., 0. *,1150., .39000,1141., 341., 0., 0., 0. *,1150., .42050,1140.,-120., 110., 0., 0. *,1150., .45100,1140.,-120., 220., 0., 0. *,1150., .48150,1140.,-120., 111., 0., 0. *,1150., .51200,1140.,-120., 221., 0., 0. *,1150., .54250,1140.,-121., 110., 0., 0. *,1150., .57300,1140.,-121., 220., 0., 0. *,1150., .60350,1140.,-121., 111., 0., 0. *,1150., .63400,1140.,-121., 221., 0., 0. *,1150., .66450,1141.,-120., 110., 0., 0. *,1150., .69500,1141.,-120., 220., 0., 0. *,1150., .72550,1141.,-120., 111., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=523,540)/ * 1150., .75600,1141.,-120., 221., 0., 0. *,1150., .78650,1141.,-121., 110., 0., 0. *,1150., .81700,1141.,-121., 220., 0., 0. *,1150., .84750,1141.,-121., 111., 0., 0. *,1150., .87800,1141.,-121., 221., 0., 0. *,1150., .89325,1140.,-130., 230., 0., 0. *,1150., .90850,1140.,-130., 231., 0., 0. *,1150., .92375,1140.,-131., 230., 0., 0. *,1150., .93900,1140.,-131., 231., 0., 0. *,1150., .95425,1141.,-130., 230., 0., 0. *,1150., .96950,1141.,-130., 231., 0., 0. *,1150., .98475,1141.,-131., 230., 0., 0. *,1150.,1.00000,1141.,-131., 231., 0., 0. *,1250., .06000, 12., -11.,1240., 0., 0. *,1250., .12000, 12., -11.,1241., 0., 0. *,1250., .18000, 14., -13.,1240., 0., 0. *,1250., .24000, 14., -13.,1241., 0., 0. *,1250., .25500, 16., -15.,1240., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=541,558)/ * 1250., .27000, 16., -15.,1241., 0., 0. *,1250., .28925,1240.,-120., 0., 0., 0. *,1250., .30850,1240.,-121., 0., 0., 0. *,1250., .32775,1241.,-120., 0., 0., 0. *,1250., .34700,1241.,-121., 0., 0., 0. *,1250., .35775,1240., 340., 0., 0., 0. *,1250., .36850,1240., 341., 0., 0., 0. *,1250., .37925,1241., 340., 0., 0., 0. *,1250., .39000,1241., 341., 0., 0., 0. *,1250., .42050,1240.,-120., 110., 0., 0. *,1250., .45100,1240.,-120., 220., 0., 0. *,1250., .48150,1240.,-120., 111., 0., 0. *,1250., .51200,1240.,-120., 221., 0., 0. *,1250., .54250,1240.,-121., 110., 0., 0. *,1250., .57300,1240.,-121., 220., 0., 0. *,1250., .60350,1240.,-121., 111., 0., 0. *,1250., .63400,1240.,-121., 221., 0., 0. *,1250., .66450,1241.,-120., 110., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=559,576)/ * 1250., .69500,1241.,-120., 220., 0., 0. *,1250., .72550,1241.,-120., 111., 0., 0. *,1250., .75600,1241.,-120., 221., 0., 0. *,1250., .78650,1241.,-121., 110., 0., 0. *,1250., .81700,1241.,-121., 220., 0., 0. *,1250., .84750,1241.,-121., 111., 0., 0. *,1250., .87800,1241.,-121., 221., 0., 0. *,1250., .89325,1240.,-130., 230., 0., 0. *,1250., .90850,1240.,-130., 231., 0., 0. *,1250., .92375,1240.,-131., 230., 0., 0. *,1250., .93900,1240.,-131., 231., 0., 0. *,1250., .95425,1241.,-130., 230., 0., 0. *,1250., .96950,1241.,-130., 231., 0., 0. *,1250., .98475,1241.,-131., 230., 0., 0. *,1250.,1.00000,1241.,-131., 231., 0., 0. *,1350., .06000, 12., -11.,1340., 0., 0. *,1350., .12000, 12., -11.,1341., 0., 0. *,1350., .18000, 14., -13.,1340., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=577,594)/ * 1350., .24000, 14., -13.,1341., 0., 0. *,1350., .25500, 16., -15.,1340., 0., 0. *,1350., .27000, 16., -15.,1341., 0., 0. *,1350., .28925,1340.,-120., 0., 0., 0. *,1350., .30850,1340.,-121., 0., 0., 0. *,1350., .32775,1341.,-120., 0., 0., 0. *,1350., .34700,1341.,-121., 0., 0., 0. *,1350., .35775,1340., 340., 0., 0., 0. *,1350., .36850,1340., 341., 0., 0., 0. *,1350., .37925,1341., 340., 0., 0., 0. *,1350., .39000,1341., 341., 0., 0., 0. *,1350., .42050,1340.,-120., 110., 0., 0. *,1350., .45100,1340.,-120., 220., 0., 0. *,1350., .48150,1340.,-120., 111., 0., 0. *,1350., .51200,1340.,-120., 221., 0., 0. *,1350., .54250,1340.,-121., 110., 0., 0. *,1350., .57300,1340.,-121., 220., 0., 0. *,1350., .60350,1340.,-121., 111., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=595,612)/ * 1350., .63400,1340.,-121., 221., 0., 0. *,1350., .66450,1341.,-120., 110., 0., 0. *,1350., .69500,1341.,-120., 220., 0., 0. *,1350., .72550,1341.,-120., 111., 0., 0. *,1350., .75600,1341.,-120., 221., 0., 0. *,1350., .78650,1341.,-121., 110., 0., 0. *,1350., .81700,1341.,-121., 220., 0., 0. *,1350., .84750,1341.,-121., 111., 0., 0. *,1350., .87800,1341.,-121., 221., 0., 0. *,1350., .89325,1340.,-130., 230., 0., 0. *,1350., .90850,1340.,-130., 231., 0., 0. *,1350., .92375,1340.,-131., 230., 0., 0. *,1350., .93900,1340.,-131., 231., 0., 0. *,1350., .95425,1341.,-130., 230., 0., 0. *,1350., .96950,1341.,-130., 231., 0., 0. *,1350., .98475,1341.,-131., 230., 0., 0. *,1350.,1.00000,1341.,-131., 231., 0., 0. *,2150., .06000, 12., -11.,2140., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=613,630)/ * 2150., .12000, 12., -11.,1241., 0., 0. *,2150., .18000, 14., -13.,2140., 0., 0. *,2150., .24000, 14., -13.,1241., 0., 0. *,2150., .25500, 16., -15.,2140., 0., 0. *,2150., .27000, 16., -15.,1241., 0., 0. *,2150., .28925,2140.,-120., 0., 0., 0. *,2150., .30850,2140.,-121., 0., 0., 0. *,2150., .32775,1241.,-120., 0., 0., 0. *,2150., .34700,1241.,-121., 0., 0., 0. *,2150., .35775,2140., 340., 0., 0., 0. *,2150., .36850,2140., 341., 0., 0., 0. *,2150., .37925,1241., 340., 0., 0., 0. *,2150., .39000,1241., 341., 0., 0., 0. *,2150., .42050,2140.,-120., 110., 0., 0. *,2150., .45100,2140.,-120., 220., 0., 0. *,2150., .48150,2140.,-120., 111., 0., 0. *,2150., .51200,2140.,-120., 221., 0., 0. *,2150., .54250,2140.,-121., 110., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=631,648)/ * 2150., .57300,2140.,-121., 220., 0., 0. *,2150., .60350,2140.,-121., 111., 0., 0. *,2150., .63400,2140.,-121., 221., 0., 0. *,2150., .66450,1241.,-120., 110., 0., 0. *,2150., .69500,1241.,-120., 220., 0., 0. *,2150., .72550,1241.,-120., 111., 0., 0. *,2150., .75600,1241.,-120., 221., 0., 0. *,2150., .78650,1241.,-121., 110., 0., 0. *,2150., .81700,1241.,-121., 220., 0., 0. *,2150., .84750,1241.,-121., 111., 0., 0. *,2150., .87800,1241.,-121., 221., 0., 0. *,2150., .89325,2140.,-130., 230., 0., 0. *,2150., .90850,2140.,-130., 231., 0., 0. *,2150., .92375,2140.,-131., 230., 0., 0. *,2150., .93900,2140.,-131., 231., 0., 0. *,2150., .95425,1241.,-130., 230., 0., 0. *,2150., .96950,1241.,-130., 231., 0., 0. *,2150., .98475,1241.,-131., 230., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=649,666)/ * 2150.,1.00000,1241.,-131., 231., 0., 0. *,2250., .06000, 12., -11.,2240., 0., 0. *,2250., .12000, 12., -11.,2241., 0., 0. *,2250., .18000, 14., -13.,2240., 0., 0. *,2250., .24000, 14., -13.,2241., 0., 0. *,2250., .25500, 16., -15.,2240., 0., 0. *,2250., .27000, 16., -15.,2241., 0., 0. *,2250., .28925,2240.,-120., 0., 0., 0. *,2250., .30850,2240.,-121., 0., 0., 0. *,2250., .32775,2241.,-120., 0., 0., 0. *,2250., .34700,2241.,-121., 0., 0., 0. *,2250., .35775,2240., 340., 0., 0., 0. *,2250., .36850,2240., 341., 0., 0., 0. *,2250., .37925,2241., 340., 0., 0., 0. *,2250., .39000,2241., 341., 0., 0., 0. *,2250., .42050,2240.,-120., 110., 0., 0. *,2250., .45100,2240.,-120., 220., 0., 0. *,2250., .48150,2240.,-120., 111., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=667,684)/ * 2250., .51200,2240.,-120., 221., 0., 0. *,2250., .54250,2240.,-121., 110., 0., 0. *,2250., .57300,2240.,-121., 220., 0., 0. *,2250., .60350,2240.,-121., 111., 0., 0. *,2250., .63400,2240.,-121., 221., 0., 0. *,2250., .66450,2241.,-120., 110., 0., 0. *,2250., .69500,2241.,-120., 220., 0., 0. *,2250., .72550,2241.,-120., 111., 0., 0. *,2250., .75600,2241.,-120., 221., 0., 0. *,2250., .78650,2241.,-121., 110., 0., 0. *,2250., .81700,2241.,-121., 220., 0., 0. *,2250., .84750,2241.,-121., 111., 0., 0. *,2250., .87800,2241.,-121., 221., 0., 0. *,2250., .89325,2240.,-130., 230., 0., 0. *,2250., .90850,2240.,-130., 231., 0., 0. *,2250., .92375,2240.,-131., 230., 0., 0. *,2250., .93900,2240.,-131., 231., 0., 0. *,2250., .95425,2241.,-130., 230., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=685,702)/ * 2250., .96950,2241.,-130., 231., 0., 0. *,2250., .98475,2241.,-131., 230., 0., 0. *,2250.,1.00000,2241.,-131., 231., 0., 0. *,2350., .06000, 12., -11.,2340., 0., 0. *,2350., .12000, 12., -11.,2341., 0., 0. *,2350., .18000, 14., -13.,2340., 0., 0. *,2350., .24000, 14., -13.,2341., 0., 0. *,2350., .25500, 16., -15.,2340., 0., 0. *,2350., .27000, 16., -15.,2341., 0., 0. *,2350., .28925,2340.,-120., 0., 0., 0. *,2350., .30850,2340.,-121., 0., 0., 0. *,2350., .32775,2341.,-120., 0., 0., 0. *,2350., .34700,2341.,-121., 0., 0., 0. *,2350., .35775,2340., 340., 0., 0., 0. *,2350., .36850,2340., 341., 0., 0., 0. *,2350., .37925,2341., 340., 0., 0., 0. *,2350., .39000,2341., 341., 0., 0., 0. *,2350., .42050,2340.,-120., 110., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=703,720)/ * 2350., .45100,2340.,-120., 220., 0., 0. *,2350., .48150,2340.,-120., 111., 0., 0. *,2350., .51200,2340.,-120., 221., 0., 0. *,2350., .54250,2340.,-121., 110., 0., 0. *,2350., .57300,2340.,-121., 220., 0., 0. *,2350., .60350,2340.,-121., 111., 0., 0. *,2350., .63400,2340.,-121., 221., 0., 0. *,2350., .66450,2341.,-120., 110., 0., 0. *,2350., .69500,2341.,-120., 220., 0., 0. *,2350., .72550,2341.,-120., 111., 0., 0. *,2350., .75600,2341.,-120., 221., 0., 0. *,2350., .78650,2341.,-121., 110., 0., 0. *,2350., .81700,2341.,-121., 220., 0., 0. *,2350., .84750,2341.,-121., 111., 0., 0. *,2350., .87800,2341.,-121., 221., 0., 0. *,2350., .89325,2340.,-130., 230., 0., 0. *,2350., .90850,2340.,-130., 231., 0., 0. *,2350., .92375,2340.,-131., 230., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=721,738)/ * 2350., .93900,2340.,-131., 231., 0., 0. *,2350., .95425,2341.,-130., 230., 0., 0. *,2350., .96950,2341.,-130., 231., 0., 0. *,2350., .98475,2341.,-131., 230., 0., 0. *,2350.,1.00000,2341.,-131., 231., 0., 0. *,3150., .06000, 12., -11.,3140., 0., 0. *,3150., .12000, 12., -11.,1341., 0., 0. *,3150., .18000, 14., -13.,3140., 0., 0. *,3150., .24000, 14., -13.,1341., 0., 0. *,3150., .25500, 16., -15.,3140., 0., 0. *,3150., .27000, 16., -15.,1341., 0., 0. *,3150., .28925,3140.,-120., 0., 0., 0. *,3150., .30850,3140.,-121., 0., 0., 0. *,3150., .32775,1341.,-120., 0., 0., 0. *,3150., .34700,1341.,-121., 0., 0., 0. *,3150., .35775,3140., 340., 0., 0., 0. *,3150., .36850,3140., 341., 0., 0., 0. *,3150., .37925,1341., 340., 0., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=739,756)/ * 3150., .39000,1341., 341., 0., 0., 0. *,3150., .42050,3140.,-120., 110., 0., 0. *,3150., .45100,3140.,-120., 220., 0., 0. *,3150., .48150,3140.,-120., 111., 0., 0. *,3150., .51200,3140.,-120., 221., 0., 0. *,3150., .54250,3140.,-121., 110., 0., 0. *,3150., .57300,3140.,-121., 220., 0., 0. *,3150., .60350,3140.,-121., 111., 0., 0. *,3150., .63400,3140.,-121., 221., 0., 0. *,3150., .66450,1341.,-120., 110., 0., 0. *,3150., .69500,1341.,-120., 220., 0., 0. *,3150., .72550,1341.,-120., 111., 0., 0. *,3150., .75600,1341.,-120., 221., 0., 0. *,3150., .78650,1341.,-121., 110., 0., 0. *,3150., .81700,1341.,-121., 220., 0., 0. *,3150., .84750,1341.,-121., 111., 0., 0. *,3150., .87800,1341.,-121., 221., 0., 0. *,3150., .89325,3140.,-130., 230., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=757,774)/ * 3150., .90850,3140.,-130., 231., 0., 0. *,3150., .92375,3140.,-131., 230., 0., 0. *,3150., .93900,3140.,-131., 231., 0., 0. *,3150., .95425,1341.,-130., 230., 0., 0. *,3150., .96950,1341.,-130., 231., 0., 0. *,3150., .98475,1341.,-131., 230., 0., 0. *,3150.,1.00000,1341.,-131., 231., 0., 0. *,3250., .06000, 12., -11.,3240., 0., 0. *,3250., .12000, 12., -11.,2341., 0., 0. *,3250., .18000, 14., -13.,3240., 0., 0. *,3250., .24000, 14., -13.,2341., 0., 0. *,3250., .25500, 16., -15.,3240., 0., 0. *,3250., .27000, 16., -15.,2341., 0., 0. *,3250., .28925,3240.,-120., 0., 0., 0. *,3250., .30850,3240.,-121., 0., 0., 0. *,3250., .32775,2341.,-120., 0., 0., 0. *,3250., .34700,2341.,-121., 0., 0., 0. *,3250., .35775,3240., 340., 0., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=775,792)/ * 3250., .36850,3240., 341., 0., 0., 0. *,3250., .37925,2341., 340., 0., 0., 0. *,3250., .39000,2341., 341., 0., 0., 0. *,3250., .42050,3240.,-120., 110., 0., 0. *,3250., .45100,3240.,-120., 220., 0., 0. *,3250., .48150,3240.,-120., 111., 0., 0. *,3250., .51200,3240.,-120., 221., 0., 0. *,3250., .54250,3240.,-121., 110., 0., 0. *,3250., .57300,3240.,-121., 220., 0., 0. *,3250., .60350,3240.,-121., 111., 0., 0. *,3250., .63400,3240.,-121., 221., 0., 0. *,3250., .66450,2341.,-120., 110., 0., 0. *,3250., .69500,2341.,-120., 220., 0., 0. *,3250., .72550,2341.,-120., 111., 0., 0. *,3250., .75600,2341.,-120., 221., 0., 0. *,3250., .78650,2341.,-121., 110., 0., 0. *,3250., .81700,2341.,-121., 220., 0., 0. *,3250., .84750,2341.,-121., 111., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=793,810)/ * 3250., .87800,2341.,-121., 221., 0., 0. *,3250., .89325,3240.,-130., 230., 0., 0. *,3250., .90850,3240.,-130., 231., 0., 0. *,3250., .92375,3240.,-131., 230., 0., 0. *,3250., .93900,3240.,-131., 231., 0., 0. *,3250., .95425,2341.,-130., 230., 0., 0. *,3250., .96950,2341.,-130., 231., 0., 0. *,3250., .98475,2341.,-131., 230., 0., 0. *,3250.,1.00000,2341.,-131., 231., 0., 0. *,3350., .06000, 12., -11.,3340., 0., 0. *,3350., .12000, 12., -11.,3341., 0., 0. *,3350., .18000, 14., -13.,3340., 0., 0. *,3350., .24000, 14., -13.,3341., 0., 0. *,3350., .25500, 16., -15.,3340., 0., 0. *,3350., .27000, 16., -15.,3341., 0., 0. *,3350., .28925,3340.,-120., 0., 0., 0. *,3350., .30850,3340.,-121., 0., 0., 0. *,3350., .32775,3341.,-120., 0., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=811,828)/ * 3350., .34700,3341.,-121., 0., 0., 0. *,3350., .35775,3340., 340., 0., 0., 0. *,3350., .36850,3340., 341., 0., 0., 0. *,3350., .37925,3341., 340., 0., 0., 0. *,3350., .39000,3341., 341., 0., 0., 0. *,3350., .42050,3340.,-120., 110., 0., 0. *,3350., .45100,3340.,-120., 220., 0., 0. *,3350., .48150,3340.,-120., 111., 0., 0. *,3350., .51200,3340.,-120., 221., 0., 0. *,3350., .54250,3340.,-121., 110., 0., 0. *,3350., .57300,3340.,-121., 220., 0., 0. *,3350., .60350,3340.,-121., 111., 0., 0. *,3350., .63400,3340.,-121., 221., 0., 0. *,3350., .66450,3341.,-120., 110., 0., 0. *,3350., .69500,3341.,-120., 220., 0., 0. *,3350., .72550,3341.,-120., 111., 0., 0. *,3350., .75600,3341.,-120., 221., 0., 0. *,3350., .78650,3341.,-121., 110., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=829,846)/ * 3350., .81700,3341.,-121., 220., 0., 0. *,3350., .84750,3341.,-121., 111., 0., 0. *,3350., .87800,3341.,-121., 221., 0., 0. *,3350., .89325,3340.,-130., 230., 0., 0. *,3350., .90850,3340.,-130., 231., 0., 0. *,3350., .92375,3340.,-131., 230., 0., 0. *,3350., .93900,3340.,-131., 231., 0., 0. *,3350., .95425,3341.,-130., 230., 0., 0. *,3350., .96950,3341.,-130., 231., 0., 0. *,3350., .98475,3341.,-131., 230., 0., 0. *,3350.,1.00000,3341.,-131., 231., 0., 0. *,1160., .33300, 1., -2.,1500., 0., 0. *,1160., .66700, 4., -3.,1500., 0., 0. *,1160., .77800, -12., 11.,1500., 0., 0. *,1160., .88900, -14., 13.,1500., 0., 0. *,1160.,1.00000, -16., 15.,1500., 0., 0. *,1260., .33300, 1., -2.,2500., 0., 0. *,1260., .66700, 4., -3.,2500., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=847,864)/ * 1260., .77800, -12., 11.,2500., 0., 0. *,1260., .88900, -14., 13.,2500., 0., 0. *,1260.,1.00000, -16., 15.,2500., 0., 0. *,2260., .33300, 1., -2.,2500., 0., 0. *,2260., .66700, 4., -3.,2500., 0., 0. *,2260., .77800, -12., 11.,2500., 0., 0. *,2260., .88900, -14., 13.,2500., 0., 0. *,2260.,1.00000, -16., 15.,2500., 0., 0. *,2160., .33300, 1., -2.,1500., 0., 0. *,2160., .66700, 4., -3.,1500., 0., 0. *,2160., .77800, -12., 11.,1500., 0., 0. *,2160., .88900, -14., 13.,1500., 0., 0. *,2160.,1.00000, -16., 15.,1500., 0., 0. *,1360., .33300, 1., -2.,3500., 0., 0. *,1360., .66700, 4., -3.,3500., 0., 0. *,1360., .77800, -12., 11.,3500., 0., 0. *,1360., .88900, -14., 13.,3500., 0., 0. *,1360.,1.00000, -16., 15.,3500., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=865,882)/ * 2360., .33300, 1., -2.,3500., 0., 0. *,2360., .66700, 4., -3.,3500., 0., 0. *,2360., .77800, -12., 11.,3500., 0., 0. *,2360., .88900, -14., 13.,3500., 0., 0. *,2360.,1.00000, -16., 15.,3500., 0., 0. *,3360., .33300, 1., -2.,3500., 0., 0. *,3360., .66700, 4., -3.,3500., 0., 0. *,3360., .77800, -12., 11.,3500., 0., 0. *,3360., .88900, -14., 13.,3500., 0., 0. *,3360.,1.00000, -16., 15.,3500., 0., 0. *,1151.,1.00000,1150., 10., 0., 0., 0. *,1251.,1.00000,1250., 10., 0., 0., 0. *,2251.,1.00000,2250., 10., 0., 0., 0. *,1351.,1.00000,1350., 10., 0., 0., 0. *,2351.,1.00000,2350., 10., 0., 0., 0. *,3351.,1.00000,3350., 10., 0., 0., 0. *,1161.,1.00000,1160., 10., 0., 0., 0. *,1261.,1.00000,1260., 10., 0., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=883,886)/ * 2261.,1.00000,2260., 10., 0., 0., 0. *,1361.,1.00000,1360., 10., 0., 0., 0. *,2361.,1.00000,2360., 10., 0., 0., 0. *,3361.,1.00000,3360., 10., 0., 0., 0./ C *--------------------------------------------- C * DELTA++ RESONANCES C *--------------------------------------------- DATA ((DECTAB(I,J),I=1,7),J=887,900)/ C *--DL++(1620)--------------------------------- * 1112., .30000,1120., 120., 0., 0., 0. *,1112., .66000,1111., 110., 0., 0., 0. *,1112., .90000,1121., 120., 0., 0., 0. *,1112.,1.00000,1120., 120., 110., 0., 0. C *--DL++(1700)--------------------------------- *,1113., .15000,1120., 120., 0., 0., 0. *,1113., .51000,1111., 110., 0., 0., 0. *,1113., .75000,1121., 120., 0., 0., 0. *,1113.,1.00000,1120., 120., 110., 0., 0. C *--DL++(1925)--------------------------------- *,1114., .28000,1120., 120., 0., 0., 0. *,1114., .40600,1111., 110., 0., 0., 0. *,1114., .49000,1121., 120., 0., 0., 0. *,1114., .69000,1120., 121., 0., 0., 0. *,1114., .70000,1130., 130., 0., 0., 0. *,1114.,1.00000,1122., 120., 0., 0., 0./ C *--------------------------------------------- C * DELTA- RESONANCES C *--------------------------------------------- DATA ((DECTAB(I,J),I=1,7),J=901,914)/ C *--DL-(1620)---------------------------------- * 2222., .30000,1220.,-120., 0., 0., 0. *,2222., .66000,2221., 110., 0., 0., 0. *,2222., .90000,1221.,-120., 0., 0., 0. *,2222.,1.00000,1220., 110.,-120., 0., 0. C *--DL-(1700)---------------------------------- *,2223., .15000,1220.,-120., 0., 0., 0. *,2223., .51000,2221., 110., 0., 0., 0. *,2223., .75000,1221.,-120., 0., 0., 0. *,2223.,1.00000,1220., 110.,-120., 0., 0. C *--DL-(1925)---------------------------------- *,2224., .28000,1220.,-120., 0., 0., 0. *,2224., .40600,2221., 110., 0., 0., 0. *,2224., .49000,1221.,-120., 0., 0., 0. *,2224., .69000,1220.,-121., 0., 0., 0. *,2224., .70000,2230., 230., 0., 0., 0. *,2224.,1.00000,1222.,-120., 0., 0., 0./ C *--------------------------------------------- C * N*+ RESONANCES + DELTA+ RESONANCES C *--------------------------------------------- DATA ((DECTAB(I,J),I=1,7),J=915,931)/ C *--N*+(1440)---------------------------------- * 1122., .20000,1120., 110., 0., 0., 0. *,1122., .60000,1220., 120., 0., 0., 0. *,1122., .68000,1111.,-120., 0., 0., 0. *,1122., .73000,1121., 110., 0., 0., 0. *,1122., .76000,1221., 120., 0., 0., 0. *,1122., .84000,1120., 120.,-120., 0., 0. *,1122., .87000,1120., 110., 110., 0., 0. *,1122.,1.00000,1220., 120., 110., 0., 0. C *--N*+(1530)---------------------------------- *,1123., .17000,1120., 110., 0., 0., 0. *,1123., .51000,1220., 120., 0., 0., 0. *,1123., .57000,1111.,-120., 0., 0., 0. *,1123., .61000,1121., 110., 0., 0., 0. *,1123., .63000,1221., 120., 0., 0., 0. *,1123., .67000,1120., 120.,-120., 0., 0. *,1123., .68000,1120., 110., 110., 0., 0. *,1123., .75000,1220., 120., 110., 0., 0. *,1123.,1.00000,1120., 220., 0., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=932,948)/ C *--DL+(1620)---------------------------------- * 1124., .20000,1120., 110., 0., 0., 0. *,1124., .30000,1220., 120., 0., 0., 0. *,1124., .54000,1111.,-120., 0., 0., 0. *,1124., .58000,1121., 110., 0., 0., 0. *,1124., .90000,1221., 120., 0., 0., 0. *,1124., .96000,1120., 120.,-120., 0., 0. *,1124.,1.00000,1220., 120., 110., 0., 0. C *--N*+(1665)---------------------------------- *,1125., .16700,1120., 110., 0., 0., 0. *,1125., .49970,1220., 120., 0., 0., 0. *,1125., .62470,1111.,-120., 0., 0., 0. *,1125., .70800,1121., 110., 0., 0., 0. *,1125., .74970,1221., 120., 0., 0., 0. *,1125., .82080,1120., 120.,-120., 0., 0. *,1125., .85190,1120., 110., 110., 0., 0. *,1125., .96300,1220., 120., 110., 0., 0. *,1125., .97300,1120., 220., 0., 0., 0. *,1125.,1.00000,2130., 130., 0., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=949,955)/ C *--DL+(1700)---------------------------------- * 1126., .10000,1120., 110., 0., 0., 0. *,1126., .15000,1220., 120., 0., 0., 0. *,1126., .39000,1111.,-120., 0., 0., 0. *,1126., .43000,1121., 110., 0., 0., 0. *,1126., .75000,1221., 120., 0., 0., 0. *,1126., .91500,1120., 120.,-120., 0., 0. *,1126.,1.00000,1220., 120., 110., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=956,969)/ C *--N*+(1710)---------------------------------- * 1127., .04430,1120., 110., 0., 0., 0. *,1127., .13290,1220., 120., 0., 0., 0. *,1127., .23790,1111.,-120., 0., 0., 0. *,1127., .30790,1121., 110., 0., 0., 0. *,1127., .34290,1221., 120., 0., 0., 0. *,1127., .41190,1120., 120.,-120., 0., 0. *,1127., .48090,1120., 110., 110., 0., 0. *,1127., .54990,1220., 120., 110., 0., 0. *,1127., .66070,1120., 220., 0., 0., 0. *,1127., .72800,2130., 130., 0., 0., 0. *,1127., .74930,1230., 130., 0., 0., 0. *,1127., .76000,1130., 230., 0., 0., 0. *,1127., .84000,1120., 111., 0., 0., 0. *,1127.,1.00000,1220., 121., 0., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=970,980)/ C *--DL+(1925)---------------------------------- * 1128., .18700,1120., 110., 0., 0., 0. *,1128., .28000,1220., 120., 0., 0., 0. *,1128., .36400,1111.,-120., 0., 0., 0. *,1128., .37800,1121., 110., 0., 0., 0. *,1128., .49000,1221., 120., 0., 0., 0. *,1128., .62300,1120., 111., 0., 0., 0. *,1128., .69000,1220., 121., 0., 0., 0. *,1128., .69350,1130., 230., 0., 0., 0. *,1128., .69900,1230., 130., 0., 0., 0. *,1128., .89900,1122., 110., 0., 0., 0. *,1128.,1.00000,1222., 120., 0., 0., 0./ C *--------------------------------------------- C * N*0 RESONANCES + DELTA0 RESONANCES C *--------------------------------------------- DATA ((DECTAB(I,J),I=1,7),J=981,997)/ C *----------N*0(1440)-------------------------- * 1222., .20000,1220., 110., 0., 0., 0. *,1222., .60000,1120.,-120., 0., 0., 0. *,1222., .68000,2221., 120., 0., 0., 0. *,1222., .73000,1221., 110., 0., 0., 0. *,1222., .76000,1121.,-120., 0., 0., 0. *,1222., .84000,1220., 120.,-120., 0., 0. *,1222., .87000,1220., 110., 110., 0., 0. *,1222.,1.00000,1120.,-120., 110., 0., 0. C *----------N*0(1530)-------------------------- *,1223., .17000,1220., 110., 0., 0., 0. *,1223., .51000,1120.,-120., 0., 0., 0. *,1223., .57000,2221., 120., 0., 0., 0. *,1223., .61000,1221., 110., 0., 0., 0. *,1223., .63000,1121.,-120., 0., 0., 0. *,1223., .67000,1220., 120.,-120., 0., 0. *,1223., .68000,1220., 110., 110., 0., 0. *,1223., .75000,1120.,-120., 110., 0., 0. *,1223.,1.00000,1220., 220., 0., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=998,1014)/ C *----------DL0(1620)-------------------------- * 1224., .20000,1220., 110., 0., 0., 0. *,1224., .30000,1120.,-120., 0., 0., 0. *,1224., .54000,2221., 120., 0., 0., 0. *,1224., .58000,1221., 110., 0., 0., 0. *,1224., .90000,1121.,-120., 0., 0., 0. *,1224., .96500,1220., 120.,-120., 0., 0. *,1224.,1.00000,1120.,-120., 110., 0., 0. C *----------N*0(1665)-------------------------- *,1225., .16700,1220., 110., 0., 0., 0. *,1225., .49970,1120.,-120., 0., 0., 0. *,1225., .62470,2221., 120., 0., 0., 0. *,1225., .70800,1221., 110., 0., 0., 0. *,1225., .74970,1121.,-120., 0., 0., 0. *,1225., .82080,1220., 120.,-120., 0., 0. *,1225., .85190,1220., 110., 110., 0., 0. *,1225., .96300,1120.,-120., 110., 0., 0. *,1225., .97300,1220., 220., 0., 0., 0. *,1225.,1.00000,2130., 230., 0., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=1015,1021)/ C *----------DL0(1700)-------------------------- * 1226., .10000,1220., 110., 0., 0., 0. *,1226., .15000,1120.,-120., 0., 0., 0. *,1226., .39000,2221., 120., 0., 0., 0. *,1226., .43000,1221., 110., 0., 0., 0. *,1226., .75000,1121.,-120., 0., 0., 0. *,1226., .91500,1220., 120.,-120., 0., 0. *,1226.,1.00000,1120.,-120., 110., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=1022,1035)/ C *----------N*0(1710)-------------------------- * 1227., .04430,1220., 110., 0., 0., 0. *,1227., .13290,1120.,-120., 0., 0., 0. *,1227., .23790,2221., 120., 0., 0., 0. *,1227., .30790,1221., 110., 0., 0., 0. *,1227., .34290,1121.,-120., 0., 0., 0. *,1227., .41190,1220., 120.,-120., 0., 0. *,1227., .48090,1220., 110., 110., 0., 0. *,1227., .54990,1120.,-120., 110., 0., 0. *,1227., .66070,1220., 220., 0., 0., 0. *,1227., .72800,2130., 230., 0., 0., 0. *,1227., .73870,1230., 230., 0., 0., 0. *,1227., .76000,2230., 130., 0., 0., 0. *,1227., .92000,1120.,-121., 0., 0., 0. *,1227.,1.00000,1220., 111., 0., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=1036,1046)/ C *----------DL0(1925)-------------------------- * 1228., .18700,1220., 110., 0., 0., 0. *,1228., .28000,1120.,-120., 0., 0., 0. *,1228., .36400,2221., 120., 0., 0., 0. *,1228., .37800,1221., 110., 0., 0., 0. *,1228., .49000,1121.,-120., 0., 0., 0. *,1228., .55700,1220., 111., 0., 0., 0. *,1228., .69000,1120.,-121., 0., 0., 0. *,1228., .69350,2230., 130., 0., 0., 0. *,1228., .70000,1230., 230., 0., 0., 0. *,1228., .80000,1122.,-120., 0., 0., 0. *,1228.,1.00000,1222., 110., 0., 0., 0./ C *--------------------------------------------- C * LAMBDA RESONANCES + SIGMA0 RESONANCES C *--------------------------------------------- DATA ((DECTAB(I,J),I=1,7),J=1047,1059)/ C *----------LAMBDA(1405)----------------------- * 1233., .33000,1230., 110., 0., 0., 0. *,1233., .66000,2230., 120., 0., 0., 0. *,1233.,1.00000,1130.,-120., 0., 0., 0. C *----------LAMBDA(1520)----------------------- *,1234., .22500,1120.,-130., 0., 0., 0. *,1234., .48000,1220.,-230., 0., 0., 0. *,1234., .62000,1230., 110., 0., 0., 0. *,1234., .76000,2230., 120., 0., 0., 0. *,1234., .90000,1130.,-120., 0., 0., 0. *,1234., .96000,2130., 120.,-120., 0., 0. *,1234., .99000,2130., 110., 110., 0., 0. *,1234., .99330,1130.,-120., 110., 0., 0. *,1234., .99660,2230., 120., 110., 0., 0. *,1234.,1.00000,1230., 120.,-120., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=1060,1075)/ C *----------LAMBDA(1645)----------------------- * 1235., .10000,1120.,-130., 0., 0., 0. *,1235., .20000,1220.,-230., 0., 0., 0. *,1235., .35000,1230., 110., 0., 0., 0. *,1235., .50000,2230., 120., 0., 0., 0. *,1235., .65000,1130.,-120., 0., 0., 0. *,1235., .75000,2130., 120.,-120., 0., 0. *,1235., .80000,2130., 110., 110., 0., 0. *,1235., .84500,1130.,-120., 110., 0., 0. *,1235., .89000,2230., 120., 110., 0., 0. *,1235., .93500,1230., 120.,-120., 0., 0. *,1235.,1.00000,2130., 220., 0., 0., 0. C *----------SIGMA0(1665)----------------------- *,1236., .10000,1120.,-130., 0., 0., 0. *,1236., .20000,1220.,-230., 0., 0., 0. *,1236., .40000,2230., 120., 0., 0., 0. *,1236., .60000,1130.,-120., 0., 0., 0. *,1236.,1.00000,2130., 110., 0., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=1076,1084)/ C *----------SIGMA0(1776)----------------------- * 1237., .17500,1120.,-130., 0., 0., 0. *,1237., .35000,1220.,-230., 0., 0., 0. *,1237., .38750,2230., 120., 0., 0., 0. *,1237., .42500,1130.,-120., 0., 0., 0. *,1237., .57500,2130., 110., 0., 0., 0. *,1237., .60000,2231., 120., 0., 0., 0. *,1237., .62500,1131.,-120., 0., 0., 0. *,1237., .75000,1234., 110., 0., 0., 0. *,1237.,1.00000,1230., 220., 0., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=1085,1094)/ C *----------LAMBDA(1845)----------------------- * 1238., .17000,1120.,-130., 0., 0., 0. *,1238., .34000,1220.,-230., 0., 0., 0. *,1238., .44000,1230., 110., 0., 0., 0. *,1238., .54000,2230., 120., 0., 0., 0. *,1238., .64000,1130.,-120., 0., 0., 0. *,1238., .70000,1231., 110., 0., 0., 0. *,1238., .76000,2231., 120., 0., 0., 0. *,1238., .82000,1131.,-120., 0., 0., 0. *,1238., .91000,1120.,-131., 0., 0., 0. *,1238.,1.00000,1220.,-231., 0., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=1095,1106)/ C *----------SIGMA0(1930)----------------------- * 1239., .07500,1120.,-130., 0., 0., 0. *,1239., .15000,1220.,-230., 0., 0., 0. *,1239., .20000,1121.,-130., 0., 0., 0. *,1239., .25000,1221.,-230., 0., 0., 0. *,1239., .32500,1120.,-131., 0., 0., 0. *,1239., .40000,1220.,-231., 0., 0., 0. *,1239., .47500,2230., 120., 0., 0., 0. *,1239., .55000,1130.,-120., 0., 0., 0. *,1239., .70000,2130., 110., 0., 0., 0. *,1239., .77500,2231., 120., 0., 0., 0. *,1239., .85000,1131.,-120., 0., 0., 0. *,1239.,1.00000,1234., 110., 0., 0., 0./ C *--------------------------------------------- C * SIGMA+ RESONANCES C *--------------------------------------------- DATA ((DECTAB(I,J),I=1,7),J=1107,1118)/ C *----------SIGMA+(1665)----------------------- * 1132., .20000,1120.,-230., 0., 0., 0. *,1132., .40000,1130., 110., 0., 0., 0. *,1132., .60000,1230., 120., 0., 0., 0. *,1132.,1.00000,2130., 120., 0., 0., 0. C *----------SIGMA+(1776)----------------------- *,1133., .35000,1120.,-230., 0., 0., 0. *,1133., .38750,1130., 110., 0., 0., 0. *,1133., .42500,1230., 120., 0., 0., 0. *,1133., .57500,2130., 120., 0., 0., 0. *,1133., .60000,1131., 110., 0., 0., 0. *,1133., .62500,1231., 120., 0., 0., 0. *,1133., .75000,1234., 120., 0., 0., 0. *,1133.,1.00000,1130., 220., 0., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=1119,1128)/ C *----------SIGMA+(1930)----------------------- * 1134., .15000,1120.,-230., 0., 0., 0. *,1134., .22500,1111.,-130., 0., 0., 0. *,1134., .25000,1121.,-230., 0., 0., 0. *,1134., .40000,1120.,-231., 0., 0., 0. *,1134., .47500,1130., 110., 0., 0., 0. *,1134., .55000,1230., 120., 0., 0., 0. *,1134., .70000,2130., 120., 0., 0., 0. *,1134., .77500,1131., 110., 0., 0., 0. *,1134., .85000,1231., 120., 0., 0., 0. *,1134.,1.00000,1234., 120., 0., 0., 0./ C *--------------------------------------------- C * SIGMA- RESONANCES C *--------------------------------------------- DATA ((DECTAB(I,J),I=1,7),J=1129,1140)/ C *----------SIGMA-(1665)----------------------- * 2232., .20000,1220.,-130., 0., 0., 0. *,2232., .40000,2230., 110., 0., 0., 0. *,2232., .60000,1230.,-120., 0., 0., 0. *,2232.,1.00000,2130.,-120., 0., 0., 0. C *----------SIGMA-(1776)----------------------- *,2233., .35000,1220.,-130., 0., 0., 0. *,2233., .38750,2230., 110., 0., 0., 0. *,2233., .42500,1230.,-120., 0., 0., 0. *,2233., .57500,2130.,-120., 0., 0., 0. *,2233., .60000,2231., 110., 0., 0., 0. *,2233., .62500,1231.,-120., 0., 0., 0. *,2233., .75000,1234.,-120., 0., 0., 0. *,2233.,1.00000,2230., 220., 0., 0., 0./ DATA ((DECTAB(I,J),I=1,7),J=1141,1150)/ C *----------SIGMA-(1930)----------------------- * 2234., .15000,1220.,-130., 0., 0., 0. *,2234., .17500,1221.,-130., 0., 0., 0. *,2234., .25000,2221.,-230., 0., 0., 0. *,2234., .40000,1220.,-131., 0., 0., 0. *,2234., .47500,2230., 110., 0., 0., 0. *,2234., .55000,1230.,-120., 0., 0., 0. *,2234., .70000,2130.,-120., 0., 0., 0. *,2234., .77500,2231., 110., 0., 0., 0. *,2234., .85000,1231.,-120., 0., 0., 0. *,2234.,1.00000,1234.,-120., 0., 0., 0./ C *--------------------------------------------- C * ADDITIONAL MESONRESONANCES C *--------------------------------------------- DATA ((DECTAB(I,J),I=1,7),J=1151,1159)/ C *-----------F0(975)--------------------------- * 332., .50000, 120.,-120., 0., 0., 0. *, 332., .75000, 110., 110., 0., 0., 0. *, 332., .87500, 130.,-130., 0., 0., 0. *, 332.,1.00000, 230.,-230., 0., 0., 0. C *-----------A0(980)--------------------------- *, 112., .56000, 110., 220., 0., 0., 0. *, 112., .78000, 130.,-130., 0., 0., 0. *, 112.,1.00000, 230.,-230., 0., 0., 0. C *-----------A+(980)--------------------------- *, 122., .60000, 120., 220., 0., 0., 0. *, 122.,1.00000, 130.,-230., 0., 0., 0./ C *--------------------------------------------- C * WEAK BARYON DECAYS C *--------------------------------------------- DATA ((DECTAB(I,J),I=1,7),J=1160,1169)/ C *-----------LAMBDA(1116)---------------------- * 2130.,0.64200,1120.,-120., 0., 0., 0. *,2130.,1.00000,1220., 110., 0., 0., 0. C *-----------SIGMA+(1180)---------------------- *,1130.,0.51580,1120., 110., 0., 0., 0. *,1130.,1.00000,1220., 120., 0., 0., 0. C *-----------SIGMA-(1180)---------------------- *,2230.,1.00000,1220.,-120., 0., 0., 0. C *---------KASKADE-(1360)---------------------- *,2330.,1.00000,2130.,-120., 0., 0., 0. C *---------KASKADE0(1360)---------------------- *,1330.,1.00000,2130., 110., 0., 0., 0. C *---------OMEGA-(1680)------------------------ *,3331.,0.68000,2130.,-130., 0., 0., 0. *,3331.,0.82000,1330.,-120., 0., 0., 0. *,3331.,1.00000,2330., 110., 0., 0., 0./ C *--------------------------------------------- C * WEAK MESON DECAYS C *--------------------------------------------- DATA ((DECTAB(I,J),I=1,7),J=1170,1171)/ C *-----------K0S(975)-------------------------- * 20., .68610, 120.,-120., 0., 0., 0. *, 20.,1.00000, 110., 110., 0., 0., 0./ C *--------------------------------------------- DATA ALFA /0.00729735/, GF /1.16570E-5/, SIN2W /.215/ C SINW = SQRT(SIN2W), COSW=SQRT(1.-SIN2W) DATA SINW /.463681/,COSW /.886002/ SAVE C----------------------------------------------------------------------- IF ( IENTRO .EQ. 1 ) THEN CALL JCENTR(3,6,3,1) ELSEIF ( IENTRO .EQ. 2 ) THEN CALL JCENTD ENDIF CALL JCENTP CALL IDRESI C DETERMINE WMASS2,WGAM2 C ---------------------- AMW=SQRT(PI*ALFA/(.9304*1.41421356*GF))/SINW WMASS2=AMW CALL IDMASS(5,AMLEP5) CALL IDMASS(6,AMLEP6) IF ( AMLEP5+AMLEP6 .GT. AMW ) THEN NGAM=9 ELSE NGAM=12 ENDIF WGAM2=GF*AMW**3/(6.*PI*1.41421356)*NGAM IRD=0 DO 1 I=1,MXLOOK LOOK(I)=0 1 CONTINUE DO 2 I=1,MXDKY MODE(1,I)=0 MODE(2,I)=0 MODE(3,I)=0 MODE(4,I)=0 MODE(5,I)=0 CBR(I)=0. 2 CONTINUE NODCAY=.FALSE. NOETA=.FALSE. NOPI0=.FALSE. NONUNU=.FALSE. NOEVOL=.FALSE. NOHADR=.FALSE. IF ( LPRINT ) WRITE(IFCH,10) 10 FORMAT('1',30('*')/' *',28X,'*'/ * ' *',5X,'ISAJET DECAY TABLE',5X,'*'/ * ' *',28X,'*'/' ',30('*')// * 6X,'PART',18X,'DECAY MODE',19X,'CUM BR',15X,'IDENT',17X, * 'DECAY IDENT'/) LOOP=0 IOLD=0 IF ( NODCAY ) RETURN 200 LOOP=LOOP+1 IF ( LOOP .GT. MXDKY ) GOTO 9999 220 CONTINUE IMODE(1)=0 IMODE(2)=0 IMODE(3)=0 IMODE(4)=0 IMODE(5)=0 LMODE(1)=IBLANK LMODE(2)=IBLANK LMODE(3)=IBLANK LMODE(4)=IBLANK LMODE(5)=IBLANK IRD=IRD+1 IF ( IRD .GT. NDECTB ) RETURN IRES=NINT(DECTAB(1,IRD)) BR=DECTAB(2,IRD) IMODE(1)=NINT(DECTAB(2+1,IRD)) IMODE(2)=NINT(DECTAB(2+2,IRD)) IMODE(3)=NINT(DECTAB(2+3,IRD)) IMODE(4)=NINT(DECTAB(2+4,IRD)) IMODE(5)=NINT(DECTAB(2+5,IRD)) IF ( NOPI0 .AND. IRES .EQ. 110 ) GOTO 220 IF ( NOETA .AND. IRES .EQ. 220 ) GOTO 220 IF ( IRES .EQ. IOLD ) GOTO 230 IF ( IRES .LT. 0 .OR. IRES .GT. MXLOOK ) THEN CALL UTSTOP('JDECIN: IRES OUT OF RANGE ') ENDIF LOOK(IRES)=LOOP 230 IOLD=IRES CBR(LOOP)=BR MODE(1,LOOP)=IMODE(1) MODE(2,LOOP)=IMODE(2) MODE(3,LOOP)=IMODE(3) MODE(4,LOOP)=IMODE(4) MODE(5,LOOP)=IMODE(5) IF ( LPRINT ) THEN IF ( IMODE(1) .NE. 0 ) LMODE(1)=IDLABL(IMODE(1)) IF ( IMODE(2) .NE. 0 ) LMODE(2)=IDLABL(IMODE(2)) IF ( IMODE(3) .NE. 0 ) LMODE(3)=IDLABL(IMODE(3)) IF ( IMODE(4) .NE. 0 ) LMODE(4)=IDLABL(IMODE(4)) IF ( IMODE(5) .NE. 0 ) LMODE(5)=IDLABL(IMODE(5)) LRES=IDLABL(IRES) WRITE(IFCH,20) LRES,(LMODE(K),K=1,5), BR,IRES,(IMODE(K),K=1,5) 20 FORMAT(6X,A5,6X,5(A5,2X),3X,F8.5,15X,I5,4X,5(I5,2X)) ENDIF GOTO 200 9999 WRITE(IFCH,*)'LOOP=', LOOP CALL UTSTOP('JDECIN: LOOP > MXDKY ') RETURN END C======================================================================= SUBROUTINE JESTPR(IC1,IC2,AM,IER) C----------------------------------------------------------------------- C PROCESSES STRINGS C----------------------------------------------------------------------- PARAMETER (KOLLMX=2500) PARAMETER (MAMX=56) PARAMETER (MXPTL=70000) PARAMETER (MXSTR=3000) PARAMETER (NDEP=129) PARAMETER (NDET=129) PARAMETER (NFLAV=6) PARAMETER (NSI=6) PARAMETER (NSIX=40) PARAMETER (NHA=NSIX+2) COMMON /ACCUM/ AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT * ,NRPTL,NRSTR,NTEVT COMMON /CEVT/ BIMEVT,COLEVT,EGYEVT,PHIEVT,PMXEVT * ,KOLEVT,NEVT,NPJEVT,NTGEVT COMMON /CKOL/ KOL COMMON /CLEAD/ COOAV3,COOAV4,LEAD COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /COL/ BIMP,BMAX,COORD(4,KOLLMX),DISTCE(KOLLMX) * ,QDEP(NDEP),QDET14(NDET),QDET16(NDET),QDET40(NDET) * ,QDET99(NDET),RMPROJ,RMTARG(4),XDEP(NDEP) * ,XDET14(NDET),XDET16(NDET),XDET40(NDET) * ,XDET99(NDET) * ,KOLL,LTARG,NORD(KOLLMX),NPROJ,NRPROJ(KOLLMX) * ,NRTARG(KOLLMX),NTARG COMMON /CPROJA/ IPROJ,ITARG,KPROJA(NHA,MAMX),KTARGA(NHA,MAMX) COMMON /CPTL/ PPTL(5,MXPTL),TIVPTL(2,MXPTL),XORPTL(4,MXPTL) * ,IBPTL(4,MXPTL),ICLPTL(MXPTL),IDPTL(MXPTL) * ,IFRPTL(2,MXPTL),IORPTL(MXPTL),ISTPTL(MXPTL) * ,JORPTL(MXPTL),NPTL,NQJPTL(MXPTL) COMMON /CPZSTR/ ESTRL,PZSTRL,ISEA,ISTRL COMMON /CSTR/ PSTR(5,MXSTR),ROTSTR(3,MXSTR),XORSTR(4,MXSTR) * ,ICSTR(4,MXSTR),IORSTR(MXSTR),IRLSTR(MXSTR),NSTR COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT REAL STRO(NSI,NSIX+1) INTEGER IC1(2),IC2(2),JC(NFLAV,2),JC1(NFLAV,2),JC2(NFLAV,2) SAVE C----------------------------------------------------------------------- IER=0 C PMAX C ---- CALL IDDECO(IC1,JC) NQ=0 DO 7 NF=1,NFLAV NQ=NQ+JC(NF,1)-JC(NF,2) 7 CONTINUE IF ( ABS(NQ) .GE. 2 ) THEN AM1MIN=PROM ELSE AM1MIN=PIOM ENDIF CALL IDDECO(IC2,JC) NQ=0 DO 8 NF=1,NFLAV NQ=NQ+JC(NF,1)-JC(NF,2) 8 CONTINUE IF ( ABS(NQ) .GE. 2 ) THEN AM2MIN=PROM ELSE AM2MIN=PIOM ENDIF IF ( AM .LE. AM1MIN+AM2MIN ) THEN PMAX=AM*0.5 ELSE PMAX=UTPCM(AM,AM1MIN,AM2MIN) ENDIF C HASTPR C ------ IPROJ=1 ITARG=1 KPROJA(2,1)=1 KTARGA(2,1)=1 KPROJA(3,1)=1 KTARGA(3,1)=1 KOL=1 COORD(1,1)=0. COORD(2,1)=0. COORD(3,1)=0. COORD(4,1)=0. CALL IDDECO(IC1,JC1) NPA1=0 DO 2 N=1,NFLAV NPA1=NPA1+JC1(N,1)+JC1(N,2) 2 CONTINUE CALL IDDECO(IC2,JC2) NPA2=0 DO 3 N=1,NFLAV NPA2=NPA2+JC2(N,1)+JC2(N,2) 3 CONTINUE IF ( NPA2 .GT. NPA1 ) THEN II=2 ELSE II=1 ENDIF IF ( NPA1 .GT. 1 .OR. NPA2 .GT. 1 ) THEN LEAD=1 ELSE LEAD=0 ENDIF NSTR0=NSTR 17 NSTR=NSTR0 DO 15 N=1,NSI STRO(N,1)=0. STRO(N,2)=0. STRO(N,3)=0. 15 CONTINUE STRO(3,II)=AM*0.5 STRO(4,II)=AM*0.5 STRO(5,II)=IC1(1) STRO(6,II)=IC1(2) STRO(3,3-II)=-AM*0.5 STRO(4,3-II)=AM*0.5 STRO(5,3-II)=IC2(1) STRO(6,3-II)=IC2(2) PZSTRL=STRO(3,1) ESTRL=STRO(4,1) PZSTRL=PZSTRL+STRO(3,2) ESTRL=ESTRL+STRO(4,2) ISTRL=0 CALL UTPAGE IF ( ISH .GE. 91 ) THEN WRITE(IFCH,110)('-',L=1,79),IPAGE,('-',L=1,79) 110 FORMAT(1X,79A1/1X,I5,'.PAGE ' * ,'STRING GENERATION'/1X,79A1/) WRITE(IFCH,105)(STRO(I,1),I=1,4),(NINT(STRO(I,1)),I=5,6) 105 FORMAT(' STR: ',4F13.5,2I8) WRITE(IFCH,104)(STRO(I,2),I=1,4),(NINT(STRO(I,2)),I=5,6) 104 FORMAT(' ',4F13.5,2I8/) ENDIF ISEA=1 ISPLT=0 14 CALL HASTPR(STRO,ISPLT) IF ( ISPLT .EQ. -1 ) GOTO 9001 IF ( ISPLT .EQ. -3 ) GOTO 9001 IF ( ISPLT .EQ. -4 ) THEN CALL UTSTOP('JESTPR: ISPLT=-4 ') ENDIF IF ( ISPLT .EQ. -5 ) GOTO 17 IF ( ISPLT .GT. 0 ) GOTO 14 PMXEVT=PMAX EGYEVT=AM RETURN 9001 IER=1 RETURN END C======================================================================= SUBROUTINE JETGEN(IER) C----------------------------------------------------------------------- C GENERATES STRINGS C----------------------------------------------------------------------- PARAMETER (MXPTL=70000) PARAMETER (MXSTR=3000) PARAMETER (NSI=6) PARAMETER (NSIX=40) PARAMETER (NHA=NSIX+2) PARAMETER (MAMX=56) COMMON /ACCUM/ AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT * ,NRPTL,NRSTR,NTEVT COMMON /CEVT/ BIMEVT,COLEVT,EGYEVT,PHIEVT,PMXEVT * ,KOLEVT,NEVT,NPJEVT,NTGEVT COMMON /CLEP/ ICINPU,IDSCAT COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /CNTEVM/ NTEVM COMMON /CPTL/ PPTL(5,MXPTL),TIVPTL(2,MXPTL),XORPTL(4,MXPTL) * ,IBPTL(4,MXPTL),ICLPTL(MXPTL),IDPTL(MXPTL) * ,IFRPTL(2,MXPTL),IORPTL(MXPTL),ISTPTL(MXPTL) * ,JORPTL(MXPTL),NPTL,NQJPTL(MXPTL) COMMON /CSTR/ PSTR(5,MXSTR),ROTSTR(3,MXSTR),XORSTR(4,MXSTR) * ,ICSTR(4,MXSTR),IORSTR(MXSTR),IRLSTR(MXSTR),NSTR COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT COMMON /PARTNR/ PEX,PEY,PEZET,PE0,PX4,PY4,SUMMAS * ,IC4,IPTNR,JS4,NPS REAL TARGA(NSI,NHA,MAMX) INTEGER ICSTRI(4,18),IC1(2),IC2(2),IC4(2) DATA ((ICSTRI(I,J),I=1,4),J=1,8)/ *100000,000000,110000,000000, *010000,000000,200000,000000, *100000,000000,210000,100000, *010000,000000,210000,010000, *001000,000000,210000,001000, *000000,100000,310000,000000, *000000,010000,220000,000000, *000000,001000,211000,000000/ DATA ((ICSTRI(I,J),I=1,4),J=11,18)/ *100000,000000,020000,000000, *010000,000000,110000,000000, *100000,000000,120000,100000, *010000,000000,120000,010000, *001000,000000,120000,001000, *000000,100000,220000,000000, *000000,010000,130000,000000, *000000,001000,121000,000000/ SAVE C----------------------------------------------------------------------- ISH0=ISH IF ( ISHSUB/100 .EQ. 2 ) ISH=MOD(ISHSUB,100) IF ( ISH .GE. 93 ) THEN WRITE(IFCH,*)('-',L=1,79) WRITE(IFCH,*)'STRING GENERATION. SR JETGEN.' ENDIF IER=0 NEVT=1 NSTR=0 NPTL=0 IF ( ICINPU .GE. 1 ) THEN 3 CALL LEPEXP(XBJ,QSQ) RNU=QSQ/(2.* PROM * XBJ) WSQ=PROM**2 + 2.* PROM * RNU - QSQ AMST=SQRT(WSQ) ELEPTO=ELEPTI-RNU COSANG=1.-QSQ/(2.*ELEPTI*ELEPTO) IF ( ISH .GE. 93 ) THEN WRITE(IFCH,*)'ELEPTI,ELEPTO,RNU: ',ELEPTI,ELEPTO,RNU WRITE(IFCH,*)'XBJ,QSQ,COSANG=1-QSQ/2/ELEPTI/ELEPTO: ' * ,XBJ,QSQ,COSANG ENDIF IF ( RNU .GT. ELEPTI ) THEN IF ( ISH .GE. 93 ) WRITE(IFCH,*)'***** Q0 TOO LARGE: ',RNU GOTO 3 ENDIF IF ( COSANG.GT.1. .AND. COSANG.LT.1.001 ) THEN COSANG=1. ELSEIF ( COSANG.LT.-1. .OR. COSANG.GT.1. ) THEN COSANO=COSANG IF ( COSANG .GE. 0. ) COSANG= 1. IF ( COSANG .LT. 0. ) COSANG=-1. IF(ISH.GE.90)THEN CALL UTMSG('JETGEN') WRITE(IFCH,*)'***** COSANG OUT OF RANGE' WRITE(IFCH,*)'ELEPTI,ELEPTO,RNU: ',ELEPTI,ELEPTO,RNU WRITE(IFCH,*)'XBJ,QSQ,COSANG=1-QSQ/2/ELEPTI/ELEPTO: ' * ,XBJ,QSQ,COSANO WRITE(IFCH,*)'COSANG_NEW: ',COSANG CALL UTMSGF ENDIF ENDIF ANGMUE=ACOS(COSANG) CALL LEPTAR(XBJ,QSQ,MATARG,LATARG,IDSCAT) ENDIF IF ( MATARG .GT. 0 ) THEN CALL NUCOGE NPTL=0 CALL NUCINI('STR',TARGA,LATARG,MATARG,-1) CALL NUCSTR(IER) IF ( IER .EQ. 1 ) GOTO 99999 ENDIF IF ( ICINPU .EQ. 0 ) THEN R=RANGEN() PS=0. DO 1 K=1,99 PS=PS+PROB(K) IF ( R .LE. PS ) GOTO 2 1 CONTINUE CALL UTSTOP('JETGEN: NO K FOUND ') 2 CONTINUE IC1(1)=ICFOR(K,1) IC1(2)=ICFOR(K,2) IC2(1)=ICBAC(K,1) IC2(2)=ICBAC(K,2) AMST=ENGY ELSEIF ( ICINPU .GT. 0 ) THEN CALL LEPSTR(IDSCAT,XBJ,QSQ,IDS) IC1(1)=ICSTRI(1,IDS) IC1(2)=ICSTRI(2,IDS) IC2(1)=ICSTRI(3,IDS) IC2(2)=ICSTRI(4,IDS) ENDIF CALL JESTPR(IC1,IC2,AMST,IER) 99999 ISH=ISH0 RETURN END C======================================================================= SUBROUTINE JFRADE(IER) C----------------------------------------------------------------------- C PERFORMS STRING FRAGMENTATION/DECAY AND FIN. STATE INTERACTIONS C----------------------------------------------------------------------- PARAMETER (KOLLMX=2500) PARAMETER (MAMX=56) PARAMETER (MXDKY=2000) PARAMETER (MXINDX=1000) PARAMETER (MXLOOK=10000) PARAMETER (MXMA=11) PARAMETER (MXMX=6) PARAMETER (MXPTL=70000) PARAMETER (MXRE=100) PARAMETER (MXSTR=3000) PARAMETER (NDEP=129) PARAMETER (NDET=129) PARAMETER (NPRBMS=20) PARAMETER (NSIX=40) PARAMETER (NHA=NSIX+2) COMMON /ACCUM/ AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT * ,NRPTL,NRSTR,NTEVT COMMON /CEVT/ BIMEVT,COLEVT,EGYEVT,PHIEVT,PMXEVT * ,KOLEVT,NEVT,NPJEVT,NTGEVT COMMON /CKOL/ KOL COMMON /CNCE/ NCES,NCOLEX COMMON /CNFR/ NRFRA COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /COL/ BIMP,BMAX,COORD(4,KOLLMX),DISTCE(KOLLMX) * ,QDEP(NDEP),QDET14(NDET),QDET16(NDET),QDET40(NDET) * ,QDET99(NDET),RMPROJ,RMTARG(4),XDEP(NDEP) * ,XDET14(NDET),XDET16(NDET),XDET40(NDET) * ,XDET99(NDET) * ,KOLL,LTARG,NORD(KOLLMX),NPROJ,NRPROJ(KOLLMX) * ,NRTARG(KOLLMX),NTARG COMMON /CPRBMS / PRBMS(NPRBMS) COMMON /CPROJA/ IPROJ,ITARG,KPROJA(NHA,MAMX),KTARGA(NHA,MAMX) COMMON /CPTL/ PPTL(5,MXPTL),TIVPTL(2,MXPTL),XORPTL(4,MXPTL) * ,IBPTL(4,MXPTL),ICLPTL(MXPTL),IDPTL(MXPTL) * ,IFRPTL(2,MXPTL),IORPTL(MXPTL),ISTPTL(MXPTL) * ,JORPTL(MXPTL),NPTL,NQJPTL(MXPTL) COMMON /CREMA/ REMA(MXRE,MXMA),REWI(MXRE,MXMA) * ,ICRE1(MXRE,MXMA),ICRE2(MXRE,MXMA) * ,IDMX(MXMA,MXMX),INDX(MXINDX) COMMON /CSTR/ PSTR(5,MXSTR),ROTSTR(3,MXSTR),XORSTR(4,MXSTR) * ,ICSTR(4,MXSTR),IORSTR(MXSTR),IRLSTR(MXSTR),NSTR COMMON /CTIMEL/ NTC DOUBLE PRECISION DETAP,DETAT,TPRO,TTAR,TTAUS,TTP,TTT * ,ZPRO,ZTAR,ZZP,ZZT COMMON /CTTAUS/ DETAP,DETAT,TPRO,TTAR,TTAUS,TTP,TTT * ,ZPRO,ZTAR,ZZP,ZZT COMMON /C2PTL/ AMIPTL(MXPTL),RADPTL(MXPTL),IAAPTL(MXPTL) COMMON /DIDIB/ NDIDIB COMMON /DKYTAB/ CBR(MXDKY),LOOK(MXLOOK),MODE(5,MXDKY) COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT COMMON /PARTNR/ PEX,PEY,PEZET,PE0,PX4,PY4,SUMMAS * ,IC4,IPTNR,JS4,NPS DOUBLE PRECISION DIFF,ZFI REAL PSUM(5) INTEGER IC4(2) SAVE C----------------------------------------------------------------------- C INITIALIZATION C -------------- CDH IF ( ISH .EQ. 13 .OR. ISH .EQ. 14 ) CALL UTTIMA('*** JFRADE *** ') IER=0 IRET=0 ISH0=ISH IF ( ISHSUB/100 .EQ. 16 ) ISH=MOD(ISHSUB,100) IF ( NEVT .NE. 1 .OR. IFRADE .EQ. 0 ) GOTO 1000 NPTLPT=ABS(MAPROJ)+ABS(MATARG) IF ( ICHOIC .EQ. 1 .OR. ICHOIC .EQ. 4 ) THEN YCMMAX=LOG(EGYEVT*2.5) ETAPRO=YCMMAX*.6667 ETATAR=-ETAPRO ELSE ETAPRO=(YPJTL-YHAHA)*.6667 ETATAR=-YHAHA*.6667 ENDIF DETAP=ETAPRO DETAT=ETATAR TPRO=COSH(DETAP) ZPRO=SINH(DETAP) TTAR=COSH(DETAT) ZTAR=SINH(DETAT) C WRITE C ----- CALL UTPAGE IF ( ISH .GE. 91 ) THEN WRITE(IFCH,110)('-',L=1,79),IPAGE,('-',L=1,79) 110 FORMAT(1X,79A1/1X,I5,'.PAGE ' * ,'STRINGS BEFORE RESCALING'/1X,79A1/) DO 9 J=1,NSTR WRITE(IFCH,109)J,(ICSTR(K,J)/100,K=1,4) * ,SQRT(PSTR(1,J)**2+PSTR(2,J)**2),PSTR(3,J),PSTR(5,J) * ,IRLSTR(J) 109 FORMAT(' /CSTR/',I4,3X,4I5,3(E11.3),I4) 9 CONTINUE ENDIF C STRING RESCALING C ---------------- IF ( ICHOIC.LE.2 .AND. NSTR.GT.1 .AND. IRESCL.EQ.1 ) THEN PSUM(1)=0. PSUM(2)=0. IF ( ICHOIC .EQ. 1 ) THEN PSUM(3)=0. PSUM(4)=EGYEVT ELSE PSUM(3)=(NPJEVT-NTGEVT)*PNLLX PSUM(4)=NPJEVT*SQRT(AMPROJ**2+PNLLX**2) * +NTGEVT*SQRT(AMTARG**2+PNLLX**2) ENDIF PSUM(5)=SQRT(PSUM(4)**2-PSUM(3)**2) CALL HRESCL(1,NSTR,PSUM,IFAIL) IF ( IFAIL .NE. 0 ) GOTO 1001 ENDIF C WRITE C ----- CALL UTPAGE IF ( ISH .GE. 91 ) THEN WRITE(IFCH,111)('-',L=1,79),IPAGE,('-',L=1,79) 111 FORMAT(/1X,79A1/1X,I5,'.PAGE ' * ,'STRINGS AFTER RESCALING'/1X,79A1/) DO 10 J=1,NSTR WRITE(IFCH,109)J,(ICSTR(K,J)/100,K=1,4) * ,SQRT(PSTR(1,J)**2+PSTR(2,J)**2),PSTR(3,J),PSTR(5,J) * ,IRLSTR(J) 10 CONTINUE ENDIF C FRAGMENTATION C ------------- IF ( ISHSUB/100 .EQ. 3 ) ISH=MOD(ISHSUB,100) CDH IF ( ISH .EQ. 13 ) CALL UTTIMA(' ') DO 3 J=1,NSTR CALL UTPAGE IF ( ISH .GE. 91 ) WRITE(IFCH,102)('-',L=1,79),IPAGE,J * ,(ICSTR(K,J),K=1,4),SQRT(PSTR(1,J)**2+PSTR(2,J)**2 * +PSTR(3,J)**2),PSTR(4,J),PSTR(5,J),('-',L=1,79) 102 FORMAT(/1X,79A1 * /1X,I5,'.PAGE STR:',I3,4I7,3(E10.2)/1X,79A1/) CALL JAMFRA(J,NEWEVT) IF ( NEWEVT .EQ. 1 ) GOTO 10011 3 CONTINUE CDH IF ( ISH .EQ. 13 ) CALL UTTIMA('FRAGMENTATION ') C PRINT /CPTL/ C ------------ IF ( ISHSUB/100 .EQ. 9 ) ISH=MOD(ISHSUB,100) CALL UTPAGE IF ( ISH .GE. 91 ) THEN WRITE(IFCH,104)('-',L=1,79),IPAGE,('-',L=1,79) 104 FORMAT(/1X,79A1/1X,I5,'.PAGE ' * ,'PTLS AFTER FRAGMENTATION'/1X,79A1/) DO 18 N=1,NPTL IF ( N.GT.NPTLPT .OR. ISTPTL(N).NE.0 ) * WRITE(IFCH,116)IORPTL(N),JORPTL(N),N,IFRPTL(1,N),IFRPTL(2,N) * ,IDPTL(N),PPTL(3,N),PPTL(4,N),PPTL(5,N),ISTPTL(N) 18 CONTINUE ENDIF C INITIAL DECAY C ------------- IF ( ISHSUB/100 .EQ. 10 ) ISH=MOD(ISHSUB,100) CALL UTPAGE CDH IF ( ISH.EQ.13 ) CALL UTTIMA(' ') IF ( RADIAC .GT. 0. ) THEN TTAUS=TAUMIN IACN=1 ELSE TTAUS=AINFIN IACN=0 ENDIF TTP=TTAUS*TPRO TTT=TTAUS*TTAR ZZP=TTAUS*ZPRO ZZT=TTAUS*ZTAR IF ( ISH .GE. 91 ) THEN WRITE(IFCH,119)('-',L=1,79),IPAGE,SNGL(TTAUS),('-',L=1,79) 119 FORMAT(/1X,79A1/1X,I5,'.PAGE ' * ,'DECAY BEFORE TAU =',E10.3/1X,79A1/) ENDIF NP1=1 21 NP2=NPTL DO 5 I=NP1,NP2 IF ( TTAUS .LE. 0.D0 ) THEN DIFF = TIVPTL(2,I) - TTAUS ELSE ZFI=XORPTL(3,I)+(TIVPTL(2,I)-XORPTL(4,I))*PPTL(3,I)/PPTL(4,I) CALL UTTAUT(SNGL(ZFI),TZFI) DIFF = TIVPTL(2,I) - TZFI ENDIF IF ( DIFF .LE. 0. .OR. IACN.EQ.0 ) THEN IF ( ISTPTL(I) .EQ. 0 ) THEN CALL JDECA(I,IRET) IF ( IRET .EQ. 1 ) GOTO 1001 ENDIF ENDIF 5 CONTINUE NP1=NP2+1 IF ( NP1 .LE. NPTL ) GOTO 21 CDH IF ( ISH .EQ. 13 ) CALL UTTIMA('DECAY INI ') C INTERACTION AND DECAY C --------------------- IF ( IACN .EQ. 0 ) GOTO 5000 CALL UTPAGE IF ( ISH .GE. 91 ) THEN WRITE(IFCH,118)('-',L=1,79),IPAGE,('-',L=1,79) 118 FORMAT(/1X,79A1/1X,I5,'.PAGE ' * ,'INTERACTIONS AND DECAY'/1X,79A1/) ENDIF DTAUS=1./(NUMTAU-1.)*(TAUMAX-TAUMIN) DO 23 NT=1,NUMTAU NTC=NT TTAUS=TAUMIN+(NT-1.)*DTAUS TTP=TTAUS*TPRO TTT=TTAUS*TTAR ZZP=TTAUS*ZPRO ZZT=TTAUS*ZTAR IF ( IOJINT .EQ. 1 ) THEN CALL JINTA1 ELSEIF ( IOJINT .EQ. 2 ) THEN CALL JINTA2 ENDIF TTAUS=TTAUS+DTAUS TTP=TTAUS*TPRO TTT=TTAUS*TTAR ZZP=TTAUS*ZPRO ZZT=TTAUS*ZTAR NP1=1 36 NP2=NPTL DO 37 IP=NP1,NP2 IF ( TTAUS .LE. 0.D0 ) THEN DIFF = TIVPTL(2,IP) - TTAUS ELSE ZFI=XORPTL(3,IP)+(TIVPTL(2,IP)-XORPTL(4,IP)) * *PPTL(3,IP)/PPTL(4,IP) IF ( ZFI .LE. ZZT ) THEN DIFF = TIVPTL(2,IP) - TTT - (ZFI-ZZT)*ZZT/TTT ELSEIF ( ZFI .GE. ZZP ) THEN DIFF = TIVPTL(2,IP) - TTP - (ZFI-ZZP)*ZZP/TTP ELSE IF ( TTAUS .LT. AINFIN ) THEN IF ( TIVPTL(2,IP) .GE. 0. ) THEN DIFF = TIVPTL(2,IP) DIFF = DIFF**2 - (TTAUS**2+ZFI**2) ELSE DIFF = TIVPTL(2,IP) - SQRT(TTAUS**2+ZFI**2) ENDIF ELSE DIFF = TIVPTL(2,IP) - TTAUS IF ( ISH .GE. 90 ) THEN CALL UTMSG('JFRADE') WRITE(IFCH,*)'***** LARGE TTAUS; SET TZ=TTAUS' WRITE(IFCH,*)'TTAUS=',TTAUS,'ZFI=',ZFI CALL UTMSGF ENDIF ENDIF ENDIF ENDIF IF ( DIFF .LE. 0. ) THEN IF ( ISTPTL(IP) .EQ. 0 ) THEN CALL JDECA(IP,IRET) IF ( IRET .EQ. 1 ) GOTO 1001 ENDIF ENDIF 37 CONTINUE NP1=NP2+1 IF ( NP1 .LE. NPTL ) THEN DO 4 IP=NP1,NPTL IAAPTL(IP)=1 4 CONTINUE GOTO 36 ENDIF CDH IF ( ISH .EQ. 13 ) CALL UTTIMA('DECAY ') 23 CONTINUE C FINAL DECAY C ----------- CALL UTPAGE IF ( ISH .GE. 91 ) THEN WRITE(IFCH,120)('-',L=1,79),IPAGE,('-',L=1,79) 120 FORMAT(/1X,79A1/1X,I5,'.PAGE ' * ,'FINAL DECAY'/1X,79A1/) ENDIF NBEF=NPTL CDH N0BEF=NPTL0 NAFT=NPTL CDH N0AFT=NPTL0 IF ( NCLEAN .GT. 0 ) THEN CALL UTCLEA(NPTL0) NAFT=NPTL CDH N0AFT=NPTL0 ENDIF ISHNPT=ISH IF ( ISHSUB/100 .EQ. 19 ) ISH=MOD(ISHSUB,100) IF ( ISH .EQ. 22 ) THEN WRITE(IFMT,131)NBEF,NAFT 131 FORMAT(1X,'BEF FIN DE: NBEF=',I8,4X,'NAFT=',I8) ENDIF ISH=ISHNPT NP1=1 41 NP2=NPTL DO 42 IP=NP1,NP2 IF ( ISTPTL(IP) .EQ. 0 ) THEN CALL JDECA(IP,IRET) IF ( IRET .EQ. 1 ) GOTO 1001 ENDIF 42 CONTINUE NP1=NP2+1 IF ( NP1 .LE. NPTL ) THEN DO 6 IP=NP1,NPTL IAAPTL(IP)=1 6 CONTINUE GOTO 41 ENDIF ISHNPT=ISH IF ( ISHSUB/100 .EQ. 19 ) ISH=MOD(ISHSUB,100) IF ( ISH .EQ. 22 ) THEN WRITE(IFMT,132)NPTL 132 FORMAT(1X,'AFT FIN DE: NPTL=',I8) ENDIF ISH=ISHNPT CDH IF ( ISH .EQ. 13 ) CALL UTTIMA('DECAY FIN ') C PRINT /CPTL/ C ------------ CALL UTPAGE IF ( ISHSUB/100 .EQ. 11 ) ISH=MOD(ISHSUB,100) IF ( ISH .GE. 91 ) THEN WRITE(IFCH,117)('-',L=1,79),IPAGE,('-',L=1,79) 117 FORMAT(/1X,79A1/1X,I5,'.PAGE ' * ,'PTLS AFTER PERFORMING INTERACTIONS'/1X,79A1/ * 1X,' IOR',' JOR',4X,' N',4X,'IFR1IFR2',10X,'ID',3X, * 5X,'PTR',7X,'PZ',4X,'MASS ','IST'/) DO 34 N=1,NPTL IF ( N .GT. NPTLPT .OR. ISTPTL(N) .NE. 0 ) * WRITE(IFCH,116)IORPTL(N),JORPTL(N),N,IFRPTL(1,N),IFRPTL(2,N) * ,IDPTL(N),SQRT(PPTL(1,N)**2+PPTL(2,N)**2),PPTL(3,N),PPTL(5,N) * ,ISTPTL(N),IAAPTL(N) 116 FORMAT(1X,I7,I7,4X,I7,4X,I4,I4,I12,3(E10.2),1X,I2,I2) 34 CONTINUE ENDIF C TRAFO -> LAB CM C --------------- 5000 CONTINUE IF ( LABSYS .EQ. 1 ) THEN DO 7 I=1,NPTL AMT=SQRT(PPTL(5,I)**2+PPTL(1,I)**2+PPTL(2,I)**2) PZ=PPTL(3,I) E=PPTL(4,I) YI=SIGN( LOG((E+ABS(PZ))/AMT), PZ ) Y=YI+YHAHA PPTL(3,I)=AMT*SINH(Y) PPTL(4,I)=AMT*COSH(Y) 7 CONTINUE ENDIF C FINISH C ------ CALL UTPAGE IF ( ISH .GE. 91 ) THEN WRITE(IFCH,113)('-',L=1,79),IPAGE,('-',L=1,79) 113 FORMAT(/1X,79A1/1X,I5,'.PAGE ' * ,'PARTICLE PRODUCTION FINISHED'/1X,79A1/) CDH ELSEIF ( ISH .EQ. 13 ) THEN CDH CALL UTTIMA(' ') ENDIF GOTO 1000 10011 CONTINUE IF ( ISH .GE. 90 ) THEN CALL UTMSG('JFRADE') WRITE(IFCH,*)'***** FRAGMENTATION NOT POSSIBLE' WRITE(IFCH,112)J,(ICSTR(K,J)/100,K=1,4) * ,(PSTR(L,J),L=1,5) 112 FORMAT( ' STR:',3X,I4,3X,3X,4I5,5F7.2,F7.2) CALL UTMSGF ENDIF IER=1 GOTO 1000 1001 CONTINUE IER=1 GOTO 1000 1000 CONTINUE IF ( IER .EQ. 1 ) THEN IF ( ISH .GE. 90 ) THEN CALL UTMSG('JFRADE') WRITE(IFCH,*)'***** REDO EVENT',NREVT+1 CALL UTMSGF ENDIF ENDIF CDH IF ( ISH .EQ. 14 ) CALL UTTIMA(' JFRADE F ') ISH=ISH0 RETURN END C======================================================================= SUBROUTINE JINTA1 C---------------------------------------------------------------------- C SECONDARY INTERACTIONS C---------------------------------------------------------------------- PARAMETER (KOLLMX=2500) PARAMETER (MAMX=56) PARAMETER (MXDKY=2000) PARAMETER (MXINDX=1000) PARAMETER (MXLOOK=10000) PARAMETER (MXMA=11) PARAMETER (MXMX=6) PARAMETER (MXPTL=70000) PARAMETER (MXIFR=MXPTL) PARAMETER (MXRE=100) PARAMETER (MXSTR=3000) PARAMETER (NDEP=129) PARAMETER (NDET=129) PARAMETER (NFLAV=6) PARAMETER (NPRBMS=20) PARAMETER (NSIX=40) PARAMETER (NHA=NSIX+2) COMMON /ACCUM/ AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT * ,NRPTL,NRSTR,NTEVT COMMON /CEVT/ BIMEVT,COLEVT,EGYEVT,PHIEVT,PMXEVT * ,KOLEVT,NEVT,NPJEVT,NTGEVT COMMON /CIFRIJ/ IFRIJ(MXIFR) COMMON /CJINT/ BX,BY,RNUP,RNUT,VELP,VELT,XAVER(4),NPTL0 COMMON /CKOL/ KOL COMMON /CNCE/ NCES,NCOLEX COMMON /CNFR/ NRFRA COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /COL/ BIMP,BMAX,COORD(4,KOLLMX),DISTCE(KOLLMX) * ,QDEP(NDEP),QDET14(NDET),QDET16(NDET),QDET40(NDET) * ,QDET99(NDET),RMPROJ,RMTARG(4),XDEP(NDEP) * ,XDET14(NDET),XDET16(NDET),XDET40(NDET) * ,XDET99(NDET) * ,KOLL,LTARG,NORD(KOLLMX),NPROJ,NRPROJ(KOLLMX) * ,NRTARG(KOLLMX),NTARG COMMON /CPRBMS/ PRBMS(NPRBMS) COMMON /CPROJA/ IPROJ,ITARG,KPROJA(NHA,MAMX),KTARGA(NHA,MAMX) COMMON /CPTL/ PPTL(5,MXPTL),TIVPTL(2,MXPTL),XORPTL(4,MXPTL) * ,IBPTL(4,MXPTL),ICLPTL(MXPTL),IDPTL(MXPTL) * ,IFRPTL(2,MXPTL),IORPTL(MXPTL),ISTPTL(MXPTL) * ,JORPTL(MXPTL),NPTL,NQJPTL(MXPTL) COMMON /CREMA/ REMA(MXRE,MXMA),REWI(MXRE,MXMA) * ,ICRE1(MXRE,MXMA),ICRE2(MXRE,MXMA) * ,IDMX(MXMA,MXMX),INDX(MXINDX) COMMON /CSTR/ PSTR(5,MXSTR),ROTSTR(3,MXSTR),XORSTR(4,MXSTR) * ,ICSTR(4,MXSTR),IORSTR(MXSTR),IRLSTR(MXSTR),NSTR COMMON /CTIMEL/ NTC DOUBLE PRECISION DETAP,DETAT,TPRO,TTAR,TTAUS,TTP,TTT * ,ZPRO,ZTAR,ZZP,ZZT COMMON /CTTAUS/ DETAP,DETAT,TPRO,TTAR,TTAUS,TTP,TTT * ,ZPRO,ZTAR,ZZP,ZZT COMMON /C2PTL/ AMIPTL(MXPTL),RADPTL(MXPTL),IAAPTL(MXPTL) COMMON /C4PTL/ OPTL(MXPTL),TPTL(MXPTL),UPTL(MXPTL) * ,XPTL(MXPTL),YPTL(MXPTL),ZPTL(MXPTL) COMMON /DIDIB/ NDIDIB COMMON /DKYTAB/ CBR(MXDKY),LOOK(MXLOOK),MODE(5,MXDKY) COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT COMMON /PARTNR/ PEX,PEY,PEZET,PE0,PX4,PY4,SUMMAS * ,IC4,IPTNR,JS4,NPS DOUBLE PRECISION DD,DERR,TI1,TI2,TT,VV,VVP,VVT,XO3,XO4,ZZ,ZZA INTEGER IC4(2),JC(NFLAV,2),JCDU(NFLAV,2),JCI(NFLAV,2) LOGICAL IACPTL(MXPTL+10) DATA DERR/1.D-2/ SAVE C---------------------------------------------------------------------- C INITIALIZATION FOR NTC=1 C ------------------------ IF ( NTC .EQ. 1 ) THEN IF ( OVERLP.GE.0. .AND. MAPROJ.NE.0 .AND. MATARG.NE.0 ) THEN IF ( MAPROJ .EQ. 1 ) THEN RNUP=0. ELSE RNUP=1.19*MAPROJ**(0.3333333)-1.61*MAPROJ**(-0.3333333) ENDIF IF ( MATARG .EQ. 1 ) THEN RNUT=0. ELSE RNUT=1.19*MATARG**(0.3333333)-1.61*MATARG**(-0.3333333) ENDIF RNUP=RNUP+OVERLP RNUT=RNUT+OVERLP VELP=PPTL(3,1)/PPTL(4,1) VELT=PPTL(3,IABS(MAPROJ)+1)/PPTL(4,IABS(MAPROJ)+1) BX=COS(PHIEVT)*BIMEVT BY=SIN(PHIEVT)*BIMEVT ENDIF NPTL0=NPTL DO 51 I=1,NPTL0 IAAPTL(I)=1 CALL IDQUAC(I,NQI,NDUMMY,NDUMMY,JCI) IF ( NQI .NE. 0 ) THEN RADPTL(I)=RADIAC AMIPTL(I)=PROM+AMSIAC ELSE RADPTL(I)=RADIAS AMIPTL(I)=PIOM+AMSIAC ENDIF 51 CONTINUE ENDIF C INITIALIZATION FOR EACH NTC C --------------------------- NT=NTC CALL UTPAGE CDH IF ( ISH .EQ. 13 ) CALL UTTIMA(' ') NBEF=NPTL CDH N0BEF=NPTL0 NAFT=NPTL CDH N0AFT=NPTL0 IF ( NCLEAN .GT. 0 ) THEN IF ( MOD(NT-1,NCLEAN) .EQ. 0 ) THEN CALL UTCLEA(NPTL0) NAFT=NPTL CDH N0AFT=NPTL0 ENDIF ENDIF TAUS=TTAUS NPTLPT=ABS(MAPROJ)+ABS(MATARG) IF ( NPTL .GT. NPTL0 ) THEN DO 52 I=NPTL0+1,NPTL CALL IDQUAC(I,NQI,NDUMMY,NDUMMY,JCI) IF ( NQI .NE. 0 ) THEN RADPTL(I)=RADIAC AMIPTL(I)=PROM+AMSIAC ELSE RADPTL(I)=RADIAS AMIPTL(I)=PIOM+AMSIAC ENDIF 52 CONTINUE ENDIF DO 44 I=1,NPTL IF ( ICLPTL(I).EQ.0 .AND. PPTL(5,I).GT.AMIPTL(I) ) THEN IACPTL(I)=.TRUE. ELSE IACPTL(I)=.FALSE. ENDIF IF ( IORPTL(I).EQ.-1 ) IACPTL(I)=.TRUE. C CALL UTTAIN IS REPLACED HERE TO AVOID OVERHEAD C CALL UTTAIN(I,X,Y,Z,T,N,0) XO4=XORPTL(4,I) C* IF ( IOPT .EQ. 0 ) THEN TI1=TIVPTL(1,I) C* ELSEIF ( IOPT .EQ. 1 ) THEN C* TI1=XO4 C* ENDIF TI2=TIVPTL(2,I) IF ( TI1 .GT. TI2 ) GOTO 1009 PPT4I = 1./PPTL(4,I) VV=PPTL(3,I)*PPT4I XO3=XORPTL(3,I) ZZ=XO3+(TI2-XO4)*VV IF ( TTAUS .LE. 0.D0 ) THEN TZ=TTAUS ELSE IF ( ZZ .LE. ZZT ) THEN TZ=TTT+(ZZ-ZZT)*ZZT/TTT ELSEIF ( ZZ .GE. ZZP ) THEN TZ=TTP+(ZZ-ZZP)*ZZP/TTP ELSE IF ( TTAUS .GE. AINFIN ) THEN TZ=TTAUS IF ( ISH .GE. 90 ) THEN CALL UTMSG('JINTA1') WRITE(IFCH,*)'***** LARGE TTAUS; SET TZ=TTAUS' WRITE(IFCH,*)'TTAUS=',TTAUS,'ZZ=',ZZ CALL UTMSGF ENDIF ELSE C*DH TZ=SQRT(TTAUS**2+ZZ**2) IF ( TI2 .LT. 0.D0 ) GOTO 1002 IF ( TTAUS**2+ZZ**2 .GE. TI2**2 ) GOTO 1002 GOTO 1006 ENDIF ENDIF ENDIF IF ( TZ .GE. TI2 ) GOTO 1002 1006 ZZ=XO3+(TI1-XO4)*VV IF ( TTAUS .GT. 0.D0 ) THEN IF ( ZZ .LE. ZZT ) THEN TZ=TTT+(ZZ-ZZT)*ZZT/TTT ELSEIF ( ZZ .GE. ZZP ) THEN TZ=TTP+(ZZ-ZZP)*ZZP/TTP ELSE IF ( TTAUS .GE. AINFIN ) THEN TZ=TTAUS IF ( ISH .GE. 90 ) THEN CALL UTMSG('JINTA1') WRITE(IFCH,*)'***** LARGE TTAUS; SET TZ=TTAUS' WRITE(IFCH,*)'TTAUS=',TTAUS,'ZZ=',ZZ CALL UTMSGF ENDIF ELSE C*DH TZ=SQRT(TTAUS**2+ZZ**2) IF ( TI1 .LT. 0.D0 ) GOTO 1007 IF ( TTAUS**2+ZZ**2 .LE. TI1**2 ) GOTO 1001 GOTO 1007 ENDIF ENDIF ENDIF IF ( TZ .LE. TI1 ) GOTO 1001 1007 IF ( TTAUS .LE. 0.D0 ) THEN TT=TTAUS ZZ=XO3+(TT-XO4)*VV IF ( TT.LT.TI1 .OR. TT.GE.TI2 ) GOTO 1031 ELSE ZZA=XO3-XO4*VV VVT=ZZT/TTT TT=(TTT+(ZZA-ZZT)*VVT)/(1.D0-VV*VVT) ZZ=XO3+(TT-XO4)*VV IF ( ZZ .LE. ZZT ) THEN IF ( TT.LT.TI1 .OR. TT.GE.TI2 ) GOTO 1032 GOTO 1000 ENDIF VVP=ZZP/TTP TT=(TTP+(ZZA-ZZP)*VVP)/(1.D0-VV*VVP) ZZ=XO3+(TT-XO4)*VV IF ( ZZ .GE. ZZP ) THEN IF ( TT.LT.TI1 .OR. TT.GE.TI2 ) GOTO 1033 GOTO 1000 ENDIF DD=1.D0-VV**2 IF ( DD .EQ. 0.D0 ) THEN TT=-VV*(TTAUS**2+ZZA**2)*0.5D0/ZZA ELSE TT=(ZZA*VV+SQRT(ZZA**2+TTAUS**2*DD))/DD ENDIF ZZ=XO3+(TT-XO4)*VV IF ( TT.LT.TI1 .OR. TT.GE.TI2 ) GOTO 1034 IF ( TT .LT. 0.D0 ) GOTO 1035 IF ( ZZ.LE.ZZT .OR. ZZ.GE.ZZP ) GOTO 1004 IF ( ABS(TTAUS**2-(TT+ZZ)*(TT-ZZ)) * .GT. DERR*TTAUS**2 ) GOTO 1005 ENDIF 1000 N=0 1011 T=TT Z=ZZ X=XORPTL(1,I)+(T-XO4)*PPTL(1,I)*PPT4I Y=XORPTL(2,I)+(T-XO4)*PPTL(2,I)*PPT4I GOTO 53 1001 N=1 GOTO 53 1002 N=2 GOTO 53 1031 N=31 GOTO 1003 1032 N=32 GOTO 1003 1033 N=33 GOTO 1003 1034 N=34 1003 IF ( ABS(TT-TI1) .LE. DERR*ABS(TT) ) GOTO 1000 IF ( ABS(TT-TI2) .LE. DERR*ABS(TT) ) GOTO 1000 IF ( ISH .GE. 90 ) THEN CALL UTMSG('JINTA1') WRITE(IFCH,*)'***** TI1 < TT < TI2 NOT FULFILLED - ',N WRITE(IFCH,*)SNGL(TI1),SNGL(TT),SNGL(TI2) CALL UTMSGF ENDIF GOTO 1011 1035 CONTINUE IF ( ISH .GE. 90 ) THEN CALL UTMSG('JINTA1') WRITE(IFCH,*)'***** TT < 0 ( ',TT,' )' WRITE(IFCH,*)'VV,DD:',VV,DD WRITE(IFCH,*)'ZZA,TTAUS:',ZZA,TTAUS CALL UTMSGF ENDIF GOTO 1011 1004 N=4 IF ( ABS(ZZ-ZZT) .LE. DERR*ABS(ZZ) ) GOTO 1000 IF ( ABS(ZZ-ZZP) .LE. DERR*ABS(ZZ) ) GOTO 1000 IF ( ISH .GE. 90 ) THEN CALL UTMSG('JINTA1') WRITE(IFCH,*)'***** ZZT < ZZ < ZZP NOT FULFILLED' WRITE(IFCH,*)SNGL(ZZT),SNGL(ZZ),SNGL(ZZP) CALL UTMSGF ENDIF GOTO 1011 1005 N=5 IF ( ABS(TTAUS**2-(TT+ZZ)*(TT-ZZ)) .LE. DERR ) GOTO 1000 IF ( ISH .GE. 90 ) THEN CALL UTMSG('JINTA1') WRITE(IFCH,*)'***** TTAUS**2 .NE. (TT+ZZ)*(TT-ZZ)' WRITE(IFCH,*)SNGL(TTAUS**2),SNGL((TT+ZZ)*(TT-ZZ)) CALL UTMSGF ENDIF GOTO 1011 1009 N=9 53 CONTINUE IF ( N.EQ.2 ) THEN IF ( NCLEAN .GT. 0 ) THEN IF ( MOD(NT,NCLEAN).EQ.0 ) THEN ISTPTL(I)=2 ENDIF ENDIF IACPTL(I)=.TRUE. GOTO 54 ENDIF IF ( N.EQ.9 ) THEN IACPTL(I)=.TRUE. GOTO 54 ENDIF IF ( N.EQ.1 ) THEN IACPTL(I)=.TRUE. GOTO 54 ENDIF IF ( IAAPTL(I) .EQ. 0 ) THEN IACPTL(I)=.TRUE. GOTO 54 ENDIF IF ( ISTPTL(I) .EQ. 2 ) IACPTL(I)=.TRUE. IF ( ABS(IDPTL(I)) .LT. 100 * .AND. ABS(IDPTL(I)) .NE. 20 ) IACPTL(I)=.TRUE. IF ( IDPTL(I) .EQ. 441 .AND. JPSIFI .EQ. 0 ) IACPTL(I)=.TRUE. 54 XPTL(I)=X YPTL(I)=Y ZPTL(I)=Z TPTL(I)=T IF ( OVERLP.GE.0. .AND. MAPROJ.NE.0 .AND. MATARG.NE.0 ) THEN IF ( (X-BX*0.5)**2+(Y-BY*0.5)**2+(Z-VELP*TAUS)**2 * .LT. RNUP**2 .AND. * (X+BX*0.5)**2+(Y+BY*0.5)**2+(Z-VELT*TAUS)**2 * .LT. RNUT**2 ) IACPTL(I)=.TRUE. ENDIF 44 CONTINUE NPTL0=NPTL I=0 C I LOOP --> 24 C ------------- 9999 I=I+1 IF ( IACPTL(I) ) GOTO 24 J0=NPTLPT+1 IF ( I .GT. NPTLPT ) J0=I+1 IF ( I .GT. NPTL0 ) J0=1 C J LOOP --> 250 C ------------- J = J0-1 25 J = J+1 IF ( J .GT. NPTL ) GOTO 24 IF ( IACPTL(J) ) THEN IF ( IACPTL(J+1) ) THEN IF ( IACPTL(J+2) ) THEN IF ( IACPTL(J+3) ) THEN IF ( IACPTL(J+4) ) THEN IF ( IACPTL(J+5) ) THEN IF ( IACPTL(J+6) ) THEN IF ( IACPTL(J+7) ) THEN IF ( IACPTL(J+8) ) THEN IF ( IACPTL(J+9) ) THEN IF ( IACPTL(J+10) ) THEN J=J+10 GOTO 25 ELSE J=J+10 IF ( J .GT. NPTL ) GOTO 24 GOTO 26 ENDIF ELSE J=J+9 IF ( J .GT. NPTL ) GOTO 24 GOTO 26 ENDIF ELSE J=J+8 IF ( J .GT. NPTL ) GOTO 24 GOTO 26 ENDIF ELSE J=J+7 IF ( J .GT. NPTL ) GOTO 24 GOTO 26 ENDIF ELSE J=J+6 IF ( J .GT. NPTL ) GOTO 24 GOTO 26 ENDIF ELSE J=J+5 IF ( J .GT. NPTL ) GOTO 24 GOTO 26 ENDIF ELSE J=J+4 IF ( J .GT. NPTL ) GOTO 24 GOTO 26 ENDIF ELSE J=J+3 IF ( J .GT. NPTL ) GOTO 24 GOTO 26 ENDIF ELSE J=J+2 IF ( J .GT. NPTL ) GOTO 24 GOTO 26 ENDIF ELSE J=J+1 IF ( J .GT. NPTL ) GOTO 24 GOTO 26 ENDIF ENDIF 26 CONTINUE RADSQR=(RADPTL(I)+RADPTL(J))**2 IF ( (ZPTL(I)-ZPTL(J))**2 .GT. RADSQR ) GOTO 25 IF ( (YPTL(I)-YPTL(J))**2 .GT. RADSQR ) GOTO 25 IF ( (XPTL(I)-XPTL(J))**2 .GT. RADSQR ) GOTO 25 IF ( I .EQ. J ) GOTO 25 IF ( IORPTL(I).GT.0 .AND. IORPTL(J).EQ.IORPTL(I) ) GOTO 25 IF ( IORPTL(I) .EQ. J ) GOTO 25 IF ( IORPTL(J) .EQ. I ) GOTO 25 PDE=(PPTL(3,I)+PPTL(3,J))/(PPTL(4,I)+PPTL(4,J)) GAM2I=1.-PDE**2 IF ( GAM2I .EQ. 0. ) GOTO 25 IF ( (ZPTL(I)-ZPTL(J)-(TPTL(I)-TPTL(J))*PDE)**2 * .GT. RADSQR*GAM2I ) GOTO 25 IF ( (XPTL(I)-XPTL(J))**2+(YPTL(I)-YPTL(J))**2+ * 1./GAM2I*(ZPTL(I)-ZPTL(J)-(TPTL(I)-TPTL(J))*PDE)**2 * .GT. RADSQR ) GOTO 25 CALL JINTCC(I,J,IRET) IF ( IRET .EQ. 1 ) GOTO 25 IACTN=0 NPTL00=NPTL NSTR00=NSTR XAVER(1)=(XPTL(I)+XPTL(J))*0.5 XAVER(2)=(YPTL(I)+YPTL(J))*0.5 XAVER(3)=(ZPTL(I)+ZPTL(J))*0.5 XAVER(4)=(TPTL(I)+TPTL(J))*0.5 CALL JINTFS(I,J,NQIFUS,JC,AMIM,IRET) IF ( IRET .EQ. 1 ) GOTO 25 CALL JINTCE(I,J,AMIM,IACTN,IRET) IF ( IRET .EQ. 25 ) GOTO25 TIVPTL(2,I)=TPTL(I) TIVPTL(2,J)=TPTL(J) ISTPTL(I)=1 ISTPTL(J)=1 IACPTL(I)=.TRUE. IACPTL(J)=.TRUE. CALL JINTCH(I,J,KMAX) DO 30 K=1,KMAX N=IFRIJ(K) ISTPTL(N)=2 IACPTL(N)=.TRUE. 30 CONTINUE CALL JINTPA(I,J,KMAX) DO 31 K=1,KMAX N=IFRIJ(K) IACPTL(N)=.TRUE. 31 CONTINUE IF ( IACTN .EQ. 1 ) THEN DO 32 N=NPTL00+1,NPTL IAAPTL(N)=1 CALL IDQUAC(N,NQI,NDUMMY,NDUMMY,JCDU) IF ( NQI .EQ. 0 ) THEN RADPTL(N)=RADIAS AMIPTL(N)=PIOM+AMSIAC ELSE RADPTL(N)=RADIAC AMIPTL(N)=PROM+AMSIAC ENDIF IACPTL(N)=.FALSE. IF ( PPTL(5,N) .GT. AMIPTL(N) ) IACPTL(N)=.TRUE. CALL UTTAIN(N,X,Y,Z,T,K,0) IF ( K.EQ.1 .OR. K.EQ.2 .OR. K.EQ.9 ) IACPTL(N)=.TRUE. IF ( ABS(IDPTL(N)) .LT. 100 * .AND. ABS(IDPTL(N)) .NE. 20 ) IACPTL(N)=.TRUE. XPTL(N)=X YPTL(N)=Y ZPTL(N)=Z TPTL(N)=T IF ( OVERLP.GE.0. .AND. MAPROJ.NE.0 .AND. MATARG.NE.0 ) THEN IF ( (X-BX*.5)**2+(Y-BY*.5)**2+(Z-VELP*TAUS)**2 * .LT. RNUP**2 .AND. * (X+BX*.5)**2+(Y+BY*.5)**2+(Z-VELT*TAUS)**2 * .LT. RNUT**2 ) IACPTL(N)=.TRUE. ENDIF 32 CONTINUE GOTO 24 ENDIF CALL JINTEL(I,J,AMIM,IACTN) IF ( IACTN .EQ. 2 ) THEN DO 33 N=NPTL00+1,NPTL IF ( N .EQ. NPTL00+1 ) THEN IJ=I ELSEIF ( N .EQ. NPTL00+2 ) THEN IJ=J ENDIF RADPTL(N)=RADPTL(IJ) AMIPTL(N)=AMIPTL(IJ) XPTL(N)=XAVER(1) YPTL(N)=XAVER(2) ZPTL(N)=XAVER(3) TPTL(N)=XAVER(4) IACPTL(N)=.FALSE. IAAPTL(N)=1 33 CONTINUE GOTO 24 ENDIF CALL JINTFU(I,J,JC,IACTN) DO 34 N=NPTL00+1,NPTL IF ( NQIFUS .EQ. 0 ) THEN RADPTL(N)=RADIAS AMIPTL(N)=PIOM+AMSIAC ELSE RADPTL(N)=RADIAC AMIPTL(N)=PROM+AMSIAC ENDIF XPTL(N)=XAVER(1) YPTL(N)=XAVER(2) ZPTL(N)=XAVER(3) TPTL(N)=XAVER(4) IACPTL(N)=.FALSE. IAAPTL(N)=1 34 CONTINUE * GOTO 24 *250 GOTO 25 24 CONTINUE IF ( I .LT. NPTL-1 ) GOTO 9999 ISHNPT=ISH IF ( ISHSUB/100 .EQ. 19 ) ISH=MOD(ISHSUB,100) IF ( ISH .EQ. 22 ) THEN WRITE(IFMT,131)NT,NBEF,NAFT,NPTL 131 FORMAT(1X,'NT=',I5,4X,'NBEF=',I8,4X,'NAFT=',I8,4X,'NPTL=',I8) ENDIF ISH=ISHNPT CDH IF ( ISH .EQ. 13 ) CALL UTTIMA('INTERACTIONS ') RETURN END C======================================================================= SUBROUTINE JINTA2 C---------------------------------------------------------------------- C SECONDARY INTERACTIONS: PERCOLATION--CLUSTER MODEL C---------------------------------------------------------------------- PARAMETER (KOLLMX=2500) PARAMETER (MAMX=56) PARAMETER (MXDKY=2000) PARAMETER (MXINDX=1000) PARAMETER (MXLOOK=10000) PARAMETER (MXMA=11) PARAMETER (MXMX=6) PARAMETER (MXPTL=70000) PARAMETER (MXIFR=MXPTL) PARAMETER (MXRE=100) PARAMETER (MXSTR=3000) PARAMETER (NDEP=129) PARAMETER (NDET=129) PARAMETER (NFLAV=6) PARAMETER (NPRBMS=20) PARAMETER (NSIX=40) PARAMETER (NHA=NSIX+2) COMMON /ACCUM/ AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT * ,NRPTL,NRSTR,NTEVT COMMON /CEVT/ BIMEVT,COLEVT,EGYEVT,PHIEVT,PMXEVT * ,KOLEVT,NEVT,NPJEVT,NTGEVT COMMON /CIFRIJ/ IFRIJ(MXIFR) COMMON /CJINT/ BX,BY,RNUP,RNUT,VELP,VELT,XAVER(4),NPTL0 COMMON /CKOL/ KOL COMMON /CNCE/ NCES,NCOLEX COMMON /CNFR/ NRFRA COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /COL/ BIMP,BMAX,COORD(4,KOLLMX),DISTCE(KOLLMX) * ,QDEP(NDEP),QDET14(NDET),QDET16(NDET),QDET40(NDET) * ,QDET99(NDET),RMPROJ,RMTARG(4),XDEP(NDEP) * ,XDET14(NDET),XDET16(NDET),XDET40(NDET) * ,XDET99(NDET) * ,KOLL,LTARG,NORD(KOLLMX),NPROJ,NRPROJ(KOLLMX) * ,NRTARG(KOLLMX),NTARG COMMON /CPRBMS/ PRBMS(NPRBMS) COMMON /CPROJA/ IPROJ,ITARG,KPROJA(NHA,MAMX),KTARGA(NHA,MAMX) COMMON /CPTL/ PPTL(5,MXPTL),TIVPTL(2,MXPTL),XORPTL(4,MXPTL) * ,IBPTL(4,MXPTL),ICLPTL(MXPTL),IDPTL(MXPTL) * ,IFRPTL(2,MXPTL),IORPTL(MXPTL),ISTPTL(MXPTL) * ,JORPTL(MXPTL),NPTL,NQJPTL(MXPTL) COMMON /CREMA/ REMA(MXRE,MXMA),REWI(MXRE,MXMA) * ,ICRE1(MXRE,MXMA),ICRE2(MXRE,MXMA) * ,IDMX(MXMA,MXMX),INDX(MXINDX) COMMON /CSTR/ PSTR(5,MXSTR),ROTSTR(3,MXSTR),XORSTR(4,MXSTR) * ,ICSTR(4,MXSTR),IORSTR(MXSTR),IRLSTR(MXSTR),NSTR COMMON /CTIMEL/ NTC DOUBLE PRECISION DETAP,DETAT,TPRO,TTAR,TTAUS,TTP,TTT * ,ZPRO,ZTAR,ZZP,ZZT COMMON /CTTAUS/ DETAP,DETAT,TPRO,TTAR,TTAUS,TTP,TTT * ,ZPRO,ZTAR,ZZP,ZZT COMMON /C2PTL/ AMIPTL(MXPTL),RADPTL(MXPTL),IAAPTL(MXPTL) COMMON /C3PTL/ DESPTL(MXPTL),DEZPTL(MXPTL) COMMON /C4PTL/ OPTL(MXPTL),TPTL(MXPTL),UPTL(MXPTL) * ,XPTL(MXPTL),YPTL(MXPTL),ZPTL(MXPTL) COMMON /DIDIB/ NDIDIB COMMON /DKYTAB/ CBR(MXDKY),LOOK(MXLOOK),MODE(5,MXDKY) COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT COMMON /PARTNR/ PEX,PEY,PEZET,PE0,PX4,PY4,SUMMAS * ,IC4,IPTNR,JS4,NPS INTEGER IC4(2),JC(NFLAV,2),JCDU(NFLAV,2),JCI(NFLAV,2) LOGICAL IACPTL(MXPTL+10) SAVE C---------------------------------------------------------------------- C INITIALIZATION FOR NTC=1 C ------------------------ IF ( NTC .EQ. 1 ) THEN IF ( OVERLP.GE.0. .AND. MAPROJ.NE.0 .AND. MATARG.NE.0 ) THEN IF ( MAPROJ .EQ. 1 ) THEN RNUP=0. ELSE RNUP=1.19*MAPROJ**(.3333333)-1.61*MAPROJ**(-.3333333) ENDIF RNUP=RNUP+OVERLP IF ( MATARG .EQ. 1 ) THEN RNUT=0. ELSE RNUT=1.19*MATARG**(.3333333)-1.61*MATARG**(-.3333333) ENDIF RNUT=RNUT+OVERLP VELP=PPTL(3,1)/PPTL(4,1) VELT=PPTL(3,IABS(MAPROJ)+1)/PPTL(4,IABS(MAPROJ)+1) BX=COS(PHIEVT)*BIMEVT BY=SIN(PHIEVT)*BIMEVT ENDIF NPTL0=NPTL DO 51 I=1,NPTL0 IAAPTL(I)=1 CALL IDQUAC(I,NQI,NDUMMY,NDUMMY,JCI) IF ( NQI .EQ. 0 ) THEN RADPTL(I)=RADIAS DESPTL(I)=RADIAS DEZPTL(I)=0. AMIPTL(I)=PIOM+AMSIAC ELSE RADPTL(I)=RADIAC DESPTL(I)=RADIAC DEZPTL(I)=0. AMIPTL(I)=PROM+AMSIAC ENDIF 51 CONTINUE ENDIF C INITIALIZATION FOR EACH NTC C --------------------------- NT=NTC CALL UTPAGE CDH IF ( ISH .EQ. 13 ) CALL UTTIMA(' ') NBEF=NPTL CDH N0BEF=NPTL0 NAFT=NPTL CDH N0AFT=NPTL0 IF ( NCLEAN .GT. 0 ) THEN IF ( MOD(NT-1,NCLEAN) .EQ. 0 ) THEN CALL UTCLEA(NPTL0) NAFT=NPTL CDH N0AFT=NPTL0 ENDIF ENDIF TAUS=TTAUS NPTLPT=ABS(MAPROJ)+ABS(MATARG) IF ( NPTL .GT. NPTL0 ) THEN DO 52 I=NPTL0+1,NPTL CALL IDQUAC(I,NQI,NDUMMY,NDUMMY,JCI) IF ( NQI .EQ. 0 ) THEN RADPTL(I)=RADIAS DESPTL(I)=RADIAS DEZPTL(I)=0. AMIPTL(I)=PIOM+AMSIAC ELSE RADPTL(I)=RADIAC DESPTL(I)=RADIAC DEZPTL(I)=0. AMIPTL(I)=PROM+AMSIAC ENDIF 52 CONTINUE ENDIF DO 44 I=1,NPTL IF ( ICLPTL(I).EQ.0 .AND. PPTL(5,I).GT.AMIPTL(I) ) THEN IACPTL(I)=.TRUE. ELSE IACPTL(I)=.FALSE. ENDIF IF ( IORPTL(I).EQ.-1 ) IACPTL(I)=.TRUE. CALL UTTAIN(I,X,Y,Z,T,N,0) IF ( N.EQ.2 ) THEN IF ( NCLEAN .GT. 0 ) THEN IF ( MOD(NT,NCLEAN).EQ.0 ) THEN ISTPTL(I)=2 ENDIF ENDIF IACPTL(I)=.TRUE. GOTO 54 ENDIF IF ( N.EQ.9 ) THEN IACPTL(I)=.TRUE. GOTO 54 ENDIF IF ( N.EQ.1 ) THEN IACPTL(I)=.TRUE. GOTO 54 ENDIF IF ( IAAPTL(I) .EQ. 0 ) THEN IACPTL(I)=.TRUE. GOTO 54 ENDIF IF ( ISTPTL(I) .EQ. 2 ) IACPTL(I)=.TRUE. IF ( ABS(IDPTL(I)) .LT. 100 * .AND. ABS(IDPTL(I)) .NE. 20 ) IACPTL(I)=.TRUE. IF ( IDPTL(I) .EQ. 441 .AND. JPSIFI .EQ. 0 ) IACPTL(I)=.TRUE. 54 XPTL(I)=X YPTL(I)=Y ZPTL(I)=Z TPTL(I)=T CALL UTTAUS(Z,SZ) OPTL(I)=SZ+DESPTL(I) UPTL(I)=SZ-DESPTL(I) IF ( OVERLP.GE.0. .AND. MAPROJ.NE.0 .AND. MATARG.NE.0 ) THEN IF ( (X-BX*.5)**2+(Y-BY*.5)**2+(Z-VELP*TAUS)**2 .LT. RNUP**2 * .AND. (X+BX*.5)**2+(Y+BY*.5)**2+(Z-VELT*TAUS)**2 * .LT. RNUT**2 ) IACPTL(I)=.TRUE. ENDIF 44 CONTINUE NPTL0=NPTL I=0 C I LOOP --> 24 C ------------- 9999 I=I+1 IF ( IACPTL(I) ) GOTO 24 J0=NPTLPT+1 IF ( I .GT. NPTLPT ) J0=I+1 IF ( I .GT. NPTL0 ) J0=1 UPTLI = UPTL(I) OPTLI = OPTL(I) C J LOOP --> 250 C ------------- J = J0-1 25 J = J+1 IF ( J .GT. NPTL ) GOTO 24 IF ( IACPTL(J) ) THEN IF ( IACPTL(J+1) ) THEN IF ( IACPTL(J+2) ) THEN IF ( IACPTL(J+3) ) THEN IF ( IACPTL(J+4) ) THEN IF ( IACPTL(J+5) ) THEN IF ( IACPTL(J+6) ) THEN IF ( IACPTL(J+7) ) THEN IF ( IACPTL(J+8) ) THEN IF ( IACPTL(J+9) ) THEN IF ( IACPTL(J+10) ) THEN J=J+10 GOTO 25 ELSE J=J+10 IF ( J .GT. NPTL ) GOTO 24 GOTO 26 ENDIF ELSE J=J+9 IF ( J .GT. NPTL ) GOTO 24 GOTO 26 ENDIF ELSE J=J+8 IF ( J .GT. NPTL ) GOTO 24 GOTO 26 ENDIF ELSE J=J+7 IF ( J .GT. NPTL ) GOTO 24 GOTO 26 ENDIF ELSE J=J+6 IF ( J .GT. NPTL ) GOTO 24 GOTO 26 ENDIF ELSE J=J+5 IF ( J .GT. NPTL ) GOTO 24 GOTO 26 ENDIF ELSE J=J+4 IF ( J .GT. NPTL ) GOTO 24 GOTO 26 ENDIF ELSE J=J+3 IF ( J .GT. NPTL ) GOTO 24 GOTO 26 ENDIF ELSE J=J+2 IF ( J .GT. NPTL ) GOTO 24 GOTO 26 ENDIF ELSE J=J+1 IF ( J .GT. NPTL ) GOTO 24 GOTO 26 ENDIF ENDIF 26 IF ( OPTLI .LT. UPTL(J) ) GOTO 25 IF ( UPTLI .GE. OPTL(J) ) GOTO 25 RADSQR=(RADPTL(I)+RADPTL(J))**2 IF ( (YPTL(I)-YPTL(J))**2 .GT. RADSQR ) GOTO 25 IF ( (XPTL(I)-XPTL(J))**2 .GT. RADSQR ) GOTO 25 IF ( I .EQ. J ) GOTO 25 IF ( IORPTL(I).GT.0 .AND. IORPTL(J).EQ.IORPTL(I) ) GOTO 25 IF ( IORPTL(I) .EQ. J ) GOTO 25 IF ( IORPTL(J) .EQ. I ) GOTO 25 IF ( (XPTL(I)-XPTL(J))**2+(YPTL(I)-YPTL(J))**2 .GT. RADSQR ) * GOTO 25 CALL JINTCC(I,J,IRET) IF ( IRET .EQ. 1 ) GOTO 25 IACTN=0 NPTL00=NPTL NSTR00=NSTR XAVER(1)=(XPTL(I)+XPTL(J))*0.5 XAVER(2)=(YPTL(I)+YPTL(J))*0.5 XAVER(3)=(ZPTL(I)+ZPTL(J))*0.5 XAVER(4)=(TPTL(I)+TPTL(J))*0.5 CALL JINTFS(I,J,NQIFUS,JC,AMIM,IRET) IF ( IRET .EQ. 1 ) GOTO 25 CALL JINTCE(I,J,AMIM,IACTN,IRET) IF ( IRET .EQ. 25 ) GOTO 25 TIVPTL(2,I)=TPTL(I) TIVPTL(2,J)=TPTL(J) ISTPTL(I)=1 ISTPTL(J)=1 IACPTL(I)=.TRUE. IACPTL(J)=.TRUE. CALL JINTCH(I,J,KMAX) DO 30 K=1,KMAX N=IFRIJ(K) ISTPTL(N)=2 IACPTL(N)=.TRUE. 30 CONTINUE CALL JINTPA(I,J,KMAX) DO 31 K=1,KMAX N=IFRIJ(K) IACPTL(N)=.TRUE. 31 CONTINUE IF ( IACTN .EQ. 1 ) THEN DO 32 N=NPTL00+1,NPTL IAAPTL(N)=1 CALL IDQUAC(N,NQI,NDUMMY,NDUMMY,JCDU) IF ( NQI .EQ. 0 ) THEN RADPTL(N)=RADIAS DESPTL(N)=RADIAS DEZPTL(N)=0. AMIPTL(N)=PIOM+AMSIAC ELSE RADPTL(N)=RADIAC DESPTL(N)=RADIAC DEZPTL(N)=0. AMIPTL(N)=PROM+AMSIAC ENDIF IACPTL(N)=.FALSE. IF ( PPTL(5,N) .GT. AMIPTL(N) ) IACPTL(N)=.TRUE. CALL UTTAIN(N,X,Y,Z,T,K,0) IF ( K.EQ.1 .OR. K.EQ.2 .OR. K.EQ.9 ) IACPTL(N)=.TRUE. IF ( ABS(IDPTL(N)).LT.100 .AND. ABS(IDPTL(N)).NE.20 ) * IACPTL(N)=.TRUE. XPTL(N)=X YPTL(N)=Y ZPTL(N)=Z TPTL(N)=T CALL UTTAUS(Z,SZ) OPTL(N)=SZ+DESPTL(N) UPTL(N)=SZ-DESPTL(N) IF ( OVERLP.GE.0. .AND. MAPROJ.NE.0 .AND. MATARG.NE.0 ) THEN IF ( (X-BX*.5)**2+(Y-BY*.5)**2+(Z-VELP*TAUS)**2.LT.RNUP**2 * .AND. (X+BX*.5)**2+(Y+BY*.5)**2+(Z-VELT*TAUS)**2 * .LT.RNUT**2 ) IACPTL(N)=.TRUE. ENDIF 32 CONTINUE GOTO 24 ENDIF CALL JINTEL(I,J,AMIM,IACTN) IF ( IACTN .EQ. 2 ) THEN DO 33 N=NPTL00+1,NPTL IF ( N .EQ. NPTL00+1 ) THEN IJ=I ELSEIF ( N .EQ. NPTL00+2 ) THEN IJ=J ENDIF RADPTL(N)=RADPTL(IJ) DESPTL(N)=DESPTL(IJ) DEZPTL(N)=DEZPTL(IJ) AMIPTL(N)=AMIPTL(IJ) XPTL(N)=XAVER(1) YPTL(N)=XAVER(2) ZPTL(N)=XAVER(3) TPTL(N)=XAVER(4) Z=ZPTL(N) CALL UTTAUS(Z,SZ) OPTL(N)=SZ+DESPTL(N) UPTL(N)=SZ-DESPTL(N) IACPTL(N)=.FALSE. IAAPTL(N)=1 33 CONTINUE GOTO 24 ENDIF CALL JINTFU(I,J,JC,IACTN) DO 34 N=NPTL00+1,NPTL IF ( NQIFUS .EQ. 0 ) THEN RADPTL(N)=RADIAS DESPTL(N)=RADIAS DEZPTL(N)=0. AMIPTL(N)=PIOM+AMSIAC ELSE RADPTL(N)=RADIAC DESPTL(N)=RADIAC DEZPTL(N)=0. AMIPTL(N)=PROM+AMSIAC ENDIF XPTL(N)=XAVER(1) YPTL(N)=XAVER(2) ZPTL(N)=XAVER(3) TPTL(N)=XAVER(4) Z=ZPTL(N) CALL UTTAUS(Z,SZ) OPTL(N)=SZ+DESPTL(N) UPTL(N)=SZ-DESPTL(N) IACPTL(N)=.FALSE. IAAPTL(N)=1 34 CONTINUE IF ( ISH .EQ. 23 .AND. PPTL(5,NPTL) .GE. AMPRIF ) THEN N=NPTL CALL JINTFP(I,J,N, * XPTL(I),YPTL(I),RADPTL(I),OPTL(I),UPTL(I), * XPTL(J),YPTL(J),RADPTL(J),OPTL(J),UPTL(J), * XPTL(N),YPTL(N),RADPTL(N),OPTL(N),UPTL(N)) ENDIF * GOTO 24 *250 GOTO 25 24 CONTINUE IF ( I .LT. NPTL-1 ) GOTO 9999 IF ( ISH .EQ. 24 ) THEN IF ( TAUS.EQ.1. .OR. TAUS.EQ.2. .OR. * TAUS.EQ.4. .OR. TAUS.EQ.8. ) THEN DO 45 I=1,NPTL IF ( IACPTL(I) .AND. I .NE. NPTL ) GOTO 45 CALL JINTCL(I,XPTL(I),YPTL(I),RADPTL(I) * ,OPTL(I),UPTL(I),IACPTL(I)) 45 CONTINUE ENDIF ENDIF ISHNPT=ISH IF ( ISHSUB/100 .EQ. 19 ) ISH=MOD(ISHSUB,100) IF ( ISH .EQ. 22 ) THEN WRITE(IFMT,131)NT,NBEF,NAFT,NPTL 131 FORMAT(1X,'NT=',I5,4X,'NBEF=',I8,4X,'NAFT=',I8,4X,'NPTL=',I8) ENDIF ISH=ISHNPT CDH IF ( ISH .EQ. 13 ) CALL UTTIMA('INTERACTIONS ') RETURN END C======================================================================= SUBROUTINE JINTCC(I,J,IRET) C--------------------------------------------------------------------- C IRET=1 IF I = CHILD OF J C IRET=1 IF J = CHILD OF I C IRET=0 ELSE C--------------------------------------------------------------------- PARAMETER (MXPTL=70000) PARAMETER (MXIFR=MXPTL) COMMON /CPTL/ PPTL(5,MXPTL),TIVPTL(2,MXPTL),XORPTL(4,MXPTL) * ,IBPTL(4,MXPTL),ICLPTL(MXPTL),IDPTL(MXPTL) * ,IFRPTL(2,MXPTL),IORPTL(MXPTL),ISTPTL(MXPTL) * ,JORPTL(MXPTL),NPTL,NQJPTL(MXPTL) COMMON /C2PTL/ AMIPTL(MXPTL),RADPTL(MXPTL),IAAPTL(MXPTL) INTEGER IFR(MXIFR) SAVE C--------------------------------------------------------------------- IRET=0 DO 57 KK=1,2 IF ( KK .EQ. 1 ) THEN N=I M=J ELSE N=J M=I ENDIF K1=0 K2=0 LOOP=0 55 LOOP=LOOP+1 IF ( IFRPTL(1,N) .GT. 0 ) THEN DO 56 K=IFRPTL(1,N),IFRPTL(2,N) IF ( K .EQ. M ) GOTO 1001 K2=K2+1 IF ( K2 .GT. MXIFR ) THEN CALL UTSTOP('JINTCC: K2 > MXIFR ') ENDIF IFR(K2)=K 56 CONTINUE ENDIF K1=K1+1 IF ( K1 .LE. K2 ) THEN N=IFR(K1) GOTO 55 ENDIF 57 CONTINUE GOTO 1000 1001 IRET=1 1000 RETURN END C======================================================================= SUBROUTINE JINTCE(I,J,AMIM,IACTN,IRET) C---------------------------------------------------------------------- C COLOUR EXCHANGE INTERACTION OF PTLS I,J C INPUT: C I,J: PTL NUMBERS; AMF: MASS, AMIM: MIN MASS, OF FUSED OBJ C IACTN=1: CE DONE C IRET=0: CE DONE OR CRITERIA FOR CE NOT FULFILLED C IRET=25: SKIP C---------------------------------------------------------------------- PARAMETER (KOLLMX=2500) PARAMETER (MAMX=56) PARAMETER (MXDKY=2000) PARAMETER (MXINDX=1000) PARAMETER (MXLOOK=10000) PARAMETER (MXMA=11) PARAMETER (MXMX=6) PARAMETER (MXPTL=70000) PARAMETER (MXRE=100) PARAMETER (MXSTR=3000) PARAMETER (NDEP=129) PARAMETER (NDET=129) PARAMETER (NPRBMS=20) PARAMETER (NSI=6) PARAMETER (NSIX=40) PARAMETER (NHA=NSIX+2) COMMON /ACCUM/ AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT * ,NRPTL,NRSTR,NTEVT COMMON /CEVT/ BIMEVT,COLEVT,EGYEVT,PHIEVT,PMXEVT * ,KOLEVT,NEVT,NPJEVT,NTGEVT COMMON /CJINT/ BX,BY,RNUP,RNUT,VELP,VELT,XAVER(4),NPTL0 COMMON /CKOL/ KOL COMMON /CNCE/ NCES,NCOLEX COMMON /CNFR/ NRFRA COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /COL/ BIMP,BMAX,COORD(4,KOLLMX),DISTCE(KOLLMX) * ,QDEP(NDEP),QDET14(NDET),QDET16(NDET),QDET40(NDET) * ,QDET99(NDET),RMPROJ,RMTARG(4),XDEP(NDEP) * ,XDET14(NDET),XDET16(NDET),XDET40(NDET) * ,XDET99(NDET) * ,KOLL,LTARG,NORD(KOLLMX),NPROJ,NRPROJ(KOLLMX) * ,NRTARG(KOLLMX),NTARG COMMON /CPRBMS/ PRBMS(NPRBMS) COMMON /CPROJA/ IPROJ,ITARG,KPROJA(NHA,MAMX),KTARGA(NHA,MAMX) COMMON /CPTL/ PPTL(5,MXPTL),TIVPTL(2,MXPTL),XORPTL(4,MXPTL) * ,IBPTL(4,MXPTL),ICLPTL(MXPTL),IDPTL(MXPTL) * ,IFRPTL(2,MXPTL),IORPTL(MXPTL),ISTPTL(MXPTL) * ,JORPTL(MXPTL),NPTL,NQJPTL(MXPTL) COMMON /CREMA/ REMA(MXRE,MXMA),REWI(MXRE,MXMA) * ,ICRE1(MXRE,MXMA),ICRE2(MXRE,MXMA) * ,IDMX(MXMA,MXMX),INDX(MXINDX) COMMON /CSTR/ PSTR(5,MXSTR),ROTSTR(3,MXSTR),XORSTR(4,MXSTR) * ,ICSTR(4,MXSTR),IORSTR(MXSTR),IRLSTR(MXSTR),NSTR COMMON /CTIMEL/ NTC DOUBLE PRECISION DETAP,DETAT,TPRO,TTAR,TTAUS,TTP,TTT * ,ZPRO,ZTAR,ZZP,ZZT COMMON /CTTAUS/ DETAP,DETAT,TPRO,TTAR,TTAUS,TTP,TTT * ,ZPRO,ZTAR,ZZP,ZZT COMMON /C2PTL/ AMIPTL(MXPTL),RADPTL(MXPTL),IAAPTL(MXPTL) COMMON /DIDIB/ NDIDIB COMMON /DKYTAB/ CBR(MXDKY),LOOK(MXLOOK),MODE(5,MXDKY) COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT COMMON /PARTNR/ PEX,PEY,PEZET,PE0,PX4,PY4,SUMMAS * ,IC4,IPTNR,JS4,NPS DOUBLE PRECISION ARM(5),ARP(5),ARQ,BOO(5),ROT(3) REAL PROJ(NSI,NHA),PSUM(5),TARG(NSI,NHA) INTEGER IC(2),IC4(2) SAVE C---------------------------------------------------------------------- C INITIALIZATION C -------------- IRET=0 DELRAP=1.5 DELAMF=1.0 ISH00=ISH PNLLX0=PNLLX TAUS=TTAUS AMF=PPTL(5,NPTL+1) C CHECK WHETHER CE CRITERIA FULFILLED C ----------------------------------- VEI=PPTL(3,I)/PPTL(4,I) VEJ=PPTL(3,J)/PPTL(4,J) IF ( ABS(VEI) .LT. 1. .AND. ABS(VEJ) .LT. 1. ) THEN RAI=0.5*LOG((1.+VEI)/(1.-VEI)) RAJ=0.5*LOG((1.+VEJ)/(1.-VEJ)) ELSE RAI=0. RAJ=0. ENDIF IF ( .NOT. (AMF.GT.AMIM+DELAMF .AND. ABS(RAI-RAJ).GT.DELRAP * .AND. ABS(IDPTL(I)).LT.10000 * .AND. ABS(IDPTL(J)).LT.10000) ) GOTO 1000 IACTN=1 C PRINT C ----- IF ( ISH .GE. 91 ) THEN IF ( ISH .GE. 92 ) WRITE(IFCH,*)' ' WRITE(IFCH,101)NTC,TAUS 101 FORMAT(1X,'CO.EX. INTERACTION --- NT=',I3,' --- TAUS=',F6.2) IF ( ISH .GE. 92 ) WRITE(IFCH,*)' ' WRITE(IFCH,115)I,IDPTL(I) * ,(PPTL(K,I),K=3,5),(XORPTL(K,I),K=3,4) 115 FORMAT(1X,'/CPTL/',I8,I10 * ,1X,2(E10.2),E10.2,1X,2(E10.2),2X,I4) WRITE(IFCH,115)J,IDPTL(J) * ,(PPTL(K,J),K=3,5),(XORPTL(K,J),K=3,4) IF ( ISH .GE. 92 ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,*)'AMF,AMIM: ',AMF,AMIM WRITE(IFCH,*)'RAI,RAJ: ',RAI,RAJ WRITE(IFCH,*)' ' ENDIF ENDIF C INITIALIZATION C -------------- NPTL00=NPTL NSTR00=NSTR IPROJ=1 ITARG=1 DO 11 L=1,NHA KPROJA(L,1)=1 KTARGA(L,1)=1 11 CONTINUE KOL=1 COORD(1,1)=XAVER(1) COORD(2,1)=XAVER(2) COORD(3,1)=XAVER(3) COORD(4,1)=XAVER(4) IDP=IDPTL(I) IDM=IDPTL(J) DO 12 L=1,5 ARP(L)=PPTL(L,I) ARM(L)=PPTL(L,J) BOO(L)=PPTL(L,NPTL+1) 12 CONTINUE SROOT = ABS(PPTL(5,NPTL+1)) S=PPTL(5,NPTL+1)**2 C BOOSTS INTO I-J CM C ------------------ CALL UTLOB2(1,BOO(1),BOO(2),BOO(3),BOO(4),BOO(5) * ,ARP(1),ARP(2),ARP(3),ARP(4)) CALL UTLOB2(1,BOO(1),BOO(2),BOO(3),BOO(4),BOO(5) * ,ARM(1),ARM(2),ARM(3),ARM(4)) IF ( ARP(3) .LT. 0.D0 ) THEN IDQ=IDM IDM=IDP IDP=IDQ DO 14 L=1,5 ARQ=ARM(L) ARM(L)=ARP(L) ARP(L)=ARQ 14 CONTINUE ENDIF PNLLX=ARP(3) ROT(1)=(ARP(1)-ARM(1))*0.5D0 ROT(2)=(ARP(2)-ARM(2))*0.5D0 ROT(3)=(ARP(3)-ARM(3))*0.5D0 CALL UTROT2(1,ROT(1),ROT(2),ROT(3) * ,ARP(1),ARP(2),ARP(3)) CALL UTROT2(1,ROT(1),ROT(2),ROT(3) * ,ARM(1),ARM(2),ARM(3)) C CHECKS C ------ IF ( ARP(3) .LT. 0.D0 ) THEN IF ( ISH .GE. 90 ) THEN CALL UTMSG('JINTCE') WRITE(IFCH,*)'***** Z-COMP OF +JET < 0.' WRITE(IFCH,*)(SNGL(ARP(L)),L=1,4) WRITE(IFCH,*)(SNGL(ARM(L)),L=1,4) CALL UTMSGF ENDIF GOTO 10025 ENDIF IF ( ABS(SNGL(ARP(4)+ARM(4))-SROOT) .GT. * 2.E-2*SROOT ) THEN IF ( ISH .GE. 90 ) THEN CALL UTMSG('JINTCE') WRITE(IFCH,*)'***** ARP(4)+ARM(4)-SQRT(S) NONZERO' WRITE(IFCH,*)'VALUE: ',SNGL(ARP(4)+ARM(4))-SROOT WRITE(IFCH,*)'SQRT(S): ',SROOT WRITE(IFCH,*)(SNGL(ARP(I)),I=1,4) WRITE(IFCH,*)(SNGL(ARM(I)),I=1,4) CALL UTMSGF ENDIF ENDIF C FILL PROJ, TARG C --------------- CALL IDTR4(IDP,IC) DO 25 M=1,NHA DO 24 N=1,NSI PROJ(N,M)=0. 24 CONTINUE 25 CONTINUE PROJ(5,1)=IC(1) PROJ(6,1)=IC(2) PROJ(5,2)=IC(1) PROJ(6,2)=IC(2) PROJ(1,2)=ARP(1) PROJ(2,2)=ARP(2) PROJ(3,2)=ARP(3) PROJ(4,2)=ARP(4) CALL IDTR4(IDM,IC) DO 28 M=1,NHA DO 27 N=1,NSI TARG(N,M)=0. 27 CONTINUE 28 CONTINUE TARG(5,1)=IC(1) TARG(6,1)=IC(2) TARG(5,2)=IC(1) TARG(6,2)=IC(2) TARG(1,2)=ARM(1) TARG(2,2)=ARM(2) TARG(3,2)=ARM(3) TARG(4,2)=ARM(4) C REDO C ---- CALL UTREMB(PROJ,TARG,1) LOO=1 GOTO 58 57 CONTINUE LOO=LOO+1 IF ( LOO .GT. 20 ) GOTO 10025 IF ( ISH .GE. 91 ) WRITE(IFCH,*)'REDO HH COLLISION' CALL UTREST(PROJ,TARG,1) 58 CONTINUE C NUMBER OF CE'S C -------------- NCOLEX=1 C-C LO=0 C-C16 LO=LO+1 C-C IF ( LO .EQ. 3 ) THEN C-C IF ( ISH .GE. 90 ) THEN C-C CALL UTMSG('JINTCE') C-C WRITE(IFCH,*)'***** LO=3' C-C CALL UTMSGF C-C ENDIF C-C ENDIF C-C R=RANGEN() C-C NCOLEX=0 C-C15 NCOLEX=NCOLEX+1 C-C IF ( NCOLEX .GT. NPRBMS ) GOTO 16 C-C IF ( R .GT. PRBMS(NCOLEX) ) GOTO 15 C DO NCOLEX CE'S C -------------- ISKIP=0 DO 30 NCE=1,NCOLEX IF ( ISH .GE. 92 .AND. NCE .GT. 1 ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,*)NCE,'. COLOUR EXCHANGE' WRITE(IFCH,*)' ' ENDIF NCES=NCE ISH=ISH-2 CALL HAHABS(PROJ,TARG,NCE/NCOLEX,NCE/NCOLEX,ISKIP,IRETHH) ISH=ISH+2 IF ( ISKIP .NE. 0 ) GOTO 10025 IF ( IRETHH .EQ. 1 ) GOTO 57 30 CONTINUE C FRAGMENTATION C ------------- IF ( NSTR .LE. NSTR00 ) GOTO 10050 IF ( ISH .GE. 92 ) THEN WRITE(IFCH,123) 123 FORMAT(/1X,'STRINGS BEFORE RESCALING'/) DO 31 L=NSTR00+1,NSTR WRITE(IFCH,109)L,(ICSTR(K,L)/100,K=1,4) * ,SQRT(PSTR(1,L)**2+PSTR(2,L)**2),PSTR(3,L),PSTR(5,L) * ,IRLSTR(L) 109 FORMAT(' /CSTR/',I5,3X,4I5,3(E11.3),I5) 31 CONTINUE ENDIF IF ( IRESCL .EQ. 1 ) THEN PSUM(1)=0. PSUM(2)=0. PSUM(3)=0. PSUM(4)=SROOT PSUM(5)=SROOT ISH=ISH-2 CALL HRESCL(NSTR00+1,NSTR,PSUM,IFAIL) ISH=ISH+2 IF ( IFAIL .NE. 0 ) GOTO 57 ENDIF IF ( ISH .GE. 92 ) THEN WRITE(IFCH,124) 124 FORMAT(/1X,'STRINGS AFTER RESCALING'/) DO 32 L=NSTR00+1,NSTR WRITE(IFCH,109)L,(ICSTR(K,L)/100,K=1,4) * ,SQRT(PSTR(1,L)**2+PSTR(2,L)**2),PSTR(3,L),PSTR(5,L) * ,IRLSTR(L) 32 CONTINUE ENDIF DO 33 L=NSTR00+1,NSTR IF ( ISH .GE. 92 ) WRITE(IFCH,122)L * ,(ICSTR(K,L),K=1,4) * ,SQRT(PSTR(1,L)**2+PSTR(2,L)**2),PSTR(3,L),PSTR(5,L) 122 FORMAT(/' STR:',I7,4I7,3(E10.2)/) ISH=ISH-2 CALL JAMFRA(L,NEWEVT) ISH=ISH+2 IF ( NEWEVT .EQ. 1 ) GOTO 10025 33 CONTINUE C BOOST PARTICLES FROM STRING FRAGMENTATION C ----------------------------------------- IF ( NPTL .LE. NPTL00 ) GOTO 10051 IORPTL(NPTL00+1)=I JORPTL(NPTL00+1)=J DO 34 L=1,5 PSUM(L)=0. 34 CONTINUE DO 38 N=NPTL00+1,NPTL DO 35 L=1,5 ARP(L)=PPTL(L,N) 35 CONTINUE CALL UTROT2(-1,ROT(1),ROT(2),ROT(3) * ,ARP(1),ARP(2),ARP(3)) CALL UTLOB2(-1,BOO(1),BOO(2),BOO(3),BOO(4),BOO(5) * ,ARP(1),ARP(2),ARP(3),ARP(4)) DO 36 L=1,5 PPTL(L,N)=ARP(L) 36 CONTINUE NQJPTL(N)=0 IF ( ISTPTL(N) .EQ. 0 ) THEN PSUM(1)=PSUM(1)+PPTL(1,N) PSUM(2)=PSUM(2)+PPTL(2,N) PSUM(3)=PSUM(3)+PPTL(3,N) PSUM(4)=PSUM(4)+PPTL(4,N) ENDIF IF ( ISH .GE. 91 ) THEN WRITE(IFCH,115)N,IDPTL(N) * ,(PPTL(K,N),K=3,5),(XORPTL(K,N),K=3,4),ISTPTL(N) ENDIF 38 CONTINUE IF ( ISH .GE. 90 ) THEN IF ( ISH .GE. 92 ) THEN WRITE(IFCH,*)'P_FIN:',(PSUM(K),K=1,4) WRITE(IFCH,*)'P_INI:',(BOO(K),K=1,4) ENDIF IF ( (ABS(BOO(1)-PSUM(1)) .GT. 5.E-3*ABS(BOO(1)) * .OR. ABS(BOO(2)-PSUM(2)) .GT. 5.E-3*ABS(BOO(2)) * .OR. ABS(BOO(3)-PSUM(3)) .GT. 5.E-3*ABS(BOO(3)) * .OR. ABS(BOO(4)-PSUM(4)) .GT. 1.E-1*ABS(BOO(4))) * .AND. * (ABS(BOO(1)-PSUM(1)) .GT. 5.E-3 * .OR. ABS(BOO(2)-PSUM(2)) .GT. 5.E-3 * .OR. ABS(BOO(3)-PSUM(3)) .GT. 5.E-3 * .OR. ABS(BOO(4)-PSUM(4)) .GT. 1.E-1) ) THEN CALL UTMSG('JINTCE') WRITE(IFCH,*)'***** P_INI /= P_FIN' WRITE(IFCH,*)'FINAL PARTICLES:' DO 39 N=NPTL00+1,NPTL WRITE(IFCH,125)N,IDPTL(N),(PPTL(K,N),K=1,5),ISTPTL(N) 125 FORMAT(1X,'/CPTL/',I6,I10,5(E11.3),I2) 39 CONTINUE WRITE(IFCH,*)'P_FIN:',(PSUM(K),K=1,4) WRITE(IFCH,*)'P_INI:',(SNGL(BOO(K)),K=1,4) CALL UTMSGF ENDIF ENDIF GOTO 1000 C FINISH C ------ 10025 CONTINUE IRET=25 IF ( ISH .GE. 91 ) WRITE(IFCH,*)'SKIP' NPTL=NPTL00 NSTR=NSTR00 GOTO 1000 10050 CONTINUE CALL UTMSG('JINTCE') WRITE(IFCH,*)'INCIDENT PARTICLES:' WRITE(IFCH,115)I,IDPTL(I),(PPTL(K,I),K=3,5) WRITE(IFCH,115)J,IDPTL(J),(PPTL(K,J),K=3,5) WRITE(IFCH,*)'NSTR=',NSTR,' NSTR00=',NSTR00 CALL UTMSGF CALL UTSTOP('JINTCE: NSTR .LE. NSTR00 ') 10051 CONTINUE CALL UTMSG('JINTCE') WRITE(IFCH,*)'INCIDENT PARTICLES:' WRITE(IFCH,115)I,IDPTL(I),(PPTL(K,I),K=3,5) WRITE(IFCH,115)J,IDPTL(J),(PPTL(K,J),K=3,5) WRITE(IFCH,*)'NSTR=',NSTR,' NSTR00=',NSTR00 WRITE(IFCH,*)'NPTL=',NPTL,' NPTL00=',NPTL00 CALL UTMSGF CALL UTSTOP('JINTCE: NPTL .LE. NPTL00 ') 1000 CONTINUE PNLLX=PNLLX0 ISH=ISH00 RETURN END C======================================================================= SUBROUTINE JINTCH(I,J,KMAX) C---------------------------------------------------------------------- C WRITES CHILDREN OF I,J TO IFRIJ(1-KMAX) C---------------------------------------------------------------------- PARAMETER (MXPTL=70000) PARAMETER (MXIFR=MXPTL) COMMON /CIFRIJ/ IFRIJ(MXIFR) COMMON /CPTL/ PPTL(5,MXPTL),TIVPTL(2,MXPTL),XORPTL(4,MXPTL) * ,IBPTL(4,MXPTL),ICLPTL(MXPTL),IDPTL(MXPTL) * ,IFRPTL(2,MXPTL),IORPTL(MXPTL),ISTPTL(MXPTL) * ,JORPTL(MXPTL),NPTL,NQJPTL(MXPTL) COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT SAVE C---------------------------------------------------------------------- KCUR=0 KMAX=0 LOOP=0 31 LOOP=LOOP+1 IF ( LOOP .EQ. 1 ) THEN N=I ELSEIF ( LOOP .EQ. 2 ) THEN N=J ENDIF IF ( IFRPTL(1,N) .GT. 0 ) THEN IF ( ISH.GE.92 ) WRITE(IFCH,*)N,' ---> ',IFRPTL(1,N),IFRPTL(2,N) DO 30 K=IFRPTL(1,N),IFRPTL(2,N) KMAX=KMAX+1 IF ( KMAX .GT. MXIFR ) THEN CALL UTSTOP('JINTCH: KMAX > MXIFR ') ENDIF IFRIJ(KMAX)=K 30 CONTINUE ENDIF IF ( LOOP .EQ. 1 ) GOTO 31 KCUR=KCUR+1 IF ( KCUR .LE. KMAX ) THEN N=IFRIJ(KCUR) GOTO 31 ENDIF RETURN END C======================================================================= SUBROUTINE JINTCL(I,X,Y,RAD,O,U,IAC) C--------------------------------------------------------------------- C FILLS HISTOGRAM CONCERNING CLUSTER CHARACTERISTICS C--------------------------------------------------------------------- PARAMETER (MXEPS=10) PARAMETER (MXPTL=70000) PARAMETER (MXTAU=4) PARAMETER (MXVOL=10) COMMON /ACCUM/ AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT * ,NRPTL,NRSTR,NTEVT COMMON /CJINTC/ CLUST(MXTAU,MXVOL,MXEPS) COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /CPTL/ PPTL(5,MXPTL),TIVPTL(2,MXPTL),XORPTL(4,MXPTL) * ,IBPTL(4,MXPTL),ICLPTL(MXPTL),IDPTL(MXPTL) * ,IFRPTL(2,MXPTL),IORPTL(MXPTL),ISTPTL(MXPTL) * ,JORPTL(MXPTL),NPTL,NQJPTL(MXPTL) DOUBLE PRECISION DETAP,DETAT,TPRO,TTAR,TTAUS,TTP,TTT * ,ZPRO,ZTAR,ZZP,ZZT COMMON /CTTAUS/ DETAP,DETAT,TPRO,TTAR,TTAUS,TTP,TTT * ,ZPRO,ZTAR,ZZP,ZZT COMMON /CVSN/ IVERSN COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /NEVNT/ NEVNT COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT COMMON /PARO5/ DELEPS,DELVOL CHARACTER AX*2 LOGICAL IAC SAVE C--------------------------------------------------------------------- TAU=SNGL(TTAUS) CDH ITAU=1+LOG(TAU)/LOG(2.) ITAU=1+LOG(TAU)*1.442695 IF ( IAC ) GOTO 1 VOL=(O-U)*RAD**2*PI IVOL=1+VOL/DELVOL EPS=PPTL(5,I)/VOL IEPS=1+EPS/DELEPS IF ( ITAU.GE.1 .AND. ITAU.LE.MXTAU .AND. * IVOL.GE.1 .AND. IVOL.LE.MXVOL .AND. * IEPS.GE.1 .AND. IEPS.LE.MXEPS ) * CLUST(ITAU,IVOL,IEPS)=CLUST(ITAU,IVOL,IEPS)+1 1 CONTINUE IF ( I .LT. NPTL .OR. NREVT+1 .LT. NEVNT ) GOTO 1000 IF ( ITAU .EQ. 1 ) WRITE(IFCH,105)MAPROJ,MATARG,ENGY,IVERSN/100. 105 FORMAT(/1X,'PROJ=',I3,3X,'TARG=',I3,3X,'ENGY=',F7.2 * ,3X,'VENUS ',F4.2,' (TURBOVENUS)') WRITE(IFCH,100)TAU,ITAU,NEVNT,DELVOL,DELEPS 100 FORMAT(/1X,'TAU=',F5.2,3X,'ITAU=',I1 * ,3X,'NEVNT=',I4,3X,'DELVOL=',F5.1,3X,'DELEPS=',F5.1/) WRITE(IFCH,101) 101 FORMAT(9X,'IVOL=1 IVOL=2 IVOL=3 IVOL=4 IVOL=5 ' * ,'IVOL=6 IVOL=7 IVOL=8 IVOL=9 IVOL=10 ') DO 106 IE=1,MXEPS IF ( IE .LE. 9 ) THEN WRITE(AX,102)IE 102 FORMAT('0',I1) ELSE WRITE(AX,103)IE 103 FORMAT(I2) ENDIF WRITE(IFCH,104)AX,(NINT(CLUST(ITAU,IV,IE)),IV=1,MXVOL) 104 FORMAT(' IEPS=',A2,10I7) 106 CONTINUE 1000 CONTINUE RETURN END C======================================================================= SUBROUTINE JINTEL(I,J,AMIM,IACTN) C---------------------------------------------------------------------- C ELASTIC SCATTERING OF PTLS I,J C EL SCATT REQUIR NOT FULF: RETURN WITHOUT ACTION, IACTN UNCHANGED C ELSE: ELASTIC SCATTERING DONE, IACTN=2 C---------------------------------------------------------------------- PARAMETER (MXPTL=70000) PARAMETER (NPTQ=129) COMMON /CJINT/ BX,BY,RNUP,RNUT,VELP,VELT,XAVER(4),NPTL0 COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /CPTL/ PPTL(5,MXPTL),TIVPTL(2,MXPTL),XORPTL(4,MXPTL) * ,IBPTL(4,MXPTL),ICLPTL(MXPTL),IDPTL(MXPTL) * ,IFRPTL(2,MXPTL),IORPTL(MXPTL),ISTPTL(MXPTL) * ,JORPTL(MXPTL),NPTL,NQJPTL(MXPTL) COMMON /CPTQ/ QPTH(NPTQ),QPTQ(NPTQ),XPTQ(NPTQ),QPTQMX,QPTHMX COMMON /CTIMEL/ NTC DOUBLE PRECISION DETAP,DETAT,TPRO,TTAR,TTAUS,TTP,TTT * ,ZPRO,ZTAR,ZZP,ZZT COMMON /CTTAUS/ DETAP,DETAT,TPRO,TTAR,TTAUS,TTP,TTT * ,ZPRO,ZTAR,ZZP,ZZT COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT REAL P(5),PEI(5),PEJ(5),U(5) SAVE C---------------------------------------------------------------------- C CHECK C ----- AMF=PPTL(5,NPTL+1) IF ( AMF .GE. AMIM ) GOTO 1000 C PRINT C ----- IF ( ISH .GE. 91 ) THEN WRITE(IFCH,101)NTC,SNGL(TTAUS) 101 FORMAT(1X,'ELASTIC SCATTERING --- NT=',I3,' --- TAUS=',F6.2) WRITE(IFCH,115)I,IDPTL(I) * ,(PPTL(K,I),K=3,5),(XORPTL(K,I),K=3,4) WRITE(IFCH,115)J,IDPTL(J) * ,(PPTL(K,J),K=3,5),(XORPTL(K,I),K=3,4) 115 FORMAT(1X,'/CPTL/',I6,I10 * ,1X,2(E10.2),E11.2,1X,2(E10.2),2X,I4) ENDIF C INITIALIZATION C -------------- IACTN=2 DO 125 K=1,5 P(K)=PPTL(K,NPTL+1) 125 CONTINUE C DETERMINE MOMENTA OF OUTGOING PARTICLES (PEI,PEJ) C ------------------------------------------------- IF ( P(5) .LE. (PPTL(5,I)+PPTL(5,J))*.99 ) THEN IF ( ISH .GE. 90 ) THEN CALL UTMSG('JINTEL') WRITE(IFCH,132)P(5),PPTL(5,I)+PPTL(5,J) 132 FORMAT(1X,'***** M_FUS < M_I+M_J ---> QCM SET ZERO ( ' * ,2F10.3,' )') WRITE(IFCH,133)'P_I: ',(PPTL(K,I),K=1,5) WRITE(IFCH,133)'P_J: ',(PPTL(K,J),K=1,5) WRITE(IFCH,133)'P_FUS:',(P(K),K=1,5) 133 FORMAT(1X,A6,3X,5F10.3) CALL UTMSGF ENDIF QCM=0. ELSEIF ( P(5) .LE. PPTL(5,I)+PPTL(5,J) ) THEN QCM=0. ELSE QCM=UTPCM(P(5),PPTL(5,I),PPTL(5,J)) ENDIF C ISOTROPIC U(3)=2.*RANGEN()-1. PHI=2.*PI*RANGEN() AUXIL=SQRT(1.-U(3)**2) U(1)=AUXIL*COS(PHI) U(2)=AUXIL*SIN(PHI) PEI(1)= QCM*U(1) PEJ(1)=-QCM*U(1) PEI(2)= QCM*U(2) PEJ(2)=-QCM*U(2) PEI(3)= QCM*U(3) PEJ(3)=-QCM*U(3) C NONISOTROPIC C-C R=RANGEN() C-C IF ( IOPTQ .EQ. 2 ) THEN C-C PT = SQRT( -4.*PTQ**2/PI * LOG(1.-QPTQMX*R) ) C-C ELSEIF ( IOPTQ .EQ. 3 ) THEN C-C PT = PTQ*SQRT( QPTQMX*R/(1.-QPTQMX*R) ) C-C ELSE C-C PT=UTINVT(NPTQ,XPTQ,QPTQ,R*QPTQ(NPTQ)) C-C ENDIF C-C IF ( PT .GE. QCM ) PT=RANGEN()*QCM C-C QPL=SQRT(QCM**2-PT**2) C-C U(3)=QPL C-C PHI=2.*PI*RANGEN() C-C U(1)=PT*COS(PHI) C-C U(2)=PT*SIN(PHI) C-C CALL UTAXIS(I,J,A1,A2,A3) C-C IVT=1 C-C IF ( A3 .LT. 0. ) THEN C-C A1=-A1 C-C A2=-A2 C-C A3=-A3 C-C IVT=-1 C-C ENDIF C-C CALL UTROTA(-1,A1,A2,A3,U(1),U(2),U(3)) C-C DO 47 K=1,3 C-C PEI(K)= U(K)*IVT C-C PEJ(K)=-U(K)*IVT C-C47 CONTINUE PEI(4)=SQRT(QCM**2+PPTL(5,I)**2) PEJ(4)=SQRT(QCM**2+PPTL(5,J)**2) PEI(5)=PPTL(5,I) PEJ(5)=PPTL(5,J) CALL UTLOBO(-1,P(1),P(2),P(3),P(4),P(5) * ,PEI(1),PEI(2),PEI(3),PEI(4)) CALL UTLOBO(-1,P(1),P(2),P(3),P(4),P(5) * ,PEJ(1),PEJ(2),PEJ(3),PEJ(4)) C FILL /CPTL/ C ----------- DO 49 LO=1,2 NPTL=NPTL+1 IF ( LO .EQ. 1 ) THEN IJ=I PPTL(1,NPTL)=PEI(1) PPTL(2,NPTL)=PEI(2) PPTL(3,NPTL)=PEI(3) PPTL(4,NPTL)=PEI(4) PPTL(5,NPTL)=PEI(5) ELSE IJ=J PPTL(1,NPTL)=PEJ(1) PPTL(2,NPTL)=PEJ(2) PPTL(3,NPTL)=PEJ(3) PPTL(4,NPTL)=PEJ(4) PPTL(5,NPTL)=PEJ(5) ENDIF ISTPTL(NPTL) =0 IDPTL(NPTL) =IDPTL(IJ) IBPTL(1,NPTL)=IBPTL(1,IJ) IBPTL(2,NPTL)=IBPTL(2,IJ) IBPTL(3,NPTL)=IBPTL(3,IJ) IBPTL(4,NPTL)=IBPTL(4,IJ) XORPTL(1,NPTL)=XAVER(1) XORPTL(2,NPTL)=XAVER(2) XORPTL(3,NPTL)=XAVER(3) XORPTL(4,NPTL)=XAVER(4) IORPTL(NPTL)=I JORPTL(NPTL)=J TIVPTL(1,NPTL)=XAVER(4) CALL IDTAU(IDPTL(NPTL),PPTL(4,NPTL),PPTL(5,NPTL),TAUGM) TIVPTL(2,NPTL)=TIVPTL(1,NPTL)+TAUGM IFRPTL(1,NPTL)=0 IFRPTL(2,NPTL)=0 ICLPTL(NPTL)=ICLPTL(IJ) NQJPTL(NPTL)=NQJPTL(IJ) IF ( ISH .GE. 91 ) WRITE(IFCH,115)NPTL,IDPTL(NPTL) * ,(PPTL(K,NPTL),K=3,5),(XORPTL(K,NPTL),K=3,4) 49 CONTINUE 1000 RETURN END C======================================================================= SUBROUTINE JINTFP(I,J,N, XPL1,YPL1,RADPL1,OPL1,UPL1, * XPL2,YPL2,RADPL2,OPL2,UPL2,XPL3,YPL3,RADPL3,OPL3,UPL3) C---------------------------------------------------------------------- C PRINTOUT C---------------------------------------------------------------------- PARAMETER (MXPTL=70000) COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /CPTL/ PPTL(5,MXPTL),TIVPTL(2,MXPTL),XORPTL(4,MXPTL) * ,IBPTL(4,MXPTL),ICLPTL(MXPTL),IDPTL(MXPTL) * ,IFRPTL(2,MXPTL),IORPTL(MXPTL),ISTPTL(MXPTL) * ,JORPTL(MXPTL),NPTL,NQJPTL(MXPTL) DOUBLE PRECISION DETAP,DETAT,TPRO,TTAR,TTAUS,TTP,TTT * ,ZPRO,ZTAR,ZZP,ZZT COMMON /CTTAUS/ DETAP,DETAT,TPRO,TTAR,TTAUS,TTP,TTT * ,ZPRO,ZTAR,ZZP,ZZT COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP REAL OPL(3),RADPL(3),UPL(3),XPL(3),YPL(3) CHARACTER AX*10,LIN*59,MARK*1,TXT*8 SAVE C---------------------------------------------------------------------- XPL(1) =XPL1 YPL(1) =YPL1 RADPL(1)=RADPL1 OPL(1) =OPL1 UPL(1) =UPL1 XPL(2) =XPL2 YPL(2) =YPL2 RADPL(2)=RADPL2 OPL(2) =OPL2 UPL(2) =UPL2 XPL(3) =XPL3 YPL(3) =YPL3 RADPL(3)=RADPL3 OPL(3) =OPL3 UPL(3) =UPL3 V1=(OPL1-UPL1)*RADPL1**2*PI V2=(OPL2-UPL2)*RADPL2**2*PI V3=(OPL3-UPL3)*RADPL3**2*PI WRITE(IFCH,103)SNGL(TTAUS) 103 FORMAT(' MONITORING FUSION INTERACTION AT TTAUS=',F5.2) TX=TTAUS TX=MAX(TX,1.) WRITE(TXT(3:7),104)TX 104 FORMAT(F5.2) WRITE(IFCH,105)'INCOMING:',I,IDPTL(I),PPTL(5,I),V1,PPTL(5,I)/V1 WRITE(IFCH,105)'INCOMING:',J,IDPTL(J),PPTL(5,J),V2,PPTL(5,J)/V2 WRITE(IFCH,105)'FUSED: ',N,IDPTL(N),PPTL(5,N),V3,PPTL(5,N)/V3 105 FORMAT(1X,A9,2X,'NR=',I6,2X,'ID=',I9,2X,'MASS=',F5.1,2X * ,'VOL=',F5.1,2X,'EPS=',F4.1) DO 110 MM=1,3 IF ( MM .EQ. 1 ) THEN TXT(1:2)='S/' TXT(8:8)=':' ELSEIF ( MM .EQ. 2 ) THEN TXT='X: ' ELSEIF ( MM .EQ. 3 ) THEN TXT='Y: ' ENDIF AX='---------!' WRITE(IFCH,100)TXT,(AX,L=1,6) 100 FORMAT(2X,A8,3X,'-3',8X,'-2',8X,'-1',9X,'0',9X,'1',9X,'2',9X,'3' * /13X,' !',6A10) DO 109 K=1,3 DO 108 L=1,59 WO=-3.+L*0.1 + 0.05 WU=-3.+L*0.1 - 0.05 IF ( MM .EQ. 1 ) THEN O=OPL(K)/TX U=UPL(K)/TX ELSEIF ( MM .EQ. 2 ) THEN O=XPL(K)+RADPL(K) U=XPL(K)-RADPL(K) ELSEIF ( MM .EQ. 3 ) THEN O=YPL(K)+RADPL(K) U=YPL(K)-RADPL(K) ENDIF IF ( K .EQ. 3 ) THEN MARK='X' ELSE MARK='O' ENDIF IF ( WU .LE. O .AND. WO .GE. U ) THEN LIN(L:L)=MARK ELSE LIN(L:L)=' ' ENDIF 108 CONTINUE WRITE(IFCH,101)U,O,LIN 101 FORMAT(1X,2F6.2,' !',A59,'!') 109 CONTINUE WRITE(IFCH,102)('-',L=1,59) 102 FORMAT(13X,' !',59A1,'!') 110 CONTINUE RETURN END C======================================================================= SUBROUTINE JINTFS(I,J,NQI,JC,AMIM,IRET) C---------------------------------------------------------------------- C INPUT: PTL NUMBERS I,J C OUTPUT: PPFUS(5): MOMENTUM , NQI: NET QUARK NUMBER, C JC: JC-CODE, AMIM: MINIMUM MASS, OF FUSED PTL C IRET=0 IF OK, 1 ELSE C PPFUS() WRITTEN TO PPTL(,NPTL+1) C---------------------------------------------------------------------- PARAMETER (MXPTL=70000) PARAMETER (NFLAV=6) COMMON /CJINT/ BX,BY,RNUP,RNUT,VELP,VELT,XAVER(4),NPTL0 COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /CPTL/ PPTL(5,MXPTL),TIVPTL(2,MXPTL),XORPTL(4,MXPTL) * ,IBPTL(4,MXPTL),ICLPTL(MXPTL),IDPTL(MXPTL) * ,IFRPTL(2,MXPTL),IORPTL(MXPTL),ISTPTL(MXPTL) * ,JORPTL(MXPTL),NPTL,NQJPTL(MXPTL) COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT DOUBLE PRECISION PPFUS(5),PP52 REAL P(5) INTEGER JC(NFLAV,2),JCI(NFLAV,2),JCJ(NFLAV,2) SAVE C---------------------------------------------------------------------- IRET=0 P(1)=PPTL(1,I)+PPTL(1,J) PPFUS(1)=P(1) P(2)=PPTL(2,I)+PPTL(2,J) PPFUS(2)=P(2) P(3)=PPTL(3,I)+PPTL(3,J) PPFUS(3)=P(3) P(4)=PPTL(4,I)+PPTL(4,J) PPFUS(4)=P(4) PP52=PPFUS(4)**2-PPFUS(3)**2-PPFUS(2)**2-PPFUS(1)**2 IF ( PP52 .LE. 0.D0 ) THEN IF ( ISH .GE. 90 ) THEN CALL UTMSG('JINTFS') WRITE(IFCH,*)'***** MFUS**2 < 0 (',PP52,' )' WRITE(IFCH,*)(PPFUS(M),M=1,4) CALL UTMSGF ENDIF GOTO 1001 ENDIF PPFUS(5)=SQRT(PP52) IF ( NPTL+1 .GT. MXPTL ) THEN CALL UTSTOP('JINTFS: NPTL>MXPTL ') ENDIF DO 36 K=1,5 PPTL(K,NPTL+1)=PPFUS(K) 36 CONTINUE AMF=PPFUS(5) ISTPTL(NPTL+1)=0 CALL IDQUAC(I,NDUMMY,NDUMMY,NDUMMY,JCI) CALL IDQUAC(J,NDUMMY,NDUMMY,NDUMMY,JCJ) NQI=0 DO 29 N=1,NFLAV JC(N,1)=JCI(N,1)+JCJ(N,1) JC(N,2)=JCI(N,2)+JCJ(N,2) NQI=NQI+JC(N,1)-JC(N,2) 29 CONTINUE CALL IDCOMJ(JC) AMIM=UTAMNZ(JC,5)+.200 IF ( AMF.LT.AMIM .AND. I.GT.NPTL0 .AND. J.GT.NPTL0 ) GOTO 1001 GOTO 1000 1001 IRET=1 1000 RETURN END C======================================================================= SUBROUTINE JINTFU(I,J,JC,IACTN) C---------------------------------------------------------------------- C FUSION OF PTLS I,J: DETERMINE CLUSTER C---------------------------------------------------------------------- PARAMETER (MXDKY=2000) PARAMETER (MXLOOK=10000) PARAMETER (MXPTL=70000) PARAMETER (NFLAV=6) COMMON /CJINT/ BX,BY,RNUP,RNUT,VELP,VELT,XAVER(4),NPTL0 COMMON /CPTL/ PPTL(5,MXPTL),TIVPTL(2,MXPTL),XORPTL(4,MXPTL) * ,IBPTL(4,MXPTL),ICLPTL(MXPTL),IDPTL(MXPTL) * ,IFRPTL(2,MXPTL),IORPTL(MXPTL),ISTPTL(MXPTL) * ,JORPTL(MXPTL),NPTL,NQJPTL(MXPTL) COMMON /CTIMEL/ NTC DOUBLE PRECISION DETAP,DETAT,TPRO,TTAR,TTAUS,TTP,TTT * ,ZPRO,ZTAR,ZZP,ZZT COMMON /CTTAUS/ DETAP,DETAT,TPRO,TTAR,TTAUS,TTP,TTT * ,ZPRO,ZTAR,ZZP,ZZT COMMON /DKYTAB/ CBR(MXDKY),LOOK(MXLOOK),MODE(5,MXDKY) COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT INTEGER IB(4),IC(2),JC(NFLAV,2) SAVE C---------------------------------------------------------------------- C PRINT C ----- IF ( ISH .GE. 91 ) THEN WRITE(IFCH,101)NTC,SNGL(TTAUS) 101 FORMAT(1X,'FUSION INTERACTION --- NT=',I3,' --- TAUS=',F6.2) WRITE(IFCH,115)I,IDPTL(I) * ,(PPTL(K,I),K=3,5),(XORPTL(K,I),K=3,4) WRITE(IFCH,115)J,IDPTL(J) * ,(PPTL(K,J),K=3,5),(XORPTL(K,I),K=3,4) 115 FORMAT(1X,'/CPTL/',I6,I10 * ,1X,2(E10.2),E11.3,1X,2(E10.2),2X,I4) ENDIF C INITIALIZATION C -------------- IACTN=3 AMF=PPTL(5,NPTL+1) NPTL=NPTL+1 C DETERMINE IDR, IB(1-4) C ---------------------- IDR=0 DO 40 NF=1,NFLAV IF ( JC(NF,1) .GE. 10 ) IDR=700000000 IF ( JC(NF,2) .GE. 10 ) IDR=700000000 40 CONTINUE IF ( IDR/100000000 .NE. 7 ) THEN CALL IDENCO(JC,IC,IRETEN) IF ( IRETEN .EQ. 1 ) THEN CALL UTSTOP('JINTFU: IDENCO RET CODE = 1 ') ENDIF ID=IDTRA(IC,0,0,3) 43 AMC=AMF CALL IDRES(ID,AMC,IDR,IADJ) IF ( IDR .NE. 0 ) THEN LID=LOOK(IABS(IDR)) IF ( LID.LE.0 .OR. LID.GT.0 .AND. MODE(2,LID).EQ.0 ) THEN IF ( PPTL(5,NPTL) .GT. AMC+1.E-3 ) THEN AMF=AMF+0.010 GOTO 43 ENDIF IF ( ABS(AMC-PPTL(5,NPTL)) .GT. 1.E-3 ) THEN IF ( ISH .GE. 90 ) THEN CALL UTMSG('JINTFU') WRITE(IFCH,*)'***** NOT ON MASS SHELL AFTER FUSION: ' * ,PPTL(5,NPTL),AMC CALL UTMSGF ENDIF ENDIF ENDIF ENDIF IF ( IDR .EQ. 0 ) THEN IF ( MOD(IC(1),100).NE.0 .OR. MOD(IC(2),100).NE.0 ) THEN IDR=900000000 ELSE IDR=800000000+IC(1)*100+IC(2)/100 ENDIF ENDIF ELSE CALL IDTRBI(JC,IB(1),IB(2),IB(3),IB(4)) IDR=IDR * +MOD(JC(1,1)+JC(2,1)+JC(3,1)+JC(4,1),10000)*10000 * +MOD(JC(1,2)+JC(2,2)+JC(3,2)+JC(4,2),10000) IF ( ISH .GE. 93 ) WRITE(IFCH,*) 'IB:',(IB(KK),KK=1,4) IBPTL(1,NPTL)=IB(1) IBPTL(2,NPTL)=IB(2) IBPTL(3,NPTL)=IB(3) IBPTL(4,NPTL)=IB(4) ENDIF C FILL /CPTL/ C ----------- IDPTL(NPTL)=IDR XORPTL(1,NPTL)=XAVER(1) XORPTL(2,NPTL)=XAVER(2) XORPTL(3,NPTL)=XAVER(3) XORPTL(4,NPTL)=XAVER(4) IORPTL(NPTL)=I JORPTL(NPTL)=J TIVPTL(1,NPTL)=XAVER(4) CALL IDTAU(IDPTL(NPTL),PPTL(4,NPTL),PPTL(5,NPTL),TAUGM) TIVPTL(2,NPTL)=TIVPTL(1,NPTL)+TAUGM IFRPTL(1,NPTL)=0 IFRPTL(2,NPTL)=0 ICLPTL(NPTL)=1 NQJPTL(NPTL)=0 C PRINT + RETURN C -------------- IF ( ISH .GE. 91 ) THEN N=NPTL WRITE(IFCH,115)N,IDPTL(N) * ,(PPTL(K,N),K=3,5),(XORPTL(K,N),K=3,4) ENDIF RETURN END C======================================================================= SUBROUTINE JINTPA(I,J,KMAX) C---------------------------------------------------------------------- C WRITES PARENTS OF I,J TO IFRIJ(1-KMAX) C SETS IAAPTL()=0 FOR PARENTS C---------------------------------------------------------------------- PARAMETER (MXPTL=70000) PARAMETER (MXIFR=MXPTL) COMMON /CIFRIJ/ IFRIJ(MXIFR) COMMON /CPTL/ PPTL(5,MXPTL),TIVPTL(2,MXPTL),XORPTL(4,MXPTL) * ,IBPTL(4,MXPTL),ICLPTL(MXPTL),IDPTL(MXPTL) * ,IFRPTL(2,MXPTL),IORPTL(MXPTL),ISTPTL(MXPTL) * ,JORPTL(MXPTL),NPTL,NQJPTL(MXPTL) COMMON /C2PTL/ AMIPTL(MXPTL),RADPTL(MXPTL),IAAPTL(MXPTL) COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT SAVE C---------------------------------------------------------------------- KCUR=0 KMAX=0 LOOP=0 12 LOOP=LOOP+1 IF ( LOOP .EQ. 1 ) THEN N=I ELSEIF ( LOOP .EQ. 2 ) THEN N=J ENDIF IF ( IORPTL(N) .GT. 0 ) THEN IF ( ISH .GE. 92 ) WRITE(IFCH,*)N,' <--- ',IORPTL(N),JORPTL(N) IF ( KMAX+2 .GT. MXIFR ) THEN CALL UTSTOP('JINTPA: KMAX+2 > MXIFR ') ENDIF IF ( IAAPTL(IORPTL(N)) .NE. 0 ) THEN KMAX=KMAX+1 IFRIJ(KMAX)=IORPTL(N) IAAPTL(IORPTL(N))=0 ENDIF IF ( JORPTL(N) .GT. 0 ) THEN IF ( IAAPTL(JORPTL(N)) .NE. 0 ) THEN KMAX=KMAX+1 IFRIJ(KMAX)=JORPTL(N) IAAPTL(JORPTL(N))=0 ENDIF ENDIF ENDIF IF ( LOOP .EQ. 1 ) GOTO 12 8 KCUR=KCUR+1 IF ( KCUR .LE. KMAX ) THEN N=IFRIJ(KCUR) IF ( IAAPTL(N) .NE. 0 ) THEN CALL UTSTOP('JINTPA: SHOULD NOT HAPPEN ') ENDIF GOTO 12 ENDIF RETURN END C======================================================================= SUBROUTINE JRESCL(J1,J2,PSUM,IFAIL) C----------------------------------------------------------------------- C RESCALES PTL MOMENTA OF PTLS J1-J2 TO HAVE TOTAL MOM PSUM. C----------------------------------------------------------------------- PARAMETER (MXPTL=70000) COMMON /ACCUM/ AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT * ,NRPTL,NRSTR,NTEVT COMMON /CPTL/ PPTL(5,MXPTL),TIVPTL(2,MXPTL),XORPTL(4,MXPTL) * ,IBPTL(4,MXPTL),ICLPTL(MXPTL),IDPTL(MXPTL) * ,IFRPTL(2,MXPTL),IORPTL(MXPTL),ISTPTL(MXPTL) * ,JORPTL(MXPTL),NPTL,NQJPTL(MXPTL) COMMON /CSCAL/ SCAL COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT DOUBLE PRECISION ENE,PADD(5),PP(5),PPSUM(5) REAL PSUM(5) DATA ERRLIM/.001/ SAVE C----------------------------------------------------------------------- IFAIL=1 IF ( J1 .GE. J2 ) THEN CALL UTSTOP('JRESCL: J1 .GE. J2 ') ENDIF DO 100 K=1,5 PPSUM(K)=PSUM(K) PADD(K)=0.D0 100 CONTINUE DO 110 J=J1,J2 DO 110 K=1,5 PADD(K)=PADD(K)+PPTL(K,J) 110 CONTINUE IF ( PADD (5) .GE. PPSUM(5) ) THEN IF ( ISH .GE. 90 ) THEN CALL UTMSG('JRESCL') WRITE(IFCH,*)'***** SUM OF PTL MASSES .GE. PPSUM(5)' DO 1 J=J1,J2 WRITE(IFCH,109)J,IDPTL(J),(PPTL(L,J),L=3,5) 109 FORMAT(' /CPTL/',I6,I10,3(E11.3)) 1 CONTINUE WRITE(IFCH,*)'PPSUM(345):',(SNGL(PPSUM(K)),K=3,5) CALL UTMSGF ENDIF RETURN ENDIF PADD(5)=PADD(4)**2-PADD(1)**2-PADD(2)**2-PADD(3)**2 IF ( PADD(5) .LE. 0.D0 ) THEN ENE = 0.D0 DO 111 J=J1,J2 ENE = ENE + DSQRT( PPTL(1,J)**2 + PPTL(2,J)**2 * + DBLE(PPTL(3,J))**2 + PPTL(5,J)**2 ) 111 CONTINUE PADD(5) = ENE**2 - PADD(1)**2 - PADD(2)**2 - PADD(3)**2 IF ( PADD(5) .LE. 0.D0 ) THEN DO 2 J=J1,J2 WRITE(IFCH,108)J,(PPTL(L,J),L=1,5) 108 FORMAT(' /CPTL/',I4,5(E11.3)) 2 CONTINUE CALL UTSTOP('JRESCL: MASS**2 OF STRING-SUM NEGATIVE ') ENDIF ENDIF PADD(5)=SQRT(PADD(5)) C BOOST PTLS TO REST C ------------------ DO 200 J=J1,J2 PP(1)=PPTL(1,J) PP(2)=PPTL(2,J) PP(3)=PPTL(3,J) PP(4)=PPTL(4,J) CALL UTLOB2(1,PADD(1),PADD(2),PADD(3),PADD(4),PADD(5) * ,PP(1),PP(2),PP(3),PP(4)) PPTL(1,J)=PP(1) PPTL(2,J)=PP(2) PPTL(3,J)=PP(3) PPTL(4,J)=PP(4) 200 CONTINUE C RESCALE MOMENTA IN REST FRAME C ----------------------------- SCAL=1. DO 301 IPASS=1,200 SUM=0. DO 310 J=J1,J2 PPTL(1,J)=SCAL*PPTL(1,J) PPTL(2,J)=SCAL*PPTL(2,J) PPTL(3,J)=SCAL*PPTL(3,J) PPTL(4,J)=SQRT(PPTL(1,J)**2+PPTL(2,J)**2+PPTL(3,J)**2 * +PPTL(5,J)**2) SUM=SUM+PPTL(4,J) 310 CONTINUE SCAL=PSUM(5)/SUM IF ( ABS(SCAL-1.) .LE. ERRLIM ) GOTO 300 301 CONTINUE IF ( ISH .GE. 90 ) THEN CALL UTMSG('JRESCL') WRITE(IFCH,*)'***** SCAL=',SCAL CALL UTMSGF ENDIF 300 CONTINUE C BOOST BACK WITH PPSUM C --------------------- DO 330 J=J1,J2 PP(1)=PPTL(1,J) PP(2)=PPTL(2,J) PP(3)=PPTL(3,J) PP(4)=PPTL(4,J) CALL UTLOB2(-1,PPSUM(1),PPSUM(2),PPSUM(3),PPSUM(4),PPSUM(5) * ,PP(1),PP(2),PP(3),PP(4)) PPTL(1,J)=PP(1) PPTL(2,J)=PP(2) PPTL(3,J)=PP(3) PPTL(4,J)=PP(4) 330 CONTINUE IFAIL=0 RETURN END C======================================================================= SUBROUTINE JSPLIT(STRO,STR,KOLSP,IER,KMAXOR) C----------------------------------------------------------------------- C SPLITS STRING STRO INTO Q-QBAR STRING STR AND REMAINDER (->STRO) C DIMENSIONS: STRO(NSI,NSIX+1),STR(NSI,2) C IER=0: OK ; IER=1: ERROR ; IER=2: ABSORPTION ; C IER=3: AGAIN WITH NEW APART, EPART C----------------------------------------------------------------------- PARAMETER (MAMX=56) PARAMETER (NFLAV=6) PARAMETER (NPTF=129) PARAMETER (NSI=6) PARAMETER (NSIX=40) PARAMETER (NHA=NSIX+2) PARAMETER (NSPLIT=129) COMMON /CJSPLI/ ALEAD,APART,ELEAD,EPART,SGNSIL,JPART,NSCC,NSCCX COMMON /CNFUSN/ NFUSN(NSIX+1) COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /CPROJA/ IPROJ,ITARG,KPROJA(NHA,MAMX),KTARGA(NHA,MAMX) COMMON /CPTF/ FPTFS,FPTFSS,FPTFU,FPTFUS,FPTFUU * ,QPTFS(NPTF),QPTFSS(NPTF),QPTFU(NPTF),QPTFUS(NPTF) * ,QPTFUU(NPTF),XPTF(NPTF) COMMON /CPZSTR/ ESTRL,PZSTRL,ISEA,ISTRL COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT COMMON /QUARKM/ SMAS,SSMAS,USMAS,UUMAS DOUBLE PRECISION A,D,DAUXIL,PAM,PAP,PEM,PEP,PIM,PIP,PNL3,PNL4 * ,PM,PO(5),POM,POP,POT,POX,POY,PO123,PP * ,PUM,PUP,PUT,PUX,PUY,PYM,PYP,SSTR(NSI,2) REAL STR(NSI,2),STRO(NSI,NSIX+1),STRO0(NSI,NSIX+1) INTEGER IC(2),ICX(2),JC(NFLAV,2),JCX(NFLAV,2) SAVE C----------------------------------------------------------------------- PUDX=PUD*.945 ISH0=ISH IF ( ISHSUB/100 .EQ. 15 ) ISH=MOD(ISHSUB,100) CALL UTKSTR(STRO,KMAX) IF ( KMAX .EQ. KMAXOR ) THEN NSCC=0 IF ( JPART .EQ. 0 ) THEN DO 5 I=1,KMAXOR NFUSN(I)=0 5 CONTINUE ENDIF ENDIF KMAX0=KMAX DO 10 K=1,KMAX DO 10 I=1,NSI STRO0(I,K)=STRO(I,K) 10 CONTINUE C-C PDIQ=PDIQUA*0.5 C-C IF ( KMAXOR .GT. KUTDIQ ) PDIQ=0. C-C PDIQ=PDIQUA*0.5*NSCCX/(KMAXOR-1.) PDIQ=0. LOOP=0 NCORN=0 XUNTER=0. XOBER=1. MESSCO=0 IF ( SGNSIL .LT. 0. ) THEN KOLSP=KTARGA(KMAX+1,ITARG) ELSE KOLSP=KPROJA(KMAX+1,IPROJ) ENDIF PAP=2.D0*EPART PAM=0.D0 PUX=STRO(1,KMAX) PUY=STRO(2,KMAX) PUT=SQRT(PUX**2+PUY**2) PUP=STRO(4,KMAX)-ABS(STRO(3,KMAX)) PUM=STRO(4,KMAX)+ABS(STRO(3,KMAX)) C PRINT C ----- IF ( ISH .GE. 92 ) THEN IF ( ISH .GE. 93 ) WRITE(IFCH,*)('-',L=1,79) WRITE(IFCH,*)'MULTI-STRING DETECTED. SPLIT OFF Q-QBAR STRING:' IF ( ISH .GE. 93 ) WRITE(IFCH,*)('-',L=1,79) WRITE(IFCH,*)' ' IF ( ISH .GE. 93 ) THEN WRITE(IFCH,*)'INPUT STRING STRO:' WRITE(IFCH,*)' ' WRITE(IFCH,105)(STRO(I,1),I=1,4),(NINT(STRO(I,1)),I=5,6) DO 8 K=2,KMAX WRITE(IFCH,104)(STRO(I,K),I=1,4),(NINT(STRO(I,K)),I=5,6) 8 CONTINUE WRITE(IFCH,*)' ' ENDIF ENDIF C ABSORPTION C ---------- IF ( ISTRL .EQ. 1 ) GOTO 1002 C RESET C ----- 5001 LOOP=0 5000 LOOP=LOOP+1 IF ( LOOP .GE. 5 ) GOTO 1002 KMAX=KMAX0 DO 11 I=1,NSI DO 11 K=1,KMAX STRO(I,K)=STRO0(I,K) 11 CONTINUE C SPLIT OFF HADRON + DETERMINE REMAINDER STRING (MOMENTA) C ------------------------------------------------------- IF ( RANGEN() .LT. PDIQ ) THEN NQU=2 ELSE NQU=1 ENDIF IFLTT=0 IFLTO=0 DO 24 I=1,NQU IFL=INT(RANGEN()/PUDX)+1 IFLTO=IFLTO*10+IFL IFLTT=IFLTT*10+(IFL+1)/2 24 CONTINUE R=RANGEN() IF ( IFLTT .EQ. 1 ) THEN IF ( IOPTF .EQ. 1 ) THEN PT=UTINVT(NPTF,XPTF,QPTFU ,R*QPTFU(NPTF)) C## WRITE(IFCH,*)'JSPLIT:PT(OLD)=',PT ELSE RPT = R*FPTFU AUXIL=-4.*PTF**2/PI PT=SQRT(AUXIL*LOG(1.+RPT*2./AUXIL)) ENDIF ELSEIF ( IFLTT .EQ. 2 ) THEN IF ( IOPTF .EQ. 1 ) THEN PT=UTINVT(NPTF,XPTF,QPTFS ,R*QPTFS(NPTF)) ELSE RPT = R*FPTFS AUXIL=-4.*PTF**2/PI PT=SQRT(AUXIL*LOG(EXP( SMAS**2/AUXIL)+RPT*2./AUXIL)- SMAS**2) ENDIF ELSEIF ( IFLTT .EQ. 11 ) THEN IF ( IOPTF .EQ. 1 ) THEN PT=UTINVT(NPTF,XPTF,QPTFUU,R*QPTFUU(NPTF)) ELSE RPT = R*FPTFUU AUXIL=-4.*PTF**2/PI PT=SQRT(AUXIL*LOG(EXP(UUMAS**2/AUXIL)+RPT*2./AUXIL)-UUMAS**2) ENDIF ELSEIF ( IFLTT .EQ. 12 .OR. IFLTT .EQ. 21 ) THEN IF ( IOPTF .EQ. 1 ) THEN PT=UTINVT(NPTF,XPTF,QPTFUS,R*QPTFUS(NPTF)) ELSE RPT = R*FPTFUS AUXIL=-4.*PTF**2/PI PT=SQRT(AUXIL*LOG(EXP(USMAS**2/AUXIL)+RPT*2./AUXIL)-USMAS**2) ENDIF ELSEIF ( IFLTT .EQ. 22 ) THEN IF ( IOPTF .EQ. 1 ) THEN PT=UTINVT(NPTF,XPTF,QPTFSS,R*QPTFSS(NPTF)) ELSE RPT = R*FPTFSS AUXIL=-4.*PTF**2/PI PT=SQRT(AUXIL*LOG(EXP(SSMAS**2/AUXIL)+RPT*2./AUXIL)-SSMAS**2) ENDIF ENDIF AT=SQRT(APART**2+PT**2) R=RANGEN() AUXIL=2.*R-1. IF ( AUXIL .LT. 0. ) THEN X = SQRT( 0.5-COS( (ACOS(-AUXIL)+PI)*.33333333 ) ) ELSE X = SQRT( 0.5+COS( (ACOS(AUXIL)+PI)*.33333333 ) ) ENDIF IF ( ESTRL .LE. ABS(PZSTRL) ) THEN XUNTER=1. ELSE YSTRL=.5*LOG((ESTRL+PZSTRL)/(ESTRL-PZSTRL)) XUNTER=ABS(0.94*SINH(YSTRL))/EPART IF ( XUNTER .GT. 1. ) XUNTER=1. ENDIF XUNTER=XUNTER-(XOBER-XUNTER) X=XUNTER+X*(XOBER-XUNTER) C-C EN=APART+X*(EPART-APART) PZ=X*EPART IF ( PZ .LT. 0. ) THEN SGNPO=-1. ELSE SGNPO=1. ENDIF EN=SQRT(PZ**2+AT**2) C-C IF ( AT .GT. EN ) AT=APART+RANGEN()*(EN-APART) C-C PT=SQRT((AT-APART)*(AT+APART)) PHI=2.*PI*RANGEN() PO(1)=PT*COS(PHI) PO(2)=PT*SIN(PHI) C-C PO(3)=SGNSIL*SQRT(EN**2-AT**2) PO(3)=SGNSIL*PZ PO(4)=EN PO123=SQRT(PO(3)**2+PO(2)**2+PO(1)**2) IF ( PO(4)-PO123 .GT. 0.D0 ) THEN PO(5)=SQRT((PO(4)-PO123)*(PO(4)+PO123)) ELSE PO(5)=0.D0 IF ( PO(4)-PO123 .LT. -1.D-4*PO(4) ) THEN IF(ISH.GE.90)THEN CALL UTMSG('JSPLIT') WRITE(IFCH,*)'***** !PO123! > PO4' WRITE(IFCH,*)'PO123,PO4:',PO123,PO(4) WRITE(IFCH,*)'PO1:',PO(1) WRITE(IFCH,*)'PO2:',PO(2) WRITE(IFCH,*)'PO3:',PO(3) WRITE(IFCH,*)'PO5:',PO(5) CALL UTMSGF ENDIF ENDIF ENDIF POX=PO(1) POY=PO(2) POT=SQRT(POX**2+POY**2) POP=PO(4)+ABS(PO(3))*SGNPO POM=PO(4)-ABS(PO(3))*SGNPO STRO(1,1)=STRO(1,1)+PO(1) STRO(2,1)=STRO(2,1)+PO(2) STRO(3,1)=STRO(3,1)-EPART*SGNSIL +PO(3) STRO(4,1)=STRO(4,1)-EPART +PO(4) STRO(1,KMAX)=0. STRO(2,KMAX)=0. STRO(3,KMAX)=0. STRO(4,KMAX)=0. IF ( PO(4)-ABS(PO(3)) .GT. 0.D0 ) THEN YLD=0.5*LOG((PO(4)+ABS(PO(3)))/(PO(4)-ABS(PO(3)))) ELSE YLD=100. ENDIF C DETERMINE SPLIT STRING (MOMENTA) C -------------------------------- PP=PAP+PUP PM=PAM+PUM PEP=PP-POP PEM=PM-POM IF ( PEP .LE. 0.D0 ) GOTO 5000 IF ( PEM .LE. 0.D0 ) GOTO 5000 A=(PEM*PEP-PUT**2-POT**2)*0.5D0 D=PUT*POT DAUXIL = A**2-D**2 IF ( DAUXIL .LT. 0.D0 ) GOTO 5000 DAUXIL=SQRT(DAUXIL) PYP=A+PUT**2-DAUXIL IF ( PYP .LT. 0.D0 .AND. PYP .GT. -1.D-6 ) PYP=0.D0 PYP=PYP/PEM PYM=A+POT**2-DAUXIL IF ( PYM .LT. 0.D0 .AND. PYM .GT. -1.D-6 ) PYM=0.D0 PYM=PYM/PEP IF ( PYP .LT. 0.D0 ) GOTO 5000 IF ( PYM .LT. 0.D0 ) GOTO 5000 PIP=PEP-PYP IF ( PIP .LT. 0.D0 ) GOTO 5000 PIM=PYM PAP=PYP PAM=PEM-PYM IF ( PAM .LT. 0.D0 ) GOTO 5000 SSTR(1,1)=-POX SSTR(2,1)=-POY SSTR(3,1)=SGNSIL*(PIP-PIM)*0.5D0 SSTR(4,1)=(PIP+PIM)*0.5D0 SSTR(1,2)=PUX SSTR(2,2)=PUY SSTR(3,2)=SGNSIL*(PAP-PAM)*0.5D0 SSTR(4,2)=(PAP+PAM)*0.5D0 PNL3=SSTR(3,1)+SSTR(3,2) PNL4=SSTR(4,1)+SSTR(4,2) IF ( PNL4-ABS(PNL3) .NE. 0. ) THEN YNL=0.5*LOG((PNL4+ABS(PNL3))/(PNL4-ABS(PNL3))) ELSE YNL=100. ENDIF STR(1,1)=SSTR(1,1) STR(2,1)=SSTR(2,1) STR(3,1)=SSTR(3,1) STR(4,1)=SSTR(4,1) STR(1,2)=SSTR(1,2) STR(2,2)=SSTR(2,2) STR(3,2)=SSTR(3,2) STR(4,2)=SSTR(4,2) C CHECKS C ------ IF ( ISH .GE. 90 ) THEN IF ( ABS(PIP*PIM-POT**2) .GT. 1.D-4 ) THEN CALL UTMSG('JSPLIT') WRITE(IFCH,*)'***** PIP*PIM /= POT**2' WRITE(IFCH,*)'PIP*PIM=',PIP*PIM WRITE(IFCH,*)'POT**2=',POT**2 WRITE(IFCH,*)'PIP=',PIP WRITE(IFCH,*)'PIM=',PIM WRITE(IFCH,*)'POT=',POT CALL UTMSGF ENDIF IF ( ABS(PAP*PAM-PUT**2) .GT. 1.D-4 ) THEN CALL UTMSG('JSPLIT') WRITE(IFCH,*)'***** PAP*PAM /= PUT**2' WRITE(IFCH,*)'PAP*PAM=',PAP*PAM WRITE(IFCH,*)'PUT**2=',PUT**2 WRITE(IFCH,*)'PAP=',PAP WRITE(IFCH,*)'PAM=',PAM WRITE(IFCH,*)'PUT=',PUT CALL UTMSGF ENDIF IF ( ABS(SSTR(4,1)**2 * -SSTR(1,1)**2-SSTR(2,1)**2-SSTR(3,1)**2) .GT. 1.D-4 ) THEN CALL UTMSG('JSPLIT') WRITE(IFCH,*)'***** MASS**2 OF STRING END 1 NONZERO' WRITE(IFCH,*)'MASS**2=',SSTR(4,1)**2 * -SSTR(1,1)**2-SSTR(2,1)**2-SSTR(3,1)**2 CALL UTMSGF ENDIF IF ( ABS(SSTR(4,2)**2 * -SSTR(1,2)**2-SSTR(2,2)**2-SSTR(3,2)**2) .GT. 1.D-4 ) THEN CALL UTMSG('JSPLIT') WRITE(IFCH,*)'***** MASS**2 OF STRING END 2 NONZERO' WRITE(IFCH,*)'MASS**2=',SSTR(4,2)**2 * -SSTR(1,2)**2-SSTR(2,2)**2-SSTR(3,2)**2 CALL UTMSGF ENDIF DO 14 N=1,4 IF ( ABS(STR(N,1)+STRO(N,1)-STRO0(N,1) * +STR(N,2)+STRO(N,KMAX)-STRO0(N,KMAX)) .GT. 1.E-4 * .AND. ABS(STR(N,1)+STRO(N,1)-STRO0(N,1) * +STR(N,2)+STRO(N,KMAX)-STRO0(N,KMAX)) * .GT. 1.E-4*ABS(STRO0(N,1)+STRO0(N,KMAX)) ) GOTO 15 14 CONTINUE GOTO 16 15 CONTINUE CALL UTMSG('JSPLIT') WRITE(IFCH,*)'***** P_STR + P_STRO /= P_STRO0' WRITE(IFCH,*)'P_STR + P_STRO:' WRITE(IFCH,104)((STR(N,1)+STR(N,2)+STRO(N,1) * +STRO(N,KMAX)),N=1,4) WRITE(IFCH,*)'P_STRO0:' WRITE(IFCH,104)((STRO0(N,1)+STRO0(N,KMAX)),N=1,4) WRITE(IFCH,*)'STR:' WRITE(IFCH,104)(STR(N,1),N=1,4) WRITE(IFCH,104)(STR(N,2),N=1,4) WRITE(IFCH,*)'STRO:' WRITE(IFCH,104)(STRO(N,1),N=1,4) WRITE(IFCH,104)(STRO(N,KMAX),N=1,4) WRITE(IFCH,*)'STRO0:' WRITE(IFCH,104)(STRO0(N,1),N=1,4) WRITE(IFCH,104)(STRO0(N,KMAX),N=1,4) CALL UTMSGF 16 CONTINUE IF ( ISH .GE. 93 ) THEN WRITE(IFCH,100)APART,EPART,EN,PT 100 FORMAT(3X,'APART,EPART,EN,PT:',4F13.5) WRITE(IFCH,101)(SNGL(PO(K)),K=1,5) 101 FORMAT(3X,'PO:',5F11.5/) IF ( NQU .EQ. 2 ) THEN WRITE(IFCH,*)'DIQUARK-ANTIDIQUARK BREAK' WRITE(IFCH,*)' ' ENDIF ENDIF ENDIF C FLAVOUR C ------- IC(1)=NINT(ABS(STRO(4+1,KMAX))) IC(2)=NINT(ABS(STRO(4+2,KMAX))) STR(4+1,2)=IC(1) STR(4+2,2)=IC(2) DO 4 N=1,NFLAV JCX(N,1)=0 JCX(N,2)=0 4 CONTINUE M=0 IF ( NQU .EQ. 1 ) THEN IF ( IC(1) .GT. 0 ) M=2 IF ( IC(2) .GT. 0 ) M=1 NFL=MOD(IFLTO,10) JCX(NFL,M)=JCX(NFL,M)+1 ELSEIF ( NQU .EQ. 2 ) THEN IF ( IC(1) .GT. 0 ) M=1 IF ( IC(2) .GT. 0 ) M=2 NFL=MOD(IFLTO,10) JCX(NFL,M)=JCX(NFL,M)+1 NFL=IFLTO/10 JCX(NFL,M)=JCX(NFL,M)+1 ENDIF IF ( M .EQ. 0 ) THEN CALL UTSTOP('JSPLIT: M = 0 ') ENDIF CALL IDENCO(JCX,ICX,IRETEN) IF ( IRETEN .EQ. 1 ) THEN CALL UTSTOP('JSPLIT: IDENCO RET CODE = 1 ') ENDIF STR(4+1,1)=ICX(1) STR(4+2,1)=ICX(2) CALL UTAMST(STR,AM,AMIN,IRET) IF ( IRET .NE. 0 ) GOTO 1002 IF ( NFUSN(KMAX) .EQ. 1 ) GOTO 1002 IC(1)=NINT(STRO(4+1,1)) IC(2)=NINT(STRO(4+2,1)) CALL IDDECO(IC,JC) DO 26 N=1,NQU IF ( N .EQ. 1 ) THEN NFL=MOD(IFLTO,10) ELSE NFL=IFLTO/10 ENDIF IF ( JC(NFL,M) .GT. 0 ) THEN JC(NFL,M)=JC(NFL,M)-1 ELSE JC(NFL,3-M)=JC(NFL,3-M)+1 ENDIF 26 CONTINUE NN=0 DO 27 N=1,NFLAV NN=NN+JC(N,1)+JC(N,2) 27 CONTINUE IF ( NN .EQ. 0 ) THEN NFL=INT(RANGEN()/PUDX)+1 JC(NFL,1)=1 JC(NFL,2)=1 ENDIF CALL IDENCO(JC,IC,IRETEN) IF ( IRETEN .EQ. 1 ) THEN IF ( ISH .GE. 90 .AND. MESSCO .EQ. 0 ) THEN CALL UTMSG('JSPLIT') WRITE(IFCH,*)'***** IDENCO RET CODE = 1. REDO JSPLIT' WRITE(IFCH,*)'JC:' WRITE(IFCH,*)JC CALL UTMSGF MESSCO=1 ENDIF GOTO 5000 ENDIF STRO(4+1,1)=IC(1) STRO(4+2,1)=IC(2) STRO(4+1,KMAX)=0. STRO(4+2,KMAX)=0. C OK C -- 1000 IER=0 NSCC=NSCC+1 GOTO 10002 C ERROR C ----- 1001 IER=1 IF ( ISH .GE. 90 ) THEN CALL UTMSG('JSPLIT') WRITE(IFCH,*)'***** SPLIT NOT POSSIBLE' CALL UTMSGF ENDIF GOTO 10001 C ABSORPTION C ---------- 1002 IER=2 NFUSN(KMAX)=1 IF ( ISH .GE. 92 ) THEN WRITE(IFCH,*)'ABSORPTION OF STRO(,KMAX)' WRITE(IFCH,*)' ' ENDIF DO 18 I=1,NSI STR(I,1)=0. STR(I,2)=0. 18 CONTINUE DO 17 K=1,KMAX DO 17 I=1,NSI STRO(I,K)=STRO0(I,K) 17 CONTINUE STRO(1,1)=STRO(1,1)+STRO(1,KMAX) STRO(2,1)=STRO(2,1)+STRO(2,KMAX) STRO(3,1)=STRO(3,1)+STRO(3,KMAX) STRO(4,1)=STRO(4,1)+STRO(4,KMAX) STRO(1,KMAX)=0. STRO(2,KMAX)=0. STRO(3,KMAX)=0. STRO(4,KMAX)=0. IC(1)=NINT(STRO(4+1,1)) IC(2)=NINT(STRO(4+2,1)) CALL IDDECO(IC,JC) ICX(1)=NINT(ABS(STRO(4+1,KMAX))) ICX(2)=NINT(ABS(STRO(4+2,KMAX))) CALL IDDECO(ICX,JCX) DO 22 NF=1,NFLAV JC(NF,1)=JC(NF,1)+JCX(NF,1) JC(NF,2)=JC(NF,2)+JCX(NF,2) 22 CONTINUE CALL IDENCO(JC,IC,IRETEN) IF ( IRETEN .EQ. 1 ) THEN IF ( ISH .GE. 90 ) THEN CALL UTMSG('JSPLIT') WRITE(IFCH,*)'***** IDENCO RET CODE = 1' * ,' (AFTER ABSORPTION)' WRITE(IFCH,*)'JC:' WRITE(IFCH,*)JC CALL UTMSGF ENDIF GOTO 1001 ENDIF STRO(5,1)=IC(1) STRO(6,1)=IC(2) STRO(5,KMAX)=0. STRO(6,KMAX)=0. GOTO 10002 C CHECK NSCC C ---------- 10002 CONTINUE IF ( KMAXOR.GT.2 .AND. KMAX.EQ.2 .AND. MAX(1,NSCC).NE.NSCCX ) THEN IER=3 IF ( ISH .GE. 91 ) THEN WRITE(IFCH,*)'REDO STRING PROCESSING WITH NEW APART, EPART' WRITE(IFCH,*)' ' ENDIF GOTO 10001 ENDIF C PRINT C ----- IF ( ISH .GE. 92 ) THEN IF ( ISH .GE. 93 ) THEN WRITE(IFCH,*)'REMAINDER STRING:' WRITE(IFCH,*)' ' WRITE(IFCH,105)(STRO(I,1),I=1,4),(NINT(STRO(I,1)),I=5,6) DO 9 K=2,KMAX WRITE(IFCH,104)(STRO(I,K),I=1,4),(NINT(STRO(I,K)),I=5,6) 9 CONTINUE WRITE(IFCH,*)' ' WRITE(IFCH,*)'SPLIT STRING:' WRITE(IFCH,*)' ' ENDIF WRITE(IFCH,105)(STR(I,1),I=1,4),(NINT(STR(I,1)),I=5,6) 105 FORMAT(' STR: ',4F13.5,2I8) WRITE(IFCH,104)(STR(I,2),I=1,4),(NINT(STR(I,2)),I=5,6) 104 FORMAT(' ',4F13.5,2I8) WRITE(IFCH,*)' ' ENDIF 10001 CONTINUE IF ( ISH .GE. 93 ) THEN WRITE(IFCH,*)('-',L=1,25) WRITE(IFCH,*)' RETURN FROM JSPLIT ' WRITE(IFCH,*)('-',L=1,25) WRITE(IFCH,*)' ' ENDIF ISH=ISH0 RETURN END C======================================================================= SUBROUTINE LEPEXP(RXBJ,RQSQ) C----------------------------------------------------------------------- C GENERATES X_BJORKEN AND Q**2 ACCORDING TO AN EXPERIMENTAL C DISTRIBUTION ( GIVEN IN ARRAY XQ(NXBJ,NQSQ) ). C----------------------------------------------------------------------- PARAMETER (NQSQ=10) PARAMETER (NXBJ=10) REAL XQ(NXBJ,NQSQ),VXQ(NXBJ*NQSQ) EQUIVALENCE (XQ(1,1),VXQ(1)) DATA VXQ/1304.02, 366.40, 19.84, 10.79, 6.42, * 4.54, 4.15, 3.38, 2.03, 1.56, * 241.63, 1637.26, 427.36, 164.51, 73.72, * 43.07, 20.73, 12.78, 9.34, 5.83, * 0.01, 724.66, 563.79, 275.08, 176.13, * 106.44, 85.82, 54.52, 37.12, 28.65, * 0.01, 202.40, 491.10, 245.13, 157.07, * 104.43, 61.05, 49.42, 37.84, 26.79, * 0.01, 3.77, 316.38, 226.92, 133.45, * 90.30, 63.67, 48.42, 35.73, 28.04, * 0.01, 0.01, 153.74, 213.09, 114.14, * 76.26, 60.02, 43.15, 43.47, 25.60, * 0.01, 0.01, 39.31, 185.74, 108.56, * 88.40, 47.29, 39.35, 31.80, 22.91, * 0.01, 0.01, 0.01, 104.61, 107.01, * 66.24, 45.34, 37.45, 33.44, 23.78, * 0.01, 0.01, 0.01, 56.58, 99.39, * 67.78, 43.28, 35.98, 34.63, 18.31, * 0.01, 0.01, 0.01, 13.56, 76.25, * 64.30, 42.80, 28.56, 21.19, 20.75 / DATA QSQMIN/4./,QSQWID/4./,XBJMIN/0./,XBJWID/.025/,INIT/0/ SAVE C----------------------------------------------------------------------- INIT=INIT+1 IF ( INIT .EQ. 1 ) THEN N=NXBJ*NQSQ SUM=VXQ(1) DO 1 I=2,N SUM=SUM+VXQ(I) VXQ(I)=VXQ(I)+VXQ(I-1) 1 CONTINUE DO 3 I=1,N VXQ(I)=VXQ(I)/SUM 3 CONTINUE ENDIF N=NXBJ*NQSQ R=RANGEN() CALL UTLOC(VXQ,N,R,ILOC) IF ( ILOC .GE. N ) ILOC=ILOC-1 I=MOD(ILOC,NXBJ)+1 IF ( I .EQ. 0 ) I=NXBJ J=ILOC/NXBJ + 1 IF ( ILOC .GT. 0 ) THEN DXINT=VXQ(ILOC+1)-VXQ(ILOC) ELSE DXINT=VXQ(1) ENDIF DXBJ=XBJWID*ABS(R-VXQ(ILOC+1))/DXINT DY =QSQWID*RANGEN() RXBJ=XBJMIN+XBJWID*FLOAT(I-1)+DXBJ RQSQ=QSQMIN+QSQWID*FLOAT(J-1)+DY RETURN END C======================================================================= SUBROUTINE LEPSTR(NUCLON,XBJ,QSQ,NSTRNG) C----------------------------------------------------------------------- C RETURNS STRING CODE NSTRNG FOR GIVEN NUCLON, XBJ, QSQ. C NUCLON : THE STRUCK NUCLEON (1120/1220 = PROTON/NEUTRON) C XBJ,QSQ : X-BJORKEN AND Q**2 C NSTRNG : STRING CODE: C PROTON STRINGS: NEUTRON STRINGS: C 1 : U --- UD 11 : U --- DD C 2 : D --- UU 12 : D --- UD C 3 : U --- UB(UUD) 13 : U --- UB(UDD) C 4 : D --- DB(UUD) 14 : D --- DB(UDD) C 5 : S --- SB(UUD) 15 : S --- SB(UDD) C 6 : UB --- U(UUD) 16 : UB --- U(UDD) C 7 : DB --- D(UUD) 17 : DB --- D(UDD) C 8 : SB --- S(UUD) 18 : SB --- S(UDD) C----------------------------------------------------------------------- REAL QUARKS(9) SAVE C----------------------------------------------------------------------- NSTRNG=0 C PROTON-STRING (VALENCE PART) IF ( NUCLON .EQ. 1120 ) THEN QUARKS(1) = 4.* STXU(XBJ,QSQ) QUARKS(2) = STXD(XBJ,QSQ) C NEUTRON-STRING (VALENCE PART) ELSEIF ( NUCLON .EQ. 1220 ) THEN QUARKS(1) = 4.* STXD(XBJ,QSQ) QUARKS(2) = STXU(XBJ,QSQ) ELSE RETURN ENDIF C THE SEA CONTRIBUTIONS (PROTON/NEUTRON) UDSEA = STXUS(XBJ,QSQ) SSEA = STXS(XBJ,QSQ) QUARKS(3) = 4.* UDSEA QUARKS(4) = UDSEA QUARKS(5) = SSEA QUARKS(6) = 4.* UDSEA QUARKS(7) = UDSEA QUARKS(8) = SSEA QUARKS(9) = 0. DO 11 I=1,8 QUARKS(9) = QUARKS(9)+QUARKS(I) 11 CONTINUE R = RANGEN() * QUARKS(9) SUMQ = 0. DO 12 I=1,8 NSTRNG = I SUMQ = SUMQ + QUARKS(I) IF ( R .LE. SUMQ ) GO TO 13 12 CONTINUE 13 CONTINUE IF ( NUCLON .EQ. 1220 ) NSTRNG=NSTRNG+10 RETURN END C======================================================================= SUBROUTINE LEPTAR(XBJ,QSQ,MATARG,LATARG,NUCLON) C----------------------------------------------------------------------- C RETURNS NUCLON = ID OF HIT TARGET NUCLEON. C XBJ : X BJORKEN C QSQ : Q SQUARED C MATARG : A OF TARGET C LATARG : Z OF TARGET C NUCLON: ID OF TARGET NUCLEON (1120/1220 FOR PROTON/NEUTRON) C----------------------------------------------------------------------- SAVE C----------------------------------------------------------------------- C PROTON PART OF THE STRUCTURE FUNCTION: F2P = LATARG * STXZPR(XBJ,QSQ) C NEUTRON PART OF THE STRUCTURE FUNCTION: F2N = (MATARG-LATARG) * STXZNE(XBJ,QSQ) C STRUCTURE FUNCTION OF NUCLEUS: F2A = F2P + F2N C SELECT THE TARGET-NUCLEON ( PROTON OR NEUTRON ): RN = RANGEN() F2RNDM = F2A * RN IF ( F2RNDM .LT. F2N ) THEN NUCLON = 1220 ELSE NUCLON = 1120 ENDIF RETURN END C======================================================================= SUBROUTINE NUCINI(OPT,ANUC,LA,MA,ISI) C----------------------------------------------------------------------- C INITIALIZES NUCLEON-MOMENTA. C WRITES NUCLEONS ON /CPTL/ (P,IFR,ICL). C----------------------------------------------------------------------- PARAMETER (MAMX=56) PARAMETER (MAMX2=MAMX*2) PARAMETER (MXPTL=70000) PARAMETER (NSI=6) PARAMETER (NSIX=40) PARAMETER (NHA=NSIX+2) COMMON /CNNN/ NNNPTL(MAMX2) COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /CPTL/ PPTL(5,MXPTL),TIVPTL(2,MXPTL),XORPTL(4,MXPTL) * ,IBPTL(4,MXPTL),ICLPTL(MXPTL),IDPTL(MXPTL) * ,IFRPTL(2,MXPTL),IORPTL(MXPTL),ISTPTL(MXPTL) * ,JORPTL(MXPTL),NPTL,NQJPTL(MXPTL) COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT REAL ANUC(NSI,NHA,MAMX) CHARACTER OPT*3 SAVE C----------------------------------------------------------------------- NHAX=3 IF ( NHA .LT. NHAX ) THEN CALL UTSTOP('NUCINI: NHA TOO SMALL ') ENDIF LAS=0 MAS=0 DO 1 L=1,MA DO 2 M=1,NHA DO 3 N=1,NSI ANUC(N,M,L)=0. 3 CONTINUE 2 CONTINUE IF ( OPT .EQ. 'NUC' ) THEN IF ( ISI .GT. 0 .AND. LAPROJ .LT. 0 ) THEN ID=IDPROJ ELSEIF ( ISI .LT. 0 .AND. LATARG .LT. 0 ) THEN ID=IDTARG ELSE IF ( RANGEN() .LE. (LA-LAS)/FLOAT(MA-MAS)) THEN ID=1120 LAS=LAS+1 ELSE ID=1220 ENDIF MAS=MAS+1 ENDIF CALL IDMASS(ID,AMS) IC1=IDTRAI(1,ID,1) IC2=IDTRAI(2,ID,1) P1=0. P2=0. P3=ISI*PNLLX P0=SQRT(PNLLX**2+AMS**2) P0X=PNLLX P5=AMS ELSEIF ( OPT .EQ. 'STR' ) THEN IF ( RANGEN() .LE. (LA-LAS)/FLOAT(MA-MAS) ) THEN ID=1120 LAS=LAS+1 ELSE ID=1220 ENDIF MAS=MAS+1 IC1=IDTRAI(1,ID,1) IC2=IDTRAI(2,ID,1) P1=0. P2=0. P3=0. P0=PROM P5=PROM ENDIF ANUC(5,1,L)=IC1 ANUC(6,1,L)=IC2 ANUC(3,2,L)=P3 ANUC(4,2,L)=P0X ANUC(5,2,L)=IC1 ANUC(6,2,L)=IC2 NPTL=NPTL+1 IF ( NPTL .NE. NNNPTL(NPTL) ) THEN CALL UTSTOP('NUCINI: NPTL AND NNNPTL DONT MATCH ') ENDIF IDPTL(NPTL)=ID PPTL(1,NPTL)=P1 PPTL(2,NPTL)=P2 PPTL(3,NPTL)=P3 PPTL(4,NPTL)=P0 PPTL(5,NPTL)=P5 IFRPTL(1,NPTL)=0 IFRPTL(2,NPTL)=0 ICLPTL(NPTL)=1 NQJPTL(NPTL)=0 1 CONTINUE RETURN END C======================================================================= SUBROUTINE NUCLCO(MASSNR,N,X,Y,Z,YNUC) C----------------------------------------------------------------------- C CALCULATES COORDINATES OF THE NUCLEONS IN A NUCLEUS. C----------------------------------------------------------------------- PARAMETER (KOLLMX=2500) PARAMETER (MXPTL=70000) PARAMETER (NDEP=129) PARAMETER (NDET=129) COMMON /ACCUM/ AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT * ,NRPTL,NRSTR,NTEVT COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /COL/ BIMP,BMAX,COORD(4,KOLLMX),DISTCE(KOLLMX) * ,QDEP(NDEP),QDET14(NDET),QDET16(NDET),QDET40(NDET) * ,QDET99(NDET),RMPROJ,RMTARG(4),XDEP(NDEP) * ,XDET14(NDET),XDET16(NDET),XDET40(NDET) * ,XDET99(NDET) * ,KOLL,LTARG,NORD(KOLLMX),NPROJ,NRPROJ(KOLLMX) * ,NRTARG(KOLLMX),NTARG COMMON /CPTL/ PPTL(5,MXPTL),TIVPTL(2,MXPTL),XORPTL(4,MXPTL) * ,IBPTL(4,MXPTL),ICLPTL(MXPTL),IDPTL(MXPTL) * ,IFRPTL(2,MXPTL),IORPTL(MXPTL),ISTPTL(MXPTL) * ,JORPTL(MXPTL),NPTL,NQJPTL(MXPTL) COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT REAL X(N),Y(N),Z(N) SAVE C----------------------------------------------------------------------- IF ( MASSNR .EQ. 0 ) RETURN IF ( MASSNR .GT. N ) THEN CALL UTSTOP('NUCLCO: MASSNR.GT.N ') ENDIF IF ( MASSNR .EQ. 1 ) THEN X(1)=0. Y(1)=0. Z(1)=0. RETURN ENDIF DO 3 I=1,MASSNR 10 CONTINUE IF ( MASSNR .EQ. MAPROJ ) * R=UTINVT(NDEP,XDEP,QDEP,RANGEN()*QDEP(NDEP)) IF ( MASSNR .EQ. MATARG ) THEN IF ( LTARG .EQ. 1 ) THEN R=UTINVT(NDET,XDET14,QDET14,RANGEN()*QDET14(NDET)) ELSEIF ( LTARG .EQ. 2 ) THEN R=UTINVT(NDET,XDET16,QDET16,RANGEN()*QDET16(NDET)) ELSEIF ( LTARG .EQ. 3 ) THEN R=UTINVT(NDET,XDET40,QDET40,RANGEN()*QDET40(NDET)) ELSE R=UTINVT(NDET,XDET99,QDET99,RANGEN()*QDET99(NDET)) ENDIF ENDIF IF ( MASSNR.NE.MAPROJ .AND. MASSNR.NE.MATARG ) THEN CALL UTSTOP('NUCLCO: NUCLEUS NEITHER PROJ NOR TARG ') ENDIF COSTHE=1.-2.*RANGEN() SINTHE= SQRT(1. - COSTHE**2) PHI=2.*PI*RANGEN() X(I)=R*SINTHE*COS(PHI) Y(I)=R*SINTHE*SIN(PHI) Z(I)=R*COSTHE IF ( I .EQ. 1 ) GOTO 3 IF ( CORE .EQ. 0. ) GOTO 3 DO 2 J=1,I-1 IF ( (X(I)-X(J))**2+(Y(I)-Y(J))**2+(Z(I)-Z(J))**2 * .LT. CORE**2 ) GOTO 10 2 CONTINUE 3 CONTINUE IF ( ISH .GE. 93 ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,*)'NUCLEON COORDINATES:' ENDIF AUXIL = 1./COSH(YNUC) DO 4 I=1,MASSNR Z(I)=Z(I)*AUXIL 4 CONTINUE IF ( ISH .GE. 93 ) THEN DO 5 I=1,MASSNR WRITE(IFCH,*)'I X Y Z: ',I,X(I),Y(I),Z(I) 5 CONTINUE ENDIF RETURN END C======================================================================= SUBROUTINE NUCOGE C----------------------------------------------------------------------- C WRITES NUCLEONS ON /CPTL/ (XOR,TIV,IST,IOR,JOR,NST). C DETERMINES SEQUENCE OF COLLISIONS ACCORDING TO NUCLEAR GEOMETRY C IF MAPROJ>0. C----------------------------------------------------------------------- PARAMETER (KOLLMX=2500) PARAMETER (MAMX=56) PARAMETER (MAMX2=MAMX*2) PARAMETER (MXPTL=70000) PARAMETER (NDEP=129) PARAMETER (NDET=129) COMMON /ACCUM/ AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT * ,NRPTL,NRSTR,NTEVT COMMON /CEVT/ BIMEVT,COLEVT,EGYEVT,PHIEVT,PMXEVT * ,KOLEVT,NEVT,NPJEVT,NTGEVT COMMON /CNCL/ XPROJ(MAMX),XTARG(MAMX),YPROJ(MAMX) * ,YTARG(MAMX),ZPROJ(MAMX),ZTARG(MAMX) COMMON /CNNN/ NNNPTL(MAMX2) COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /COL/ BIMP,BMAX,COORD(4,KOLLMX),DISTCE(KOLLMX) * ,QDEP(NDEP),QDET14(NDET),QDET16(NDET),QDET40(NDET) * ,QDET99(NDET),RMPROJ,RMTARG(4),XDEP(NDEP) * ,XDET14(NDET),XDET16(NDET),XDET40(NDET) * ,XDET99(NDET) * ,KOLL,LTARG,NORD(KOLLMX),NPROJ,NRPROJ(KOLLMX) * ,NRTARG(KOLLMX),NTARG COMMON /CPTL/ PPTL(5,MXPTL),TIVPTL(2,MXPTL),XORPTL(4,MXPTL) * ,IBPTL(4,MXPTL),ICLPTL(MXPTL),IDPTL(MXPTL) * ,IFRPTL(2,MXPTL),IORPTL(MXPTL),ISTPTL(MXPTL) * ,JORPTL(MXPTL),NPTL,NQJPTL(MXPTL) COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT SAVE C----------------------------------------------------------------------- IF ( ISH .EQ. 17 .OR. ISH .GT. 92 ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,*)'NUCOGE (ENTRY)' ENDIF VELI=1./TANH(YPJTL-YHAHA)+TANH(YHAHA) NPROJ=1 NTARG=1 DO 15 N=1,KOLLMX NORD(N)=N COORD(1,N)=0. COORD(2,N)=0. COORD(3,N)=0. COORD(4,N)=0. 15 CONTINUE IF ( MATARG .LT. 0 ) THEN KOLL=-MATARG NTARG=KOLL BIMP=0. NPTL=NPTL+1 XORPTL(1,NPTL)=0. XORPTL(2,NPTL)=0. XORPTL(3,NPTL)=0. XORPTL(4,NPTL)=0. TIVPTL(1,NPTL)=-AINFIN TIVPTL(2,NPTL)=0. ISTPTL(NPTL)=1 IORPTL(NPTL)=-1 JORPTL(NPTL)=0 NNNPTL(NPTL)=NPTL DO 1 K=1,KOLL NRPROJ(K)=1 NRTARG(K)=K NPTL=NPTL+1 XORPTL(1,NPTL)=0. XORPTL(2,NPTL)=0. XORPTL(3,NPTL)=0. XORPTL(4,NPTL)=0. TIVPTL(1,NPTL)=-AINFIN TIVPTL(2,NPTL)=0. ISTPTL(NPTL)=1 IORPTL(NPTL)=-1 JORPTL(NPTL)=0 NNNPTL(NPTL)=NPTL 1 CONTINUE GOTO 9999 ELSEIF ( MAPROJ .EQ. 1 .AND. MATARG .EQ. 1 ) THEN KOLL=1 BIMP=0. NRPROJ(1)=1 NRTARG(1)=1 DO 5 II=1,2 NPTL=NPTL+1 XORPTL(1,NPTL)=0. XORPTL(2,NPTL)=0. XORPTL(3,NPTL)=0. XORPTL(4,NPTL)=0. TIVPTL(1,NPTL)=-AINFIN TIVPTL(2,NPTL)= 0. ISTPTL(NPTL) = 1 IORPTL(NPTL) =-1 JORPTL(NPTL) = 0 NNNPTL(NPTL) = NPTL 5 CONTINUE GOTO 9999 ENDIF CALL NUCLCO(MAPROJ,MAMX,XPROJ,YPROJ,ZPROJ,YPJTL-YHAHA) CALL NUCLCO(MATARG,MAMX,XTARG,YTARG,ZTARG,YHAHA) BX=0. BY=0. IF ( MAPROJ .GT. 0 ) THEN IF ( BIMEVT .LT. 0. ) THEN B1=BMINIM B2=MIN(RMPROJ+RMTARG(LTARG),BMAXIM) IF ( B1 .GT. B2 ) THEN CALL UTSTOP('NUCOGE: BMIN > BMAX ') ENDIF BIMP=SQRT(B1**2+(B2**2-B1**2)*RANGEN()) PHI=2.*PI*RANGEN() ELSE PHI=PHIEVT BIMP=BIMEVT ENDIF BX=COS(PHI)*BIMP BY=SIN(PHI)*BIMP DO 6 I=1,MAPROJ NPTL=NPTL+1 XORPTL(1,NPTL)=XPROJ(I)+BX*0.5 XORPTL(2,NPTL)=YPROJ(I)+BY*0.5 XORPTL(3,NPTL)=ZPROJ(I) XORPTL(4,NPTL)=0. TIVPTL(1,NPTL)=-AINFIN TIVPTL(2,NPTL)= AINFIN ISTPTL(NPTL)=0 IORPTL(NPTL)=0 JORPTL(NPTL)=0 NNNPTL(NPTL)=NPTL 6 CONTINUE ENDIF DO 7 I=1,MATARG NPTL=NPTL+1 XORPTL(1,NPTL)=XTARG(I)-BX*0.5 XORPTL(2,NPTL)=YTARG(I)-BY*0.5 XORPTL(3,NPTL)=ZTARG(I) XORPTL(4,NPTL)=0. TIVPTL(1,NPTL)=-AINFIN TIVPTL(2,NPTL)= AINFIN ISTPTL(NPTL)=0 IORPTL(NPTL)=0 JORPTL(NPTL)=0 NNNPTL(NPTL)=NPTL 7 CONTINUE IF ( MAPROJ .EQ. 0 ) GOTO 1000 KOLL=0 DO 12 I=1,MAPROJ DO 12 J=1,MATARG IF ( PI*( (XPROJ(I)+BX-XTARG(J))**2 * +(YPROJ(I)+BY-YTARG(J))**2 ) .GT. SIGPPI ) GOTO 12 IF ( KOLL .GT. 0 ) THEN KP=0 KT=0 DO 30 KL=1,KOLL IF ( NRPROJ(KL) .EQ. I ) KP=1 IF ( NRTARG(KL) .EQ. J ) KT=1 30 CONTINUE CDH FTRSIG=1.0 FTR=1.0 CDH IF ( KP .EQ. 1 ) FTR=FTR*FTRSIG CDH IF ( KT .EQ. 1 ) FTR=FTR*FTRSIG IF ( KP.EQ.1 .OR. KT.EQ.1 ) THEN IF ( PI*( (XPROJ(I)+BX-XTARG(J))**2 * +(YPROJ(I)+BY-YTARG(J))**2 ) .GT. FTR*SIGPPI ) GOTO 12 ENDIF ENDIF KOLL=KOLL+1 IF ( KOLL .GT. KOLLMX ) THEN CALL UTSTOP('NUCOGE: KOLLMX TOO SMALL ') ENDIF NRPROJ(KOLL)=I NRTARG(KOLL)=J DISTCE(KOLL)=ZTARG(J)-ZPROJ(I) COORD(1,KOLL)=(XPROJ(I)+XTARG(J))*0.5 COORD(2,KOLL)=(YPROJ(I)+YTARG(J))*0.5 COORD(3,KOLL)=(ZPROJ(I)+ZTARG(J))*0.5 COORD(4,KOLL)=DISTCE(KOLL)*VELI ISTPTL(I)=1 IORPTL(I)=-1 TIVPTL(2,I)=COORD(4,KOLL) ISTPTL(MAPROJ+J)=1 IORPTL(MAPROJ+J)=-1 TIVPTL(2,MAPROJ+J)=COORD(4,KOLL) 12 CONTINUE IF ( KOLL .LE. 1 ) GOTO 9999 DO 21 N=2,KOLL DO 22 M=1,N-1 IF ( NRPROJ(M) .EQ. NRPROJ(N) ) GOTO 21 22 CONTINUE NPROJ=NPROJ+1 21 CONTINUE DO 23 N=2,KOLL DO 24 M=1,N-1 IF ( NRTARG(M) .EQ. NRTARG(N) ) GOTO 23 24 CONTINUE NTARG=NTARG+1 23 CONTINUE DO 20 N=1,KOLL-1 DO 20 M=N+1,KOLL IF ( DISTCE(NORD(M)) .LT. DISTCE(NORD(N)) ) THEN NORDM=NORD(M) NORD(M)=NORD(N) NORD(N)=NORDM ENDIF 20 CONTINUE 9999 CONTINUE IF ( KOLL .LE. 0 ) GOTO 1000 IF ( KOLL .LT. KO1KO2/10000 .OR. KOLL .GT. MOD(KO1KO2,10000) ) * GOTO 1000 NEVT=1 BIMEVT=BIMP PHIEVT=PHI KOLEVT=KOLL NPJEVT=NPROJ NTGEVT=NTARG PMXEVT=PNLL EGYEVT=ENGY 1000 CONTINUE IF ( ISH .EQ. 17 .OR. ISH .GT. 92 ) THEN WRITE(IFCH,*)'NUCOGE (EXIT)' ENDIF RETURN END C======================================================================= SUBROUTINE NUCOLL C----------------------------------------------------------------------- C PERFORMS A NUCLEUS-NUCLEUS COLLISION (INCL. NUCLEON-NUCLEON) C----------------------------------------------------------------------- PARAMETER (KOLLMX=2500) PARAMETER (MAMX=56) PARAMETER (MXPTL=70000) PARAMETER (MXSTR=3000) PARAMETER (NDEP=129) PARAMETER (NDET=129) PARAMETER (NPRBMS=20) PARAMETER (NSI=6) PARAMETER (NSIX=40) PARAMETER (NHA=NSIX+2) COMMON /ACCUM/ AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT * ,NRPTL,NRSTR,NTEVT COMMON /CEVT/ BIMEVT,COLEVT,EGYEVT,PHIEVT,PMXEVT * ,KOLEVT,NEVT,NPJEVT,NTGEVT COMMON /CIV/ IVP,IVP0,IVT,IVT0 COMMON /CKOL/ KOL COMMON /CNCE/ NCES,NCOLEX COMMON /CNEW/ KOTRI,NEWCOL,NEWICO COMMON /CNFR/ NRFRA COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /CNTEVM/ NTEVM COMMON /COL/ BIMP,BMAX,COORD(4,KOLLMX),DISTCE(KOLLMX) * ,QDEP(NDEP),QDET14(NDET),QDET16(NDET),QDET40(NDET) * ,QDET99(NDET),RMPROJ,RMTARG(4),XDEP(NDEP) * ,XDET14(NDET),XDET16(NDET),XDET40(NDET) * ,XDET99(NDET) * ,KOLL,LTARG,NORD(KOLLMX),NPROJ,NRPROJ(KOLLMX) * ,NRTARG(KOLLMX),NTARG COMMON /CPRBMS/ PRBMS(NPRBMS) COMMON /CPROJA/ IPROJ,ITARG,KPROJA(NHA,MAMX),KTARGA(NHA,MAMX) COMMON /CPTL/ PPTL(5,MXPTL),TIVPTL(2,MXPTL),XORPTL(4,MXPTL) * ,IBPTL(4,MXPTL),ICLPTL(MXPTL),IDPTL(MXPTL) * ,IFRPTL(2,MXPTL),IORPTL(MXPTL),ISTPTL(MXPTL) * ,JORPTL(MXPTL),NPTL,NQJPTL(MXPTL) COMMON /CSTR/ PSTR(5,MXSTR),ROTSTR(3,MXSTR),XORSTR(4,MXSTR) * ,ICSTR(4,MXSTR),IORSTR(MXSTR),IRLSTR(MXSTR),NSTR COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT COMMON /PARTNR/ PEX,PEY,PEZET,PE0,PX4,PY4,SUMMAS * ,IC4,IPTNR,JS4,NPS REAL PROJ(NSI,NHA),PROJA(NSI,NHA,MAMX) * ,TARG(NSI,NHA),TARGA(NSI,NHA,MAMX) INTEGER IC4(2) CHARACTER DASH*1 DATA DASH/'-'/ SAVE C----------------------------------------------------------------------- ISH0=ISH IF ( ISHSUB/100 .EQ. 6 ) ISH=MOD(ISHSUB,100) IF ( ISH .EQ. 17 .OR. ISH .GT. 92 ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,*)'NUCOLL (ENTRY)' CDH ELSEIF ( ISH .EQ. 14 ) THEN CDH CALL UTTIMA('*** NUCOLL *** ') ENDIF IF ( ISHSUB/100 .EQ. 7 ) ISH=MOD(ISHSUB,100) NEVT=0 NPTL=0 CALL NUCOGE IF ( ICHOIC .EQ. 3 .OR. KOLL .EQ. 0 ) GOTO 1000 NAEVT=NAEVT+1 IF ( KOLL .LT. KO1KO2/10000 .OR. * KOLL .GT. MOD(KO1KO2,10000) ) GOTO 1000 COLEVT=KOLL AMSEV=SQRT((NPJEVT*SQRT(AMPROJ**2+PNLLX**2) * +NTGEVT*SQRT(AMTARG**2+PNLLX**2))**2 * -((NPJEVT-NTGEVT)*PNLLX)**2) IF ( ISHSUB/100 .EQ. 7 ) ISH=ISH0 ITRY=0 38 CONTINUE ITRY=ITRY+1 NSTR=0 NPTL=0 SUMPT2=0. AMSAC=0. CALL NUCINI('NUC',PROJA,LAPROJ,MAPROJ,1) CALL NUCINI('NUC',TARGA,LATARG,IABS(MATARG),-1) KOLRAN=RANGEN()*KOLL+1 KOLRAN=MIN(KOLRAN,KOLL) KOLRAN=MAX(KOLRAN,1) DO 2 KOLS=1,KOLL KOL=KOLS ISKIP=0 I=NRPROJ(NORD(KOL)) J=NRTARG(NORD(KOL)) IPROJ=I ITARG=J NRECOP=0 NRECOT=0 IF ( KOL .LT. KOLL ) THEN DO 33 K=KOL+1,KOLL IF ( NRPROJ(NORD(K)) .EQ. I ) NRECOP=NRECOP+1 IF ( NRTARG(NORD(K)) .EQ. J ) NRECOT=NRECOT+1 33 CONTINUE ENDIF NCOP=0 NCOT=0 IF ( KOL .GT. 1 ) THEN DO 34 K=1,KOL-1 IF ( NRPROJ(NORD(K)) .EQ. I ) NCOP=NCOP+1 IF ( NRTARG(NORD(K)) .EQ. J ) NCOT=NCOT+1 34 CONTINUE ENDIF IF ( NCOP.GE.NCOLMX .OR. NCOT.GE.NCOLMX ) ISKIP=1 DO 56 M=1,NHA SM=0. DO 57 N=1,NSI PROJ(N,M)=PROJA(N,M,I) SM=SM+PROJ(N,M)**2 57 CONTINUE IF ( M .GE. 3 .AND. SM .LT. 1.E-5 ) GOTO 58 56 CONTINUE 58 CONTINUE DO 53 M=1,NHA SM=0. DO 54 N=1,NSI TARG(N,M)=TARGA(N,M,J) SM=SM+TARG(N,M)**2 54 CONTINUE IF ( M .GE. 3 .AND. SM .LT. 1.E-5 ) GOTO 55 53 CONTINUE 55 CONTINUE IF ( KOL .EQ. KOLRAN .AND. JPSI .EQ. 1 ) THEN CALL PVJPSF(PROJ,TARG) ISKIP=1 ENDIF C NR OF COLOUR EXCHANGES C ---------------------- AMSAC0=AMSAC ISKIP0=ISKIP SMPT2=SUMPT2 CALL UTREMB(PROJ,TARG,1) GOTO 4 3 CONTINUE IF ( ISH .GE. 91 ) WRITE(IFCH,*)'REDO HH COLLISION' CALL UTREST(PROJ,TARG,1) SUMPT2=SMPT2 ISKIP=ISKIP0 AMSAC=AMSAC0 4 CONTINUE NCOLEX=1 IF ( ISKIP .NE. 1 ) THEN LO=0 16 LO=LO+1 IF ( LO .EQ. 3 ) THEN IF ( ISH .GE. 90 ) THEN CALL UTMSG('NUCOLL') WRITE(IFCH,*)'***** LO=3' CALL UTMSGF ENDIF ENDIF R=RANGEN() NCOLEX=0 15 NCOLEX=NCOLEX+1 IF ( NCOLEX .GT. NPRBMS ) GOTO 16 IF ( R .GT. PRBMS(NCOLEX) ) GOTO 15 ENDIF C HADRON-HADRON COLLISION C ----------------------- DO 31 NCE=1,NCOLEX NCES=NCE CALL UTPAGE IF ( ISH .GE. 91 ) THEN WRITE(IFCH,101)(DASH,L=1,79),IPAGE,KOL,NCE * ,NRPROJ(NORD(KOL)),NRTARG(NORD(KOL)),(DASH,L=1,79) 101 FORMAT(/1X,79A1/1X,I5,'.PAGE COL: ',I2 * ,' CEX: ',I2,' PRJ: ',I3,' TRG: ',I3/1X,79A1/) ENDIF IF ( NRECOP .EQ. 0 ) THEN ISTORP=1 ELSE ISTORP=0 ENDIF IF ( NRECOT .EQ. 0 ) THEN ISTORT=1 ELSE ISTORT=0 ENDIF CALL HAHABS(PROJ,TARG * ,ISTORP*(NCE/NCOLEX),ISTORT*(NCE/NCOLEX),ISKIP,IRETHH) IF ( ISKIP .GE. 2 ) GOTO 9997 IF ( IRETHH .EQ. 1 ) GOTO 3 IF ( IRESCL .EQ. 1 .AND. AMSAC .GT. AMSEV ) GOTO 9998 SUMPT2=SUMPT2+ * PROJ(1,2)**2+PROJ(2,2)**2+TARG(1,2)**2+TARG(2,2)**2 IF ( ISH .EQ. 11 ) WRITE(IFCH,*)'SUMPT2:',NREVT,KOL,NCE,SUMPT2 ISKIP=0 31 CONTINUE DO 40 M=1,NHA SM=0. DO 41 N=1,NSI PROJA(N,M,I)=PROJ(N,M) SM=SM+PROJ(N,M)**2 41 CONTINUE IF ( M .GE. 3 .AND. SM .LT. 1.E-5 ) GOTO 42 40 CONTINUE 42 CONTINUE DO 43 M=1,NHA SM=0. DO 44 N=1,NSI TARGA(N,M,J)=TARG(N,M) SM=SM+TARG(N,M)**2 44 CONTINUE IF ( M .GE. 3 .AND. SM .LT. 1.E-5 ) GOTO 45 43 CONTINUE 45 CONTINUE 2 CONTINUE IF ( SUMPT2 .LT. 1.E-5 ) GOTO 9999 1000 CONTINUE CDH IF ( ISH .EQ. 14 ) CALL UTTIMA(' NUCOLL F ') IF ( ISH .EQ. 17 .OR. ISH .GT. 92 ) THEN WRITE(IFCH,*)'NUCOLL (EXIT)' ENDIF ISH=ISH0 RETURN 9999 INOIAC=INOIAC+1 IF ( ISH .GE. 91 .OR. ISH .EQ. 11 ) THEN CALL UTMSG('NUCOLL') WRITE(IFCH,*)'***** NO INTERACTION. REDO NUCOLL' CALL UTMSGF ENDIF GOTO 38 9998 ILAMAS=ILAMAS+1 IF ( ISH .GE. 91 .OR. ISH .EQ. 12 ) THEN CALL UTMSG('NUCOLL') WRITE(IFCH,*)'***** AMSAC>AMSEV: ',AMSAC,AMSEV * ,' . REDO NUCOLL' DO 1 NS=1,NSTR WRITE(IFCH,109)NS,(ICSTR(L,NS)/100,L=1,4) * ,(PSTR(L,NS),L=3,5) 109 FORMAT(1X,I3,3X,4I5,3(E11.3)) 1 CONTINUE CALL UTMSGF ENDIF GOTO 38 9997 CONTINUE IF ( ISH .GE. 90 ) THEN CALL UTMSG('NUCOLL') WRITE(IFCH,*)'***** ISKIP>=2. REDO NUCOLL' CALL UTMSGF ENDIF GOTO 38 END C======================================================================= SUBROUTINE NUCSTR(IER) C----------------------------------------------------------------------- C PERFORMES X AND P TRAFOS FOR NUCLEONS FOR STRING DECAY IN NUCLEUS C----------------------------------------------------------------------- PARAMETER (MXPTL=70000) COMMON /CLEP/ ICINPU,IDSCAT COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /CPTL/ PPTL(5,MXPTL),TIVPTL(2,MXPTL),XORPTL(4,MXPTL) * ,IBPTL(4,MXPTL),ICLPTL(MXPTL),IDPTL(MXPTL) * ,IFRPTL(2,MXPTL),IORPTL(MXPTL),ISTPTL(MXPTL) * ,JORPTL(MXPTL),NPTL,NQJPTL(MXPTL) COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT SAVE C----------------------------------------------------------------------- IF ( MATARG .NE. NPTL ) THEN CALL UTSTOP('NUCSTR: MATARG /= NPTL ') ENDIF NCNT=0 3 NCNT=NCNT+1 IF ( NCNT .GE. 10 ) GOTO 1001 N0=MIN(1+INT(RANGEN()*NPTL),NPTL) IF ( ICINPU .GT. 0 .AND. IDPTL(N0) .NE. IDSCAT ) GOTO 3 ISTPTL(N0)=1 IORPTL(N0)=-1 TIVPTL(2,N0)=0. DO 2 N=1,NPTL XORPTL(1,N)=XORPTL(1,N)-XORPTL(1,N0) XORPTL(2,N)=XORPTL(2,N)-XORPTL(2,N0) XORPTL(3,N)=XORPTL(3,N)-XORPTL(3,N0) PHI=2.*PI*RANGEN() P1= -ELEPTO*SIN(ANGMUE)*SIN(PHI) P2= -ELEPTO*SIN(ANGMUE)*COS(PHI) P3=ELEPTI-ELEPTO*COS(ANGMUE) CALL UTROTA(1,P1,P2,P3,XORPTL(1,N),XORPTL(2,N),XORPTL(3,N)) P3=SQRT(P1**2+P2**2+P3**2) P1=0. P2=0. P4=PROM+ELEPTI-ELEPTO CALL UTLOBO(1,P1,P2,P3,P4,SQRT(P4**2-P3**2-P2**2-P1**2) * ,XORPTL(1,N),XORPTL(2,N),XORPTL(3,N),XORPTL(4,N)) CALL UTLOBO(1,P1,P2,P3,P4,SQRT(P4**2-P3**2-P2**2-P1**2) * ,PPTL(1,N),PPTL(2,N),PPTL(3,N),PPTL(4,N)) 2 CONTINUE IER=0 RETURN 1001 IER=1 IF ( ISH .GE. 90 ) THEN CALL UTMSG('NUCSTR') WRITE(IFCH,*)'***** IDSCAT NOT POSSIBLE ==> REDO EVENT.' CALL UTMSGF ENDIF RETURN END C======================================================================= SUBROUTINE PVJPSF(PROJ,TARG) C----------------------------------------------------------------------- C FORMS A JPSI C----------------------------------------------------------------------- PARAMETER (KOLLMX=2500) PARAMETER (MAMX=56) PARAMETER (MXPTL=70000) PARAMETER (MXSTR=3000) PARAMETER (NDEP=129) PARAMETER (NDET=129) PARAMETER (NGAU=129) PARAMETER (NPTJ=129) PARAMETER (NSI=6) PARAMETER (NSIX=40) PARAMETER (NHA=NSIX+2) COMMON /ACCUM/ AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT * ,NRPTL,NRSTR,NTEVT COMMON /CGAU/ QGAU(NGAU),XGAU(NGAU) COMMON /CKOL/ KOL COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /COL/ BIMP,BMAX,COORD(4,KOLLMX),DISTCE(KOLLMX) * ,QDEP(NDEP),QDET14(NDET),QDET16(NDET),QDET40(NDET) * ,QDET99(NDET),RMPROJ,RMTARG(4),XDEP(NDEP) * ,XDET14(NDET),XDET16(NDET),XDET40(NDET) * ,XDET99(NDET) * ,KOLL,LTARG,NORD(KOLLMX),NPROJ,NRPROJ(KOLLMX) * ,NRTARG(KOLLMX),NTARG COMMON /CPROJA/ IPROJ,ITARG,KPROJA(NHA,MAMX),KTARGA(NHA,MAMX) COMMON /CPTJ/ QPTJ(NPTJ),XPTJ(NPTJ) COMMON /CPTL/ PPTL(5,MXPTL),TIVPTL(2,MXPTL),XORPTL(4,MXPTL) * ,IBPTL(4,MXPTL),ICLPTL(MXPTL),IDPTL(MXPTL) * ,IFRPTL(2,MXPTL),IORPTL(MXPTL),ISTPTL(MXPTL) * ,JORPTL(MXPTL),NPTL,NQJPTL(MXPTL) COMMON /CSTR/ PSTR(5,MXSTR),ROTSTR(3,MXSTR),XORSTR(4,MXSTR) * ,ICSTR(4,MXSTR),IORSTR(MXSTR),IRLSTR(MXSTR),NSTR COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT REAL PROJ(NSI,NHA),PR(4),TARG(NSI,NHA),TG(4) SAVE C----------------------------------------------------------------------- PAX=0.19 PROX=PROJ(3,2) TARX=TARG(3,2) LOOP=0 PR(1)=PROJ(1,2) PR(2)=PROJ(2,2) PR(3)=PROJ(3,2) PR(4)=PROJ(4,2) TG(1)=TARG(1,2) TG(2)=TARG(2,2) TG(3)=TARG(3,2) TG(4)=TARG(4,2) CALL UTPAGE IF ( ISH .GE. 91 ) WRITE(IFCH,110)('-',L=1,79),IPAGE,('-',L=1,79) 110 FORMAT(1X,79A1/1X,I5,'.PAGE ' * ,'JPSI FORMATION'/1X,79A1/) 5000 LOOP=LOOP+1 IF ( LOOP .GT. 100 ) THEN IF(ISH.GE.90)THEN CALL UTMSG('PVJPSF') WRITE(IFCH,*)'***** JPSI FORMATION NOT POSSIBLE' CALL UTMSGF ENDIF GOTO 1000 ENDIF PROJ(1,2)=PR(1) PROJ(2,2)=PR(2) PROJ(3,2)=PR(3) PROJ(4,2)=PR(4) TARG(1,2)=TG(1) TARG(2,2)=TG(2) TARG(3,2)=TG(3) TARG(4,2)=TG(4) C JPSI MOMENTA C ------------ ID=441 CALL IDMASS(ID,AM) S=AM**2 PT=UTINVT(NPTJ,XPTJ,QPTJ,RANGEN()*QPTJ(NPTJ)) PHI=2.*PI*RANGEN() PX=PT*COS(PHI) PY=PT*SIN(PHI) LO=0 1 LO=LO+1 IF ( LO .GT. 10 ) THEN CALL UTSTOP('PVJPSF: LO > 10 ') ENDIF Z=PAX*UTINVT(NGAU,XGAU,QGAU,RANGEN()*QGAU(NGAU)) IF ( Z .GT. 1. ) GOTO 1 IF ( RANGEN() .LE. 0.5 ) THEN PZ=Z*PNLLX ELSE PZ=-Z*PNLLX ENDIF E=SQRT(S+PX**2+PY**2+PZ**2) PP=E+PZ PM=E-PZ C PROJ AND TARG MOMENTA C --------------------- R=RANGEN() POX=PROJ(1,2)-R*PX POY=PROJ(2,2)-R*PY POT2=(POX**2+POY**2) R=1.-R PUX=TARG(1,2)-R*PX PUY=TARG(2,2)-R*PY PUT2=(PUX**2+PUY**2) POP=PROJ(4,2)+PROJ(3,2) POM=PROJ(4,2)-PROJ(3,2) PUP=TARG(4,2)+TARG(3,2) PUM=TARG(4,2)-TARG(3,2) PEP=POP+PUP-PP PEM=POM+PUM-PM A=(PEM*PEP-PUT2-POT2)*0.5 D2=PUT2*POT2 AUXIL = A**2 - D2 IF ( AUXIL .LT. 0. ) GOTO 5000 AUXIL = SQRT(AUXIL) PYP=(A+PUT2-AUXIL)/PEM PYM=(A+POT2-AUXIL)/PEP IF ( PYP .LT. 0. ) GOTO 5000 IF ( PYM. LT. 0. ) GOTO 5000 PIP=PEP-PYP IF ( PIP .LT. 0. ) GOTO 5000 PIM=PYM PAP=PYP PAM=PEM-PYM IF ( PAM .LT. 0. ) GOTO 5000 PROJ(1,2)=POX PROJ(2,2)=POY PROJ(3,2)=(PIP-PIM)*0.5 PROJ(4,2)=(PIP+PIM)*0.5 TARG(1,2)=PUX TARG(2,2)=PUY TARG(3,2)=(PAP-PAM)*0.5 TARG(4,2)=(PAP+PAM)*0.5 KPROJA(2,IPROJ)=KOL KTARGA(2,ITARG)=KOL IF ( PROJ(3,2)*PROX .LT. 0. ) GOTO 5000 IF ( TARG(3,2)*TARX .LT. 0. ) GOTO 5000 C JPSI STRING C ----------- NSTR=NSTR+1 IF ( NSTR .GT. MXSTR ) THEN CALL UTSTOP('PVJPSF: NSTR>MXSTR ') ENDIF IORSTR(NSTR)=-KOL ICSTR(1,NSTR)=000100 ICSTR(2,NSTR)=0 ICSTR(3,NSTR)=0 ICSTR(4,NSTR)=000100 PSTR(1,NSTR)=PX PSTR(2,NSTR)=PY PSTR(3,NSTR)=PZ PSTR(4,NSTR)=E PSTR(5,NSTR)=AM ROTSTR(1,NSTR)=0. ROTSTR(2,NSTR)=0. ROTSTR(3,NSTR)=1. XORSTR(1,NSTR)=COORD(1,KOL) XORSTR(2,NSTR)=COORD(2,KOL) XORSTR(3,NSTR)=COORD(3,KOL) XORSTR(4,NSTR)=COORD(4,KOL) IF ( ISH .GE. 90 ) THEN IF ( ISH .GE. 91 ) THEN J=NSTR WRITE(IFCH,100)J,(ICSTR(K,J)/100,K=1,4) * ,PSTR(3,J),PSTR(4,J),PSTR(5,J) 100 FORMAT(' /CSTR/',I4,3X,4I5,3(E11.3)) ENDIF C CHECKS C ------ IF ( ABS(PIP*PIM-POT2) .GT. 1.E-4 ) THEN CALL UTMSG('PVJPSF') WRITE(IFCH,*)'***** PIP*PIM /= POT**2' WRITE(IFCH,*)'PIP*PIM=',PIP*PIM,'POT**2=',POT2 WRITE(IFCH,*)'PIP=',PIP,' PIM=',PIM CALL UTMSGF ENDIF IF ( ABS(PAP*PAM-PUT2) .GT. 1.E-4 ) THEN CALL UTMSG('PVJPSF') WRITE(IFCH,*)'***** PAP*PAM /= PUT**2' WRITE(IFCH,*)'PAP*PAM=',PAP*PAM,'PUT**2=',PUT2 WRITE(IFCH,*)'PAP=',PAP,' PAM=',PAM CALL UTMSGF ENDIF IF ( ABS(PROJ(4,2)**2 * -PROJ(1,2)**2-PROJ(2,2)**2-PROJ(3,2)**2) .GT. 1.E-4 ) THEN CALL UTMSG('PVJPSF') WRITE(IFCH,*)'***** MASS**2 OF PROJ NONZERO' WRITE(IFCH,*)'MASS**2=',PROJ(4,2)**2 * -PROJ(1,2)**2-PROJ(2,2)**2-PROJ(3,2)**2 CALL UTMSGF ENDIF IF ( ABS(TARG(4,2)**2 * -TARG(1,2)**2-TARG(2,2)**2-TARG(3,2)**2) .GT. 1.E-4 ) THEN CALL UTMSG('PVJPSF') WRITE(IFCH,*)'***** MASS**2 OF TARG NONZERO' WRITE(IFCH,*)'MASS**2=',TARG(4,2)**2 * -TARG(1,2)**2-TARG(2,2)**2-TARG(3,2)**2 CALL UTMSGF ENDIF DO 14 N=1,4 IF ( ABS(PR(N)+TG(N) * -PROJ(N,2)-TARG(N,2)-PSTR(N,NSTR)) .GT. 1.E-4 ) GOTO 15 14 CONTINUE GOTO 16 15 CONTINUE CALL UTMSG('PVJPSF') WRITE(IFCH,*)'***** PROJ + TARG /= PROJ_NEW + TARG_NEW +JPSI' WRITE(IFCH,*)'PROJ,TARG:' WRITE(IFCH,*)PR WRITE(IFCH,*)TG WRITE(IFCH,*)'PROJ_NEW,TARG_NEW,JPSI:' WRITE(IFCH,*)(PROJ(N,2),N=1,4) WRITE(IFCH,*)(TARG(N,2),N=1,4) WRITE(IFCH,*)(PSTR(N,NSTR),N=1,4) CALL UTMSGF 16 CONTINUE ENDIF AMSAC=AMSAC+AM 1000 RETURN END C======================================================================= SUBROUTINE RACPRO(TYP,QMU,N,ACPROB) C----------------------------------------------------------------------- C RETURNS THE ARRAY ACPROB CONTAINING ACCUMULATED PROB FOR: C EXPONENTIAL OR POISSON DISTRIBUTION (FOR TYP = EXP OR POI) C MULTI POMERON CUTS ACC TO GRIBOV (FOR TYP = GRI). C----------------------------------------------------------------------- COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT COMMON /PARO3/ ASUHAX(7),ASUHAY(7),OMEGA,SIGPPD,SIGPPE,UENTRO * ,IWZZZZ COMMON /PARO4/ GRICEL,GRIDEL,GRIGAM,GRIRSQ,GRISLO DOUBLE PRECISION DENOM,FZ,FZH,Q,QZ,QZH,Z REAL ACPROB(N) CHARACTER TYP*3 SAVE C----------------------------------------------------------------------- ISH0=ISH IF ( ISHSUB/100 .EQ. 17 ) ISH=MOD(ISHSUB,100) C GRIBOV-REGGE C ------------ IF ( TYP .EQ. 'GRI' ) THEN XI=LOG(ENGY**2) AUXIL = EXP(XI*GRIDEL)*GRIGAM SIG=8.*PI*AUXIL Z=2.D0*GRICEL/(GRIRSQ+GRISLO*XI)*AUXIL C 0-CUT-POMERON PROBABILITY C ------------------------- QZ=-1.D0/Z QZH=-2.D0/Z FZ=0.D0 FZH=0.D0 DO 10 I=1,20 DENOM=1.D0/I QZ=(-Z)*DENOM*QZ QZH=(-Z)*DENOM*0.5*QZH FZ=DENOM*QZ+FZ FZH=DENOM*QZH+FZH 10 CONTINUE RELER=ABS( QZ/(I*FZ) ) RELERH=ABS( QZH/(I*FZH) ) SIGPPZ=SIG*(FZH-FZ) SIGPPE=SIGPPZ/GRICEL SIGPPD=SIGPPE*(GRICEL-1) C N-CUT-POMERON PROBABILITIES, N>0 C -------------------------------- AUXIL = EXP(-Z) Q=1. R=1. ACPROB(1)=SIG/Z*(1.-AUXIL) DO 21 I=2,N Q=Q*Z/(I-1) R=R+Q SI=SIG/(I*Z)*(1.-R*AUXIL) ACPROB(I)=ACPROB(I-1)+SI 21 CONTINUE IF ( SIGPPI .LT. 0. ) SIGPPI=ACPROB(N) AUXIL2 = 1./ACPROB(N) DO 22 I=1,N ACPROB(I)=AUXIL2*ACPROB(I) 22 CONTINUE C WARNINGS C -------- IF ( ISH.GE.90 ) THEN IF ( RELER .GT. 1.E-3 ) THEN CALL UTMSG('RACPRO') WRITE(IFCH,*)'***** RELER TOO LARGE' WRITE(IFCH,*)'RELER,QZ/I,FZ:',RELER,QZ/I,FZ CALL UTMSGF ENDIF IF ( RELERH .GT. 1.E-3 ) THEN CALL UTMSG('RACPRO') WRITE(IFCH,*)'***** RELERH TOO LARGE' WRITE(IFCH,*)'RELERH,QZH/I,FZH:',RELERH,QZH/I,FZH CALL UTMSGF ENDIF IF ( SIGPPZ .LT. 0. ) THEN CALL UTMSG('RACPRO') WRITE(IFCH,*)'***** NEGATIVE SIGPPZ' WRITE(IFCH,*)'SIGPPZ,SIG,FZH,FZ:',SIGPPZ,SIG,FZH,FZ CALL UTMSGF ENDIF DO 24 I=1,N IF ( ACPROB(I) .LT. 0. ) THEN CALL UTMSG('RACPRO') WRITE(IFCH,*)'***** NEGATIVE ACPROB(I)' WRITE(IFCH,*)'I,ACPROB(I):',I,ACPROB(I) CALL UTMSGF ENDIF 24 CONTINUE RELERN=ACPROB(N)-ACPROB(N-1) IF ( RELERN .GT. 1.E-3 ) THEN CALL UTMSG('RACPRO') WRITE(IFCH,*)'***** RELERN TOO LARGE' WRITE(IFCH,*)'RELERN:',RELERN CALL UTMSGF ENDIF ENDIF C PRINT C ----- IF ( ISH .GE. 92 ) THEN 100 FORMAT(1X,79A1) WRITE(IFCH,*)' ' WRITE(IFCH,100)('-',IC=1,79) WRITE(IFCH,*)' CROSS SECTIONS AND', * ' CUT-POMERON WEIGHTS ACC TO GRIBOV-REGGE-THEORY' WRITE(IFCH,100)('-',IC=1,79) WRITE(IFCH,*)' CMS-ENERGY (GEV):',ENGY WRITE(IFCH,100)('-',IC=1,79) WRITE(IFCH,*)' ' WRITE(IFCH,*)' PARAMETERS: ' WRITE(IFCH,*)' ' WRITE(IFCH,*)' GAMMA: ',GRIGAM WRITE(IFCH,*)' R**2: ',GRIRSQ WRITE(IFCH,*)' DELTA: ',GRIDEL WRITE(IFCH,*)' SLOPE: ',GRISLO WRITE(IFCH,*)' C: ',GRICEL WRITE(IFCH,*)' ' WRITE(IFCH,*)' CROSS SECTIONS:' WRITE(IFCH,*)' ' WRITE(IFCH,*)' ELASTIC: ',SIGPPE WRITE(IFCH,*)' DIFFRACTIVE: ',SIGPPD WRITE(IFCH,*)' INELASTIC: ',SIGPPI WRITE(IFCH,*)' ' WRITE(IFCH,*)' WEIGHTS W(N) OF N CUT POMERONS:' WRITE(IFCH,*)' ( N - W(N) - W(N)_EXP )' WRITE(IFCH,*)' ' A=QMU/(QMU+1.) I=1 WRITE(IFCH,*)I,ACPROB(I),(1-A)*A**(I-1) DO 25 I=2,N WRITE(IFCH,*)I,ACPROB(I)-ACPROB(I-1),(1-A)*A**(I-1) 25 CONTINUE WRITE(IFCH,*)' ' ENDIF C POISSON C ------- ELSEIF ( TYP .EQ. 'POI' ) THEN Z=QMU IF ( Z .GE. N-1. ) THEN CALL UTSTOP('RACPRO: Z >= N-1. ') ENDIF K=MAX( 0.D0, Z-(N-1-Z) )+1. IF ( K .GE. N ) THEN CALL UTSTOP('RACPRO: K >= N. ') ENDIF IF ( K .EQ. 1 ) THEN PRBAB=EXP(-Z) ACPROB(1)=PRBAB DO 1 I=2,N PRBAB=PRBAB*Z/(I-1) ACPROB(I)=ACPROB(I-1)+PRBAB 1 CONTINUE ELSEIF ( K .GT. 1 ) THEN X=Z*EXP(-Z/(K-1.)) PRBAB=1. DO 3 I=1,K-1 PRBAB=PRBAB*X/I ACPROB(I)=0. 3 CONTINUE ACPROB(K)=PRBAB DO 4 I=K+1,N PRBAB=PRBAB*Z/(I-1) ACPROB(I)=ACPROB(I-1)+PRBAB 4 CONTINUE ELSE CALL UTSTOP('RACPRO: K <= 0. ') ENDIF C EXPONENTIAL C ----------- ELSEIF ( TYP .EQ. 'EXP' ) THEN A=QMU/(QMU+1.) PRBAB=1.-A ACPROB(1)=PRBAB DO 2 I=2,N PRBAB=PRBAB*A ACPROB(I)=ACPROB(I-1)+PRBAB 2 CONTINUE ENDIF ISH=ISH0 RETURN END C======================================================================= FUNCTION RANSTC(XFL,XMIN) C----------------------------------------------------------------------- C RETURNS RANDOM NUMBER ACCORDING TO A QUARK STRUCTURE FCTN C WITH X>=XMIN C C CHANGES : D. HECK IK3 KFK KARLSRUHE C DATE : MAR 22, 1994 C----------------------------------------------------------------------- PARAMETER (NSTRU=2049) COMMON /CIPIO/ IPIO COMMON /CUTINV/ LUTINV COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /STRU/ QSEP(NSTRU),QSET(NSTRU),QVAP(NSTRU) * ,QVAT(NSTRU),XCUTAR,XSTRU(NSTRU) * ,IDTG COMMON /STRU2/ DELTA0,DELTA1,QSEH(NSTRU),QSEPI(NSTRU) * ,QVAH(NSTRU),QVAPI(NSTRU),XSE(NSTRU),XVA(NSTRU) CHARACTER XFL*3 SAVE C----------------------------------------------------------------------- NSTRUC = NSTRU IF ( XFL .EQ. 'SEP' ) THEN RANSTC=RANXQ(NSTRUC,XSE ,QSEP,XMIN) ELSEIF ( XFL .EQ. 'SET' ) THEN RANSTC=RANXQ(NSTRUC,XSE ,QSET,XMIN) ELSEIF ( XFL .EQ. 'VAP' ) THEN RANSTC=RANXQ(NSTRUC,XVA ,QVAP,XMIN) ELSEIF ( XFL .EQ. 'VAT' ) THEN RANSTC=RANXQ(NSTRUC,XVA ,QVAT,XMIN) ENDIF 1 RETURN END C======================================================================= FUNCTION RANXQ(N,X,Q,XMIN) C----------------------------------------------------------------------- C RETURNS RANDOM NUMBER ACCORDING TO X(I) Q(I) WITH X>=XMIN C----------------------------------------------------------------------- COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT REAL X(N),Q(N) REAL XMIN,QRAN SAVE C----------------------------------------------------------------------- IMIN=1 IF ( XMIN .EQ. 0. ) GOTO 3 I1=1 I2=N 1 I=I1+(I2-I1)/2 IF ( X(I) .LT. XMIN ) THEN I1=I ELSEIF ( X(I) .GT. XMIN ) THEN I2=I ELSE IMIN=I GOTO 3 ENDIF IF ( I2-I1 .GT. 1 ) GOTO 1 IMIN=I2 3 CONTINUE IF ( Q(IMIN) .GT. Q(N)*.9999 ) THEN RANXQ=XMIN GOTO 4 ENDIF QRAN=Q(IMIN)+RANGEN()*(Q(N)-Q(IMIN)) RANXQ=UTINVT(N,X,Q,QRAN) 4 CONTINUE IF ( RANXQ .LT. XMIN ) THEN IF(ISH.GE.90)THEN CALL UTMSG('RANXQ ') WRITE(IFCH,*)'***** RANXQ=',RANXQ,' < XMIN=',XMIN WRITE(IFCH,*)'Q(IMIN) Q Q(N):',Q(IMIN),QRAN,Q(N) WRITE(IFCH,*)'X(IMIN) X X(N):',X(IMIN),RANXQ,X(N) CALL UTMSGF ENDIF RANXQ=XMIN ENDIF IF ( ISH .GT. 91 ) THEN WRITE(IFCH,*)'RANXQ:' WRITE(IFCH,*)' Q(IMIN) Q Q(N):',Q(IMIN),QRAN,Q(N) WRITE(IFCH,*)' X(IMIN) X X(N):',X(IMIN),RANXQ,X(N) ENDIF RETURN END C======================================================================= FUNCTION SBET(Z,W) C----------------------------------------------------------------------- SAVE C----------------------------------------------------------------------- SBET=SGAM(Z)*SGAM(W)/SGAM(Z+W) RETURN END C======================================================================= FUNCTION SDENSI(R) C----------------------------------------------------------------------- C NUCLEAR DENSITY C----------------------------------------------------------------------- COMMON /CDEN/ MASSNR,RMX,R0 C AI IS INVERSE OF A=0.54 REAL AI DATA AI/1.85185185/ SAVE C----------------------------------------------------------------------- SDENSI=R**2 / ( 1. + EXP((R-R0)*AI) ) RETURN END C======================================================================= FUNCTION SGAM(X) C----------------------------------------------------------------------- C GAMMA FUNCTION C----------------------------------------------------------------------- COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP DOUBLE PRECISION GC(13),GF,GP,GX,GY,GZ DATA GC/ * 0.000539698958808D0, 0.002619307282746D0, 0.020449630823590D0, * 0.073094836414370D0, 0.279643691578538D0, 0.553387692385769D0, * 0.999999999999998D0,-0.000832724708684D0, 0.004698658079622D0, * 0.022523834747260D0,-0.170447932874746D0,-0.056810335086194D0, * 1.130603357286556D0/ DATA GP / 3.141592653589793D0 / SAVE C----------------------------------------------------------------------- GF = 0.D0 GX = DBLE(X) GZ = GX IF ( GX .GT. 0.D0 ) GOTO 1 IF ( GX .EQ. DINT(GX) ) THEN WRITE(IFCH,'('' ARGUMENT OF GAMMA FUNCTION ='',E20.5)') X CALL UTSTOP('SGAM : NEGATIVE INTEGER ARGUMENT ') GOTO 5 ENDIF GZ = 1.D0 - GZ 1 CONTINUE GY = 1.D0 / GZ IF ( GZ .LE. 1.D0 ) GOTO 4 GY = 1.D0 2 CONTINUE IF ( GZ .LT. 2.D0 ) GOTO 3 GZ = GZ - 1.D0 GY = GY * GZ GOTO 2 3 CONTINUE GZ = GZ - 1.D0 4 CONTINUE GF = GY * ((((((GC(1)*GZ+GC(2))*GZ+GC(3))*GZ+GC(4))*GZ+ * GC(5))*GZ+GC(6))*GZ+GC(7))/((((((GC(8)*GZ+GC(9))*GZ+ * GC(10))*GZ+GC(11))*GZ+GC(12))*GZ+GC(13))*GZ+1.D0) IF ( GX .LE. 0.D0 ) GF = GP / ( SIN(GP*GX) * GF ) 5 CONTINUE SGAM = GF RETURN END C======================================================================= FUNCTION SGAU(X) C----------------------------------------------------------------------- C RETURNS GAUSSIAN DISTRIBUTION (NOT NORMALIZED) C----------------------------------------------------------------------- SAVE C----------------------------------------------------------------------- SGAU=EXP(-0.5*X**2) RETURN END C======================================================================= SUBROUTINE SHOPAR C----------------------------------------------------------------------- DOUBLE PRECISION SEEDC,SEEDI COMMON /CSEED/ SEEDC,SEEDI COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT COMMON /PARO3/ ASUHAX(7),ASUHAY(7),OMEGA,SIGPPD,SIGPPE,UENTRO * ,IWZZZZ COMMON /PARO4/ GRICEL,GRIDEL,GRIGAM,GRIRSQ,GRISLO COMMON /PARO5/ DELEPS,DELVOL COMMON /QUARKM/ SMAS,SSMAS,USMAS,UUMAS SAVE C----------------------------------------------------------------------- IF ( ISUP .NE. 1 .AND. ISH .GE. 90 ) THEN WRITE(IFMT,102)('*',I=1,69) * ,TAUNLL,MAXRES,PTF,PTQ,IOPTQ,PTMX,NEQMN,IAQU,WTARG * ,WPROJ,QMUST,SIGPPI,CORE,FCTRMX,NCOLMX,LABSYS,IRESCL,OVERLP * ,NTRYMX,DELMSS,SEEDI,GAUMX,BMAXIM,PUD,PSPINL,PSPINH,PISPN * ,NCLEAN,JPSI,CUTMSS,RSTRAS,ISTMAX,TENSN,NEQMX,IPAGI,NDECAY * ,PDIQUA,PAREA,DELREM,TAUMX,NSTTAU,SIGJ,JPSIFI,BMINIM * ,RADIAC,TAUMIN,TAUMAX,NUMTAU,THEMAS,AMSIAC,ELEPTI 102 FORMAT(' ',69A1 */' * TAUNLL=',F7.3,' MAXRES=',I7,' PTF =',F7.3 *,' PTQ =',F7.3,' *'/' * IOPTQ =',I7,' PTMX =',F7.3 *,' NEQMN =',I7,' IAQU =',I7,' *'/' * WTARG =',F7.3 *,' WPROJ =',F7.3,' QMUST =',F7.3,' SIGPPI=',F7.3,' *' */' * CORE =',F7.3,' FCTRMX=',F7.3,' NCOLMX=',I7 *,' LABSYS=', I7,' *'/' * IRESCL=',I7,' OVERLP=',F7.3 *,' NTRYMX=',I7,' DELMSS=',F7.3,' *'/' * SEEDI=',D24.17 *,' GAUMX =',F7.3,' BMAXIM=',F7.1,' *'/' * PUD =',F7.3 *,' PSPINL=',F7.3,' PSPINH=',F7.3,' PISPN =',F7.3,' *' */' * NCLEAN=',I7,' JPSI =',I7,' CUTMSS=',F7.3 *,' RSTRAS=',F7.3,' *'/' * ISTMAX=',I7,' TENSN =',F7.3 *,' NEQMX =',I7,' IPAGI =',I7,' *'/' * NDECAY=',I7 *,' PDIQUA=',F7.3,' PAREA =',F7.3,' DELREM=',F7.3,' *' */' * TAUMX =',F7.3,' NSTTAU=',I7,' SIGJ =',F7.3 *,' JPSIFI=',I7,' *'/' * BMINIM=',F7.1,' RADIAC=',F7.3 *,' TAUMIN=',F7.3,' TAUMAX=',F7.3,' *'/' * NUMTAU=',I7 *,' THEMAS=',F7.3,' AMSIAC=',F7.3,' ELEPTI=',F7.3,' *') WRITE(IFMT,108) * ELEPTO,ANGMUE,SMAS,UUMAS,USMAS,SSMAS,IOPBRK,NDECAW * ,IMIHIS,KENTRO,RADIAS,ISPHIS,RHOPHI,ICLHIS,ISHSUB,IOPENU * ,IOPENT,CUTMSQ,KUTDIQ,IDPM,TAUREA,ISPALL,YMXIMI,PTH,PHARD * ,IOPTF,PROSEA,NDECAX,WTMINI,WTSTEP,IWCENT,ISHEVT,PVALEN * ,IFRADE,IENTRO,GRIGAM,GRIRSQ,GRIDEL,GRISLO,GRICEL,IJPHIS * ,UENTRO,IWZZZZ,IOJINT,AMPRIF,DELVOL,DELEPS * ,('*',I=1,69) 108 FORMAT( * ' * ELEPTO=',F7.3,' ANGMUE=',F7.3,' SMAS =',F7.3 *,' UUMAS =',F7.3,' *'/' * USMAS =',F7.3,' SSMAS =',F7.3 *,' IOPBRK=',I7,' NDECAW=',I7 ,' *'/' * IMIHIS=',I7 *,' KENTRO=',I7,' RADIAS=',F7.3,' ISPHIS=',I7 ,' *' */' * RHOPHI=',F7.3,' ICLHIS=',I7 ,' ISHSUB=',I7 *,' IOPENU=',I7 ,' *'/' * IOPENT=',I7,' CUTMSQ=',F7.3 *,' KUTDIQ=',I7 ,' IDPM =',I7 ,' *'/' * TAUREA=',F7.3 *,' ISPALL=',I7 ,' YMXIMI=',F7.3,' PTH =',F7.3,' *' */' * PHARD =',F7.3,' IOPTF =',I7 ,' PROSEA=',F7.3 *,' NDECAX=',I7 ,' *'/' * WTMINI=',F7.3,' WTSTEP=',F7.3 *,' IWCENT=',I7 ,' ISHEVT=',I7 ,' *'/' * PVALEN=',F7.3 *,' IFRADE=',I7 ,' IENTRO=',I7 ,' GRIGAM=',F7.3,' *' */' * GRIRSQ=',F7.3,' GRIDEL=',F7.3,' GRISLO=',F7.3 *,' GRICEL=',F7.3,' *'/' * IJPHIS=',I7 ,' UENTRO=',F7.3 *,' IWZZZZ=',I7 ,' IOJINT=',I7 ,' *'/' * AMPRIF=',F7.3 *,' DELVOL=',F7.3,' DELEPS=',F7.3,' ',7X ,' *' */' ',69A1) ENDIF RETURN END C======================================================================= FUNCTION SJCENT(K,KU,U) C---------------------------------------------------------------------- C RETURNS ENTROPY. C INPUT: QUARK NUMBER K; ENERGY U (GEV). C IOPENT=1: OSCILLATOR MODEL. C INTERPOLATES AND EXTRAPOLATES ENTRO(1+K,1+N) C FROM SR JCENTR (JCENTD). C SR JCENTR (JCENTD) HAS TO BE CALLED BEFORE!! C IOPENT=2,3: FERMI GAS MODEL; JOERG AICHELIN. C IOPENT=2: CONST VOLUME, IOPENT=3: CONST DENSITY C IOPENT=4: FERMI GAS (NEW) C IOPENT=5: HAGEDORN C---------------------------------------------------------------------- PARAMETER (KPARX=15) PARAMETER (NQUAX=12) COMMON /CENTRO/ ENTRO(1+KPARX,1+NQUAX) COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT COMMON /PARO3/ ASUHAX(7),ASUHAY(7),OMEGA,SIGPPD,SIGPPE,UENTRO * ,IWZZZZ SAVE C---------------------------------------------------------------------- SJCENT=0. IF ( IOPENT .EQ. 0 ) THEN RETURN ELSEIF ( IOPENT .EQ. 1 ) THEN IF ( K .LE. KENTRO ) RETURN IF ( MOD(K,3) .NE. 0 ) THEN CALL UTSTOP('SJCENT: K MUST BE MULTIPLE OF 3 ') ENDIF E=U/OMEGA IF ( K .GT. KPARX ) GOTO 5001 N=INT(E) IF ( N .LT. 0 ) THEN CALL UTSTOP('SJCENT: NEGATIVE ENERGY ') ENDIF IF ( N .GE. NQUAX ) N=NQUAX-1 SJCENT=ENTRO(1+K,1+N)+(E-N)*(ENTRO(1+K,1+N+1)-ENTRO(1+K,1+N)) IF ( K .LE. 3 ) RETURN 5002 E3=E*3./K N3=INT(E3) IF ( N3 .GE. NQUAX ) N3=NQUAX-1 SENTR3=ENTRO(1+3,1+N3)+(E3-N3) * *(ENTRO(1+3,1+N3+1)-ENTRO(1+3,1+N3)) SJCENT=MIN(SJCENT,K/3.*SENTR3) RETURN 5001 CONTINUE L=KPARX EL=(E*L)/K NL=INT(EL) IF ( NL .GE. NQUAX ) NL=NQUAX-1 SENTRL=ENTRO(1+L,1+NL)+(EL-NL) * *(ENTRO(1+L,1+NL+1)-ENTRO(1+L,1+NL)) SJCENT=FLOAT(K)/L*SENTRL GOTO 5002 ELSEIF ( IOPENT .EQ. 2 ) THEN C CONSTANT VOLUME 5 FM**3 IF ( K .LE. KENTRO ) RETURN X1=12.96*K**(-.315) IF ( K .LT. 19 ) THEN X2=.785 + .005*K ELSE X2=.88 ENDIF SJCENT=K*X1*(U/K)**X2 RETURN ELSEIF ( IOPENT .EQ. 3 ) THEN C CONSTANT DENSITY IF ( K .LE. KENTRO ) RETURN X1=9.785 X2=.7926 SJCENT=K*X1*(U/K)**X2 RETURN ELSEIF ( IOPENT .EQ. 4 ) THEN C CONSTANT VOLUME 15 FM**3 IF ( K .LE. KENTRO ) RETURN SJCENT=SJCEN4(K,KU,U) RETURN ELSEIF ( IOPENT .EQ. 5 ) THEN C HAGEDORN IF ( U .LE. UENTRO .AND. K .LE. KENTRO ) THEN RETURN ENDIF CDH THAGED=.250 CDH SJCENT = U/THAGED SJCENT = U*4. ELSE CALL UTSTOP('SJCENT: INVALID OPTION IOPENT ') ENDIF RETURN END C======================================================================= FUNCTION SJCEN4(K,KU,U) C---------------------------------------------------------------------- C RETURNS TOTAL ENTROPY. C CONSTANT VOLUME 15 FM**3. C INPUT: TOTAL QUARK NUMBER K; UP AND DOWN QUARKS KU; C TOTAL EXCITATION ENERGY U(GEV). C INITIAL CALL OF SJCEN0 REQUIRED!!! C---------------------------------------------------------------------- COMMON /CSJCEN/ ENT(16000) COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT SAVE C---------------------------------------------------------------------- SJCEN4 = 0. IF ( K .LT. KU ) THEN IF ( ISH .GE. 90 ) THEN CALL UTMSG('SJCEN4') WRITE(IFCH,*)'***** K < KU' WRITE(IFCH,*)'***** K: ',K,' KU: ',KU CALL UTMSGF ENDIF RETURN ENDIF IF ( K .GT. 45 ) THEN KO=K K=45 IF ( ISH .GE. 90 ) THEN CALL UTMSG('SJCEN4') WRITE(IFCH,*)'***** K > 45' WRITE(IFCH,*)'***** K: ',KO,' K_NEW: ',K CALL UTMSGF ENDIF ENDIF IF ( MOD(K,3) .NE. 0 ) THEN CALL UTSTOP('SJCEN4: NONINTEGER BARYON NUMBER ') ENDIF IK=0 DO 1 I=3,K-3,3 IK=IK+I+1 1 CONTINUE IF ( U .LT. 10. ) THEN DU=MOD(U,.25) IU=INT(U/.25)+1 IENTRY=(IK+KU)*41+IU SJCEN4=ENT(IENTRY)+(ENT(IENTRY+1)-ENT(IENTRY))*DU*4. ELSE IU=40 IENTRY=(IK+KU)*41+IU SJCEN4=ENT(IENTRY)+(ENT(IENTRY+1)-ENT(IENTRY))*4.*(U-9.75) ENDIF RETURN END C======================================================================= FUNCTION SJCGAM(KEUX,KEDX,KESX,KECX,AMA,AMO,PO,MOX) C---------------------------------------------------------------------- C RETURNS PARTIAL DECAY WIDTH DGAMMA = PHASE SPACE * DENSITY C FOR DECAY OF CLUSTER INTO CLUSTER AND HADRON. C KE*X: NET QUARK NUMBER C AMA: CLUSTER MASS; AMO: HADRON MASS; PO: HADRON MOMENTUM C---------------------------------------------------------------------- COMMON /CENTEX/ ENTEXP COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /CSJCGA/ AMEGAM,AMNULL,ASUHA(7),ENTRPY,NOPHA,NSUHA(7) COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO3/ ASUHAX(7),ASUHAY(7),OMEGA,SIGPPD,SIGPPE,UENTRO * ,IWZZZZ SAVE C---------------------------------------------------------------------- ENTRPY=-99.9 IF ( MOX .EQ. 1 ) THEN ENTEXP=0. AMNULL=UTAMNU(KEUX,KEDX,KESX,KECX,IOPENU) ELSE ENTRPY=ENTRPY-ENTEXP ENDIF EO=SQRT(AMO**2+PO**2) IF ( EO .GT. AMA ) GOTO 999 AME2=(AMA-EO)**2-PO**2 IF ( AME2 .LT. 0. ) GOTO 999 AMEGAM=SQRT(AME2) E=AMEGAM-AMNULL IF ( E .LT. 0. ) GOTO 998 KE=ABS(KEUX+KEDX+KESX+KECX) IF ( IOPENT .EQ. 5 ) THEN IF ( E .LE. UENTRO .AND. KE .LE. KENTRO ) THEN ENTRPY=0. ELSE C ENTROPY AFTER HAGEDORN ENTRPY = E*4. ENDIF ELSE KU=ABS(KEUX+KEDX) ENTRPY=SJCENT(KE,KU,E) ENDIF IF ( MOX .EQ. 1 ) THEN ENTEXP=ENTRPY ENTRPY=0. SJCGAM=.125* PO**2/( PI**2*AMA*EO ) ELSE ENTRPY=ENTRPY-ENTEXP SJCGAM=.125*EXP(ENTRPY)* PO**2/( PI**2*AMA*EO ) ENDIF RETURN 999 AMEGAM = 0. 998 SJCGAM= 0. RETURN END C======================================================================= FUNCTION SMASS(A,Y,Z) C----------------------------------------------------------------------- C RETURNS CLUSTER MASS (IN GEV) (PER CLUSTER, NOT (!) PER NUCLEON) C ACCORDING TO BERGER/JAFFE MASS FORMULA, PRC35(1987)213 EQ.2.31, C SEE ALSO C. DOVER, BNL-46322, INTERSECTIONS-MEETING, TUCSON, 91. C A: MASSNR, Y: HYPERCHARGE, Z: CHARGE, C----------------------------------------------------------------------- COMMON /CMASS/ AC,AS,CZ,DY,DZ,EPSI,RZERO,SIGMA,THET,YM,ZM SAVE C----------------------------------------------------------------------- YMIN=YM*A ZMIN=CZ/(DZ/A+ZM/A**.3333333) SMASS=EPSI*A +AS*A**.6666667 * +(AC/A**.3333333 +DZ/A*0.5)*(Z-ZMIN)**2 * +DY/A*0.5*(Y-YMIN)**2 RETURN END C======================================================================= SUBROUTINE SMASSI(THETA) C----------------------------------------------------------------------- C INITIALIZATION FOR SMASS. C CALCULATES PARAMETERS FOR BERGER/JAFFE MASS FORMULA C (PRC35(1987)213 EQ.2.31, SEE ALSO C. DOVER, BNL-46322). C THETA: PARAMETER THAT DETERMINES ALL PARAMETERS IN MASS FORMULA. C----------------------------------------------------------------------- COMMON /CMASS/ AC,AS,CZ,DY,DZ,EPSI,RZERO,SIGMA,THET,YM,ZM COMMON /CNSTA/ AINFIN,PI,PIOM,PROM DATA ALP /0.007297145/ SAVE C----------------------------------------------------------------------- THET=THETA ASTR=.150 CO=COS(THETA) SI=SIN(THETA) BET=(1.+CO**3)*0.5 RZERO=SI/ASTR/(0.6666667/PI*(1.+CO**3) )**0.3333333 CS=ASTR/SI CZ=CS*(1.-BET**0.3333333 ) SIGMA=0.75/PI*(ASTR/SI)**3*0.3333333*(CO**2*0.5 -SI**2*(1-SI) * -1./PI*(PI*0.5-THETA-SIN(2*THETA)+SI**3*LOG((1+CO)/SI) ) ) EPSI=ASTR*(BET**0.3333333+2.)/SI AS=4.*PI*SIGMA*RZERO**2 AC=0.6*ALP/RZERO DZ=ASTR/SI*BET**0.3333333 *CO**2 * * (CO**4*(1.+BET**0.3333333)+(1+BET)**2)/ *( (2.*CO**2+BET**.3333333)*(CO**4*(1+BET**.6666667)+(1.+BET)**2)- * (CO**4+BET**0.3333333*(1+BET)) * *( (2.*BET**0.6666667-1.)*CO**2+1.+BET) ) DY=ASTR/6.*(1.+CO**3)**3/SI* * ( 1.+(1.+CO)/(4.*(1.+CO**3))**0.6666667 )/ * ( CO**6 + CO + CO*(.5*(1+CO**3))**1.333333 ) ZM=6.*ALP/(5.*RZERO) YM=(1.-CO**3)/(1.+CO**3) RETURN END C======================================================================= SUBROUTINE SMASSP C----------------------------------------------------------------------- C PRINTS SMASS. C----------------------------------------------------------------------- COMMON /CMASS/ AC,AS,CZ,DY,DZ,EPSI,RZERO,SIGMA,THET,YM,ZM COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP REAL ENG(14),YMI(14),ZMI(14) SAVE C----------------------------------------------------------------------- WRITE(IFCH,*)'PARAMETERS OF MASS FORMULA:' WRITE(IFCH,*)'---------------------------' WRITE(IFCH,*)' ' WRITE(IFCH,*)'THETA=',THET,' EPSI=',EPSI WRITE(IFCH,*)'AS=',AS,' AC=',AC WRITE(IFCH,*)'DY=',DY,' DZ=',DZ WRITE(IFCH,*)'YM=',YM WRITE(IFCH,*)'CZ DZ ZM=',CZ,DZ,ZM WRITE(IFCH,*)'SIGMA**1/3=',SIGMA**(1./3.),' RZERO=',RZERO WRITE(IFCH,*)' ' WRITE(IFCH,*)'MASS:' WRITE(IFCH,*)'-----' WRITE(IFCH,5000)(J,J=1,14) 5000 FORMAT(/5X,'A:',14I5/) DO 4 J=1,14 A=J YMI(J)=YM*A ZMI(J)=CZ/(DZ/A+ZM/A**0.3333333) 4 CONTINUE WRITE(IFCH,5002)(YMI(J),J=1,14) 5002 FORMAT(1X,'YMIN: ',14F5.2/) WRITE(IFCH,5003)(ZMI(J),J=1,14) 5003 FORMAT(1X,'ZMIN: ',14F5.2/) DO 2 I=1,15 NS=11-I DO 3 J=1,14 A=J Y=A-NS Z=0. ENG(J)=SMASS(A,Y,Z)/A 3 CONTINUE WRITE(IFCH,5001)NS,(ENG(J),J=1,14) 5001 FORMAT(1X,'S=',I2,2X,14F5.2) 2 CONTINUE WRITE(IFCH,*)' ' WRITE(IFCH,*)'MASS-MASS(FREE):' WRITE(IFCH,*)'----------------' WRITE(IFCH,5000)(J,J=1,14) DO 5 I=1,15 NS=11-I DO 6 J=1,14 A=J Y=A-NS Z=0. SG=SIGN(1.,A) AX=SG*A YX=SG*Y ZX=SG*Z KU=NINT(AX+ZX) KD=NINT(AX-ZX+YX) KS=NINT(AX-YX) KC=0 ENG(J)=(SMASS(A,Y,Z)-UTAMNU(KU,KD,KS,KC,3))/A 6 CONTINUE WRITE(IFCH,5001)NS,(ENG(J),J=1,14) 5 CONTINUE RETURN END C======================================================================= SUBROUTINE SMASST(KUX,KDX,KSX,KCX,A,Y,Z) C----------------------------------------------------------------------- C INPUT: KUX,KDX,KSX,KCX = NET QUARK NUMBERS (FOR U,D,S,C QUARKS). C OUTPUT: MASSNR A, HYPERCHARGE Y AND CHARGE Z. C----------------------------------------------------------------------- SAVE C----------------------------------------------------------------------- SG=1. IF ( KUX+KDX+KSX+KCX .LT. 0 ) SG=-1. KU=SG*KUX KD=SG*KDX KS=SG*KSX KC=SG*KCX K=KU+KD+KS+KC IF ( MOD(K,3) .NE. 0 ) THEN CALL UTSTOP('SMASST: NONINTEGER BARYON NUMBER ') ENDIF A=K/3 Y=A-KS NZ=2*KU-KD-KS+2*KC IF ( MOD(NZ,3) .NE. 0 ) THEN CALL UTSTOP('SMASST: NONINTEGER CHARGE ') ENDIF Z=NZ/3 RETURN END C======================================================================= FUNCTION SPTF(X) C----------------------------------------------------------------------- C RETURNS PT-DISTRIBUTION FOR FRAGMENTATION C----------------------------------------------------------------------- COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /CQUAMA/ QUAMA COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU SAVE C----------------------------------------------------------------------- IF ( IOPTF .EQ. 1 ) THEN SPTF = X * EXP(-2./PTF*SQRT(X**2+QUAMA**2)) ELSEIF ( IOPTF .EQ. 2 ) THEN SPTF = X * EXP(-PI*0.25*(X**2+QUAMA**2)/PTF**2) ENDIF RETURN END C======================================================================= FUNCTION SPTH(X) C----------------------------------------------------------------------- C RETURNS PT-DISTRIBUTION FOR HARD SCATTERING C----------------------------------------------------------------------- COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU SAVE C----------------------------------------------------------------------- SPTH=PTH**2*2.*X/(X**2+PTH**2)**3 RETURN END C======================================================================= FUNCTION SPTJ(X) C----------------------------------------------------------------------- C JPSI PT-DISTRIBUTION IN 200 GEV PP C----------------------------------------------------------------------- DATA AI/1.052631579/, C/2.75482/, C1/1.75482/, CC/16.30716419/ C AI IS THE INVERSE OF A SAVE C----------------------------------------------------------------------- CDH A=0.95 CDH C=1./0.363 CDH Z=X/A Z=X*AI CDH SPTJ=1./A*C**C/SGAM(C)*Z**(C-1.)*EXP(-C*Z) SPTJ = AI * CC * 0.619299158 * Z**C1 * EXP(-C*Z) RETURN END C======================================================================= FUNCTION SPTQ(X) C----------------------------------------------------------------------- C RETURNS PT-DISTRIBUTION OF QUARKS IN NUCLEONS C----------------------------------------------------------------------- COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU SAVE C----------------------------------------------------------------------- IF ( IOPTQ .EQ. 2 ) THEN AUXIL2 = PI/PTQ**2 SPTQ=(0.5*X)* AUXIL2 * EXP(-(0.5*X)**2*AUXIL2) ELSEIF ( IOPTQ .EQ. 1 ) THEN AUXIL1 = 2./PTQ SPTQ=AUXIL1**2 * X * EXP(-X*AUXIL1) ELSEIF ( IOPTQ .EQ. 3 ) THEN SPTQ=PTQ**2 * 2. * X / (X**2+PTQ**2)**2 ENDIF RETURN END C======================================================================= DOUBLE PRECISION FUNCTION SSE0(Z) C----------------------------------------------------------------------- C SEA QUARK STRUCTURE FUNCTION FOR HADRONS C----------------------------------------------------------------------- COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU DOUBLE PRECISION Z SAVE C----------------------------------------------------------------------- SSE0 = (1.D0-Z)**8.05D0 * 1.265D0 / SQRT(Z**2+XCUT**2) RETURN END C======================================================================= DOUBLE PRECISION FUNCTION SSE1(Z) C----------------------------------------------------------------------- C SEA QUARK STRUCTURE FUNCTION FOR PIONS C----------------------------------------------------------------------- COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU DOUBLE PRECISION Z SAVE C----------------------------------------------------------------------- SSE1 = (1.D0-Z)**5.D0 * 0.9D0 / SQRT(Z**2+XCUT**2) RETURN END C======================================================================= FUNCTION SSPLIT(X) C----------------------------------------------------------------------- C RETURNS SPLITTING FUNCTION C----------------------------------------------------------------------- SAVE C----------------------------------------------------------------------- C-C SSPLIT= ( 0.3 + 10.0*X**7 - 10.3*X**15 ) /SQRT(X**2+.2**2) C-C SSPLIT= 0.2 + 2.4*X**2 - 2.6*X**5 C-C SSPLIT= 0.4 + 2.0*X - 2.4*X**3 C-C SSPLIT= ( 0.8 + 2.0*X - 2.8*X**3 ) /SQRT(X**2+.2**2) SSPLIT= X**3 - X**5 RETURN END C======================================================================= FUNCTION SSPLIX(X) C----------------------------------------------------------------------- C RETURNS SPLITTING FUNCTION C----------------------------------------------------------------------- SAVE C----------------------------------------------------------------------- C-C SSPLIX= (1-X) - (1-X)**7 C-C SSPLIX= 1 C-C Z=2*X-.5 C-C SSPLIX= Z**3 - Z**5 C-C IF ( Z .LT. 0. ) SSPLIX=0. C-C IF ( Z .GT. 1. ) SSPLIX=0. SSPLIX= X**3 - X**5 RETURN END C======================================================================= SUBROUTINE STAA(X,Q2I,Z,S) C----------------------------------------------------------------------- C STRUCTURE FUNCTIONS. C----------------------------------------------------------------------- COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU SAVE C----------------------------------------------------------------------- Z=SQRT(X**2+XCUT**2) Q2=MAX(4.00001,Q2I) CDH S=LOG(LOG(Q2/.2**2)/LOG(4/.2**2)) S=LOG(LOG(Q2*25. )*0.21714724) RETURN END C======================================================================= FUNCTION STXD(X,Q2) C----------------------------------------------------------------------- C VALENCE D-QUARK DISTRIBUTION. C FROM GLUECK, HOFFMANN, REYA, Z. PHYS. C13 (1982) 119. C----------------------------------------------------------------------- SAVE C----------------------------------------------------------------------- CALL STAA(X,Q2,Z,S) A=.364-.0368*S C=2.-.5414*S**.8 D=5.09+.3463*S STXD=C*X**A*(1.-X**C)**D/SBET(D+1.,A/C) RETURN END C======================================================================= FUNCTION STXS(X,Q2) C----------------------------------------------------------------------- C S-SEA DISTRIBUTION. C FROM GLUECK, HOFFMANN, REYA, Z. PHYS. C13 (1982) 119. C----------------------------------------------------------------------- SAVE C----------------------------------------------------------------------- CALL STAA(X,Q2,Z,S) A=.0625+.1132*S**1.3 B=12.64*S-51.70*S**1.8+38.02*S**2 C=4.448*S D=7.+1.562*S E=.3081*S**2.5 F=47.24+67.91*S STXS=A*(1.+B*X+C*X**2)*(1.-X)**D + E*EXP(-F*X) RETURN END C======================================================================= FUNCTION STXU(X,Q2) C----------------------------------------------------------------------- C VALENCE U-QUARK DISTRIBUTION. C FROM GLUECK, HOFFMANN, REYA, Z. PHYS. C13 (1982) 119. C----------------------------------------------------------------------- SAVE C----------------------------------------------------------------------- CALL STAA(X,Q2,Z,S) A=.421-.0412*S C=2.-.6223*S**.8 D=3.37+.4319*S STXU=2.*C*X**A*(1.-X**C)**D/SBET(D+1.,A/C) RETURN END C======================================================================= FUNCTION STXUS(X,Q2) C----------------------------------------------------------------------- C U-SEA DISTRIBUTION. C FROM GLUECK, HOFFMANN, REYA, Z. PHYS. C13 (1982) 119. C----------------------------------------------------------------------- SAVE C----------------------------------------------------------------------- CALL STAA(X,Q2,Z,S) A=.25+.088*S**1.3 B=.8128*S-2.003*S**1.8+.0831*S**2 C=3.97*S D=7.+1.666*S E=.2487*S**2.5 F=27.8+59.68*S STXUS=A*(1.+B*X+C*X**2)*(1.-X)**D + E*EXP(-F*X) RETURN END C======================================================================= FUNCTION STXZNE(X,Q2) C----------------------------------------------------------------------- C STRUCTURE FUNCTION OF NEUTRON C----------------------------------------------------------------------- SAVE C----------------------------------------------------------------------- STXZNE=(4.*STXD(X,Q2) + STXU(X,Q2) + * 10.*STXUS(X,Q2) + 2.*STXS(X,Q2))/9. RETURN END C======================================================================= FUNCTION STXZPR(X,Q2) C----------------------------------------------------------------------- C STRUCTURE FUNCTION OF PROTON C----------------------------------------------------------------------- SAVE C----------------------------------------------------------------------- STXZPR=(4.*STXU(X,Q2) + STXD(X,Q2) + * 10.*STXUS(X,Q2) + 2.*STXS(X,Q2))/9. RETURN END C======================================================================= DOUBLE PRECISION FUNCTION SVA0(Z) C----------------------------------------------------------------------- C VALENCE QUARK STRUCTURE FUNCTION FOR HADRONS C----------------------------------------------------------------------- COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU DOUBLE PRECISION Z SAVE C----------------------------------------------------------------------- IF ( Z .NE. 0.D0 ) THEN SVA0=(1.D0-Z)**3.46 * Z**0.419 * (2.74793064D0*Z + 0.62452969D0) * / SQRT(Z**2+XCUT**2) ELSE SVA0=0.D0 ENDIF RETURN END C======================================================================= DOUBLE PRECISION FUNCTION SVA1(Z) C----------------------------------------------------------------------- C VALENCE QUARK STRUCTURE FUNCTION FOR PIONS C----------------------------------------------------------------------- COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU DOUBLE PRECISION Z SAVE C----------------------------------------------------------------------- IF ( Z .NE. 0.D0 ) THEN SVA1 = (1.D0-Z)**0.7D0 * Z**0.4D0 * 0.1730725D0 * / SQRT(Z**2+XCUT**2) ELSE SVA1=0.D0 ENDIF RETURN END C======================================================================= SUBROUTINE UINTEG(VAL,FUNC,A,B,AERR,RERR,LEVEL,ERROR,IFLAG) C----------------------------------------------------------------------- C CACLULATION OF DEFINITE INTEGRAL OF FUNC(X) FROM A TO B C----------------------------------------------------------------------- C RELERR=1.D-12 C ABSERR=0.D0 C LEVEL=1 C CALL UINTEG(VALUE,FUNCTN,A,B,ABSERR,RELERR,LEVEL,ERROR,IFLAG) C IF (IFLAG.GT.3) WRITE(*,'('' IFLAG ='',I7)') IFLAG C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION T(10,10),R(10),AIT(10),DIF(10),RN(4) DIMENSION TS(2049),IBEGS(30),BEGIN(30),FINIS(30),EST(30) LOGICAL H2CONV,AITKEN,RIGHT,REGLAR,REGLSV(30) DATA TOLSAV,AITLOW,H2TOL,AITTOL,VJUMP,MAXTS,MAXTBL,MXSTGE * / 1.D-16, 1.1D0, .15D0, .1D0, .01D0, 2049, 10, 30 / DATA RN /.71420053D0,.34662815D0,.843751D0,.12633046D0 / DATA ALG402 /.3010299956639795D0 / SAVE C----------------------------------------------------------------------- TOLMCH=TOLSAV VAL=0.D0 ERROR=0.D0 IFLAG=1 VLONG=DABS(B-A) IF ( VLONG .EQ. 0.D0 ) RETURN ERRR=DMIN1( .1D0, DMAX1(DABS(RERR),1.D1*TOLMCH) ) ERRA=DABS(AERR) STEPMN=DMAX1(VLONG/FLOAT(2**MXSTGE), * DMAX1(VLONG,DABS(A),DABS(B))*TOLMCH) STAGE=.5D0 ISTAGE=1 CUREST=0.D0 FNSIZE=0.D0 PREVER=0.D0 REGLAR=.FALSE. BEGI=A FBEG=FUNC(A)/2.D0 TS(1)=FBEG IBEG=1 ENDE=B FEND=FUNC(B)/2.D0 TS(2)=FEND IEND=2 60 CONTINUE RIGHT=.FALSE. 61 CONTINUE STEP=ENDE-BEGI ASTEP=DABS(STEP) IF ( ASTEP .LT. STEPMN ) GOTO 97 IF ( LEVEL .GE. 3 ) WRITE(*,101) BEGI,STEP,ISTAGE 101 FORMAT(' BEGI,STEP',1P,2E16.7,I5) T(1,1)=FBEG+FEND TABS=DABS(FBEG)+DABS(FEND) L=1 N=1 H2CONV=.FALSE. AITKEN=.FALSE. GOTO 63 62 IF ( LEVEL .GE. 4 ) WRITE(*,102) L,T(1,LM1) 102 FORMAT(1X,I5,7E16.8/1X,3E16.8) 63 LM1=L L=L+1 N2=N*2 FN=N2 ISTEP=(IEND-IBEG)/N IF ( ISTEP .LE. 1 ) THEN II=IEND IEND=IEND+N IF ( IEND .GT. MAXTS ) GOTO 96 HOVN=STEP/FN III=IEND DO 64 I=1,N2,2 TS(III)=TS(II) TS(III-1)=FUNC(ENDE-FLOAT(I)*HOVN) III=III-2 II=II-1 64 CONTINUE ISTEP=2 ENDIF ISTEP2=IBEG+ISTEP/2 SUM=0.D0 SUMABS=0.D0 DO 65 I=ISTEP2,IEND,ISTEP SUM=SUM+TS(I) SUMABS=SUMABS+DABS(TS(I)) 65 CONTINUE T(L,1)=T(L-1,1)/2.D0 + SUM/FN TABS=TABS/2.D0+SUMABS/FN ABSI=ASTEP*TABS N=N2 IT=1 VINT=STEP*T(L,1) TABTLM=TABS*TOLMCH FNSIZE=DMAX1(FNSIZE,DABS(T(L,1))) ERGOAL=DMAX1(ASTEP*TOLMCH*FNSIZE, * STAGE*DMAX1(ERRA,ERRR*DABS((CUREST)+VINT))) FEXTRP=1.D0 DO 66 I=1,LM1 FEXTRP=FEXTRP*4.D0 T(I,L)=T(L,I)-T(L-1,I) T(L,I+1)=T(L,I)+T(I,L)/(FEXTRP-1.D0) 66 CONTINUE ERRER=ASTEP*DABS(T(1,L)) IF ( L .LE. 2 ) THEN IF ( DABS(T(1,2)) .LE. TABTLM) GOTO 81 GOTO 63 ENDIF DO 67 I=2,LM1 DIFF=0.D0 IF ( DABS(T(I-1,L)) .GT. TABTLM ) DIFF=T(I-1,LM1)/T(I-1,L) T(I-1,LM1)=DIFF 67 CONTINUE IF ( DABS(4.D0-T(1,LM1)) .LE. H2TOL ) GOTO 69 IF ( T(1,LM1) .EQ. 0.D0 ) GOTO 68 IF ( DABS(2.D0-DABS(T(1,LM1))) .LT. VJUMP ) GOTO 80 IF ( L .EQ. 3 ) GOTO 62 H2CONV=.FALSE. IF ( DABS((T(1,LM1)-T(1,L-2))/T(1,LM1)) .LE. AITTOL ) GOTO 72 IF ( REGLAR ) GOTO 68 IF ( L .EQ. 4 ) GOTO 62 68 IF ( ERRER .LE. ERGOAL ) GOTO 83 IF ( LEVEL .GE. 4 ) WRITE(*,103) L,T(1,LM1) 103 FORMAT(1X,I5,7E16.8/1X,3E16.8) GOTO 90 69 CONTINUE IF ( LEVEL .GE. 4 ) WRITE(*,104) L,T(1,LM1) 104 FORMAT(1X,I5,E16.8,5X,'H2CONV') IF ( H2CONV ) GOTO 70 AITKEN=.FALSE. H2CONV=.TRUE. IF ( LEVEL .GE. 3 ) WRITE(*,105) L 105 FORMAT(' H2 CONVERGENCE AT ROW',I4) 70 FEXTRP=4.D0 71 IT=IT+1 VINT=STEP*T(L,IT) ERRER=DABS(STEP/(FEXTRP-1.D0)*T(IT-1,L)) IF ( ERRER .LE. ERGOAL ) GOTO 86 IF ( IT .EQ. LM1 ) GOTO 79 IF ( T(IT,LM1) .EQ. 0.D0 ) GOTO 71 IF ( T(IT,LM1) .LE. FEXTRP ) GOTO 79 IF ( DABS(T(IT,LM1)/4.D0-FEXTRP)/FEXTRP .LT. AITTOL ) * FEXTRP=FEXTRP*4.D0 GOTO 71 72 IF ( LEVEL .GE. 4 ) WRITE(*,106) L,T(1,LM1) 106 FORMAT(1X,I5,E16.8,5X,'AITKEN') IF ( T(1,LM1) .LT. AITLOW ) GOTO 90 IF ( AITKEN ) GOTO 73 H2CONV=.FALSE. AITKEN=.TRUE. IF ( LEVEL .GE. 3 ) WRITE(*,107) L 107 FORMAT(' AITKEN AT ROW',I4) 73 FEXTRP=T(L-2,LM1) IF ( FEXTRP .GT. 4.5 ) GOTO 70 IF ( FEXTRP .LT. AITLOW ) GOTO 90 IF ( DABS(FEXTRP-T(L-3,LM1))/T(1,LM1) .GT. H2TOL ) GOTO 90 IF ( LEVEL .GE. 3 ) WRITE(*,108) FEXTRP 108 FORMAT(' RATIO',F13.8) SING=FEXTRP FEXTM1=FEXTRP-1 AIT(1)=0. DO 74 I=2,L AIT(I)=T(I,1)+(T(I,1)-T(I-1,1))/FEXTM1 R(I)=T(1,I-1) DIF(I)=AIT(I)-AIT(I-1) 74 CONTINUE IT=2 75 VINT=STEP*AIT(L) IF ( LEVEL .GE. 5 ) THEN WRITE(*,109) (R(I+1),I=IT,LM1) 109 FORMAT(1X,8E15.8) WRITE(*,109) (AIT(I),I=IT,L) WRITE(*,109) (DIF(I+1),I=IT,LM1) ENDIF ERRER=ERRER/FEXTM1 IF ( ERRER .GT. ERGOAL ) GOTO 76 ALPHA=DLOG10(SING)/ALG402-1.D0 IF ( LEVEL .GE. 2 ) WRITE(*,110) ALPHA,BEGI,ENDE 110 FORMAT(11X,'INTEGRAND SHOWS SINGULAR ', * 'BEHAVIOUR OF TYPE X**(',F5.2,') BETWEEN',1P,E15.7, * ' AND',1P,E15.7) IFLAG=MAX0(IFLAG,2) GOTO 86 76 IT=IT+1 IF ( IT .EQ. LM1 ) GOTO 79 IF ( IT .LE. 3 ) THEN H2NEXT=4.D0 SINGNX=2.D0*SING ENDIF IF ( H2NEXT .GE. SINGNX) THEN FEXTRP=SINGNX SINGNX=2.D0*SINGNX ELSE FEXTRP=H2NEXT H2NEXT=4.D0*H2NEXT ENDIF DO 77 I=IT,LM1 R(I+1)=0.D0 IF ( DABS(DIF(I+1)) .GT. TABTLM ) R(I+1)=DIF(I)/DIF(I+1) 77 CONTINUE IF ( LEVEL .GE. 4 ) WRITE(*,111) FEXTRP,R(L-1),R(L) 111 FORMAT(' FEXTRP + RATIOS',1P,3E15.7) H2TFEX=-H2TOL*FEXTRP IF ( R(L)-FEXTRP .LT. H2TFEX ) GOTO 79 IF ( R(L-1)-FEXTRP .LT. H2TFEX ) GOTO 79 ERRER=ASTEP*DABS(DIF(L)) FEXTM1=FEXTRP-1.D0 DO 78 I=IT,L AIT(I)=AIT(I)+DIF(I)/FEXTM1 DIF(I)=AIT(I)-AIT(I-1) 78 CONTINUE GOTO 75 79 FEXTRP=DMAX1(PREVER/ERRER,AITLOW) PREVER=ERRER IF ( L .LT. 5 ) GOTO 63 IF ( LEVEL .GE. 3 ) WRITE(*,112) ERRER,ERGOAL,FEXTRP,IT 112 FORMAT(' ERRER,ERGOAL,FEXTRP,IT',1P,2E15.7,1P,E14.5,0P,I3) IF ( L-IT .GT. 2 .AND. ISTAGE .LT. MXSTGE ) GOTO 89 IF ( ERRER/FEXTRP**(MAXTBL-L) .LT. ERGOAL ) GOTO 63 GOTO 89 80 IF ( LEVEL .GE. 4 ) WRITE(*,113) L,T(1,LM1) 113 FORMAT(1X,I5,E16.8,5X,'JUMP') IF ( ERRER .GT. ERGOAL ) GOTO 89 DIFF=DABS(T(1,L))*2.D0*FN IF ( LEVEL .GE. 2 ) WRITE(*,114) DIFF,BEGI,ENDE 114 FORMAT(13X,'INTEGRAND SEEMS TO HAVE JUMP OF SIZE', * 1P,E15.7,' BETWEEN',1P,E15.7,' AND',1P,E15.7) GOTO 86 81 IF ( LEVEL .GE. 4 ) WRITE(*,115) L 115 FORMAT(1X,I5,21X,'STRAIGHT LINE') SLOPE=(FEND-FBEG)*2.D0 FBEG2=FBEG*2.D0 DO 82 I=1,4 DIFF=DABS(FUNC(BEGI+RN(I)*STEP)-FBEG2-RN(I)*SLOPE) IF ( DIFF .GT. TABTLM) GOTO 85 82 CONTINUE IF ( LEVEL .GE. 3 ) WRITE(*,116) BEGI,ENDE 116 FORMAT(27X,'INTEGRAND SEEMS TO BE STRAIGHT LINE BETWEEN', * 1P,E15.7,' AND',1P,E15.7) GOTO 86 83 IF ( LEVEL .GE. 4 ) WRITE(*,117) L,T(1,LM1) 117 FORMAT(1X,I5,1P,E15.7,5X,'NOISE') SLOPE=(FEND-FBEG)*2.D0 FBEG2=FBEG*2.D0 I=1 84 DIFF=DABS(FUNC(BEGI+RN(I)*STEP)-FBEG2-RN(I)*SLOPE) 85 ERRER=DMAX1(ERRER,ASTEP*DIFF) IF ( ERRER .GT. ERGOAL ) GOTO 90 I=I+1 IF ( I .LE. 4 ) GOTO 84 IF ( LEVEL .GE. 3 ) WRITE(*,118) BEGI,ENDE 118 FORMAT(' NOISE BETWEEN',1P,E15.7,' AND',1P,E15.7) IFLAG=3 86 VAL=VAL+VINT ERROR=ERROR+ERRER IF ( LEVEL .GE. 3 ) THEN IF ( LEVEL .GE. 5 ) THEN DO 87 I=1,L IF ( LEVEL .GE. 4 ) WRITE(*,119) I,(T(I,J),J=1,L) 119 FORMAT(1X,I5,7E16.8/1X,3E16.8) 87 CONTINUE ENDIF WRITE(*,120) VINT,ERRER,L,IT 120 FORMAT(' INTEGRAL IS',1P,E16.8,', ERROR',1P,E16.8, * ' FROM T(',I1,',',I1,'1H)') ENDIF IF ( RIGHT ) GOTO 88 ISTAGE=ISTAGE-1 IF ( ISTAGE .EQ. 0 ) RETURN REGLAR=REGLSV(ISTAGE) BEGI=BEGIN(ISTAGE) ENDE=FINIS(ISTAGE) CUREST=CUREST-EST(ISTAGE+1)+VINT IEND=IBEG-1 FEND=TS(IEND) IBEG=IBEGS(ISTAGE) GOTO 92 88 CUREST=CUREST+VINT STAGE=STAGE*2.D0 IEND=IBEG IBEG=IBEGS(ISTAGE) ENDE=BEGI BEGI=BEGIN(ISTAGE) FEND=FBEG FBEG=TS(IBEG) GOTO 60 89 REGLAR=.TRUE. 90 IF ( ISTAGE .EQ. MXSTGE ) GOTO 97 IF ( LEVEL .GE. 5 ) THEN DO 91 I=1,L IF ( LEVEL .GE. 4 ) WRITE(*,121) I,(T(I,J),J=1,L) 121 FORMAT(1X,I5,7E16.8/1X,3E16.8) 91 CONTINUE ENDIF IF ( RIGHT ) GOTO 93 REGLSV(ISTAGE+1)=REGLAR BEGIN(ISTAGE)=BEGI IBEGS(ISTAGE)=IBEG STAGE=STAGE/2.D0 92 RIGHT=.TRUE. BEGI=(BEGI+ENDE)/2.D0 IBEG=(IBEG+IEND)/2 TS(IBEG)=TS(IBEG)/2.D0 FBEG=TS(IBEG) GOTO 61 93 NNLEFT=IBEG-IBEGS(ISTAGE) IF ( IEND+NNLEFT .GE. MAXTS ) GOTO 96 III=IBEGS(ISTAGE) II=IEND DO 94 I=III,IBEG II=II+1 TS(II)=TS(I) 94 CONTINUE DO 95 I=IBEG,II TS(III)=TS(I) III=III+1 95 CONTINUE IEND=IEND+1 IBEG=IEND-NNLEFT FEND=FBEG FBEG=TS(IBEG) FINIS(ISTAGE)=ENDE ENDE=BEGI BEGI=BEGIN(ISTAGE) BEGIN(ISTAGE)=ENDE REGLSV(ISTAGE)=REGLAR ISTAGE=ISTAGE+1 REGLAR=REGLSV(ISTAGE) EST(ISTAGE)=VINT CUREST=CUREST+EST(ISTAGE) GOTO 60 96 CONTINUE IF ( LEVEL .GE. 2 ) WRITE(*,122) BEGI,ENDE 122 FORMAT(' TOO MANY FUNCTION EVALUATIONS AROUND'/ * 11X,1P,E15.7,' AND',1P,E15.7) IFLAG=4 GOTO 99 97 CONTINUE IFLAG=5 IF ( LEVEL .GE. 2 ) THEN IF ( LEVEL .GE. 5 ) THEN DO 98 I =1,L IF ( LEVEL .GE. 4 ) WRITE(*,123) I,(T(I,J),J=1,L) 123 FORMAT(1X,I5,7E16.8/1X,3E16.8) 98 CONTINUE ENDIF WRITE(*,124) BEGI,ENDE 124 FORMAT(11X,'INTEGRAND SHOWS SINGULAR BEHAVIOUR OF ', * 'UNKNOWN TYPE BETWEEN',1P,E15.7,' AND',1P,E15.7) ENDIF 99 CONTINUE VAL=CUREST+VINT RETURN END C======================================================================= FUNCTION UTACOS(X) C----------------------------------------------------------------------- C RETURNS ACOS(X) FOR -1 <= X <= 1 , ACOS(+-1) ELSE C----------------------------------------------------------------------- COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT SAVE C----------------------------------------------------------------------- ARGUM=X IF ( X .LT. -1. ) THEN IF ( ISH .GE. 90 ) THEN CALL UTMSG('UTACOS') WRITE(IFCH,*)'***** ARGUM = ',ARGUM,' SET -1' CALL UTMSGF ENDIF ARGUM=-1. ELSEIF ( X .GT. 1. ) THEN IF ( ISH .GE .90 ) THEN CALL UTMSG('UTACOS') WRITE(IFCH,*)'***** ARGUM = ',ARGUM,' SET 1' CALL UTMSGF ENDIF ARGUM=1. ENDIF UTACOS=ACOS(ARGUM) RETURN END C======================================================================= FUNCTION UTAMNU(KEUX,KEDX,KESX,KECX,MODUS) C---------------------------------------------------------------------- C RETURNS MIN MASS OF CLUSTER WITH GIVEN U,D,S,C CONTENT C KEUX: NET U QUARK NUMBER C KEDX: NET D QUARK NUMBER C KESX: NET S QUARK NUMBER C KECX: NET C QUARK NUMBER C MODUS:0,1,2,3,4,5,6 C---------------------------------------------------------------------- COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /CSJCGA/ AMEGAM,AMNULL,ASUHA(7),ENTRPY,NOPHA,NSUHA(7) COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO3/ ASUHAX(7),ASUHAY(7),OMEGA,SIGPPD,SIGPPE,UENTRO * ,IWZZZZ SAVE C---------------------------------------------------------------------- AMNULL=0. IF ( MODUS .EQ. 0 ) THEN DO 21 I=1,7 ASUHA(I)=ASUHAY(I) NSUHA(I)=0 21 CONTINUE ELSEIF ( MODUS .EQ. 1 ) THEN IF ( NOPHA .EQ. 0 ) THEN DO 22 I=1,7 ASUHA(I)=ASUHAX(I) NSUHA(I)=0 22 CONTINUE ELSEIF ( NOPHA .GE. 1 ) THEN DO 23 I=1,7 ASUHA(I)=ASUHAY(I) NSUHA(I)=0 23 CONTINUE ENDIF ELSEIF ( MODUS .EQ. 2 ) THEN DO 24 I=1,7 ASUHA(I)=ASUHAY(I) NSUHA(I)=0 24 CONTINUE ELSEIF ( MODUS .EQ. 3 ) THEN DO 25 I=1,7 ASUHA(I)=ASUHAY(I) NSUHA(I)=0 25 CONTINUE ELSEIF ( MODUS .EQ. 4 ) THEN DO 26 I=1,7 ASUHA(I)=ASUHAX(I) NSUHA(I)=0 26 CONTINUE ELSEIF ( MODUS .EQ. 5 ) THEN DO 27 I=1,7 ASUHA(I)=ASUHAY(I) NSUHA(I)=0 27 CONTINUE ELSEIF ( MODUS .EQ. 6 ) THEN DO 28 I=1,7 ASUHA(I)=SQRT(ASUHAY(I)**2+DELMSS**2) NSUHA(I)=0 28 CONTINUE ENDIF IAUX=KEUX+KEDX+KESX+KECX KE=ABS(IAUX) IF ( IAUX .GE. 0 ) THEN KEU=KEUX KED=KEDX KES=KESX KEC=KECX ELSE KEU=-KEUX KED=-KEDX KES=-KESX KEC=-KECX ENDIF IF ( KEC .NE. 0 ) THEN 10 CONTINUE IF ( KEC .LT. 0 ) THEN KEC=KEC+1 IF ( KEU .GT. KED ) THEN KEU=KEU-1 ELSE KED=KED-1 ENDIF AMNULL=AMNULL+1.87 GOTO 10 ENDIF 11 CONTINUE IF ( KEC .GT. 0 ) THEN KEC=KEC-1 IF ( KEU .LT. KED ) THEN KEU=KEU+1 ELSE KED=KED+1 ENDIF AMNULL=AMNULL+1.87 GOTO 11 ENDIF ENDIF 5 CONTINUE IF ( KES .LT. 0 ) THEN AMNULL=AMNULL+ASUHA(6) IF ( KEU .GE. KED ) THEN KEU=KEU-1 ELSE KED=KED-1 ENDIF KES=KES+1 GOTO 5 ENDIF 6 CONTINUE IF ( KED .LT. 0 ) THEN IF ( KEU .GE. KES ) THEN AMNULL=AMNULL+ASUHA(5) KEU=KEU-1 ELSE AMNULL=AMNULL+ASUHA(6) KES=KES-1 ENDIF KED=KED+1 GOTO 6 ENDIF 7 CONTINUE IF ( KEU .LT. 0 ) THEN IF ( KED .GE. KES ) THEN AMNULL=AMNULL+ASUHA(5) KED=KED-1 ELSE AMNULL=AMNULL+ASUHA(6) KES=KES-1 ENDIF KEU=KEU+1 GOTO 7 ENDIF IF ( KEU+KED+KES+KEC .NE. KE ) THEN CALL UTSTOP('UTAMNU: SUM_KEI /= KE ') ENDIF KEQ=KEU+KED KEQX=KEQ IF ( MODUS .EQ. 2 .AND. KE .GT. 3 ) THEN CALL SMASST(KEU,KED,KES,KEC,A,Y,Z) AMNUZ=SMASS(A,Y,Z) ENDIF AMNUX=0. I=4 2 I=I-1 3 CONTINUE IF ( (4-I)*KES .GT. (I-1)*KEQ ) THEN AMNUX=AMNUX+ASUHA(1+I) KEQ=KEQ-3+I KES=KES-I IF ( KES .LT. 0 ) THEN CALL UTSTOP('UTAMNU: NEGATIVE KES ') ENDIF IF ( KEQ .LT. 0 ) THEN CALL UTSTOP('UTAMNU: NEGATIVE KEQ ') ENDIF GOTO 3 ENDIF IF ( I .GT. 1 ) GOTO 2 IF ( KEQX .GT. KEQ ) THEN DO 8 K=1,KEQX-KEQ IF ( KEU .GE. KED ) THEN KEU=KEU-1 ELSE KED=KED-1 ENDIF 8 CONTINUE ENDIF IF ( KEU+KED .NE. KEQ ) THEN CALL UTSTOP('UTAMNU: KEU+KED /= KEQ ') ENDIF 9 CONTINUE IF ( KEU .GT. 2*KED ) THEN AMNUX=AMNUX+ASUHA(7) KEU=KEU-3 IF ( KEU .LT. 0 ) THEN CALL UTSTOP('UTAMNU: NEGATIVE KEU ') ENDIF GOTO 9 ENDIF IF ( KED .GT. 2*KEU ) THEN AMNUX=AMNUX+ASUHA(7) KED=KED-3 IF ( KED .LT. 0 ) THEN CALL UTSTOP('UTAMNU: NEGATIVE KED ') ENDIF GOTO 9 ENDIF KEQ=KEU+KED IF ( MOD(KEQ,3) .NE. 0 ) THEN CALL UTSTOP('UTAMNU: MOD(KEQ,3) /= 0 ') ENDIF AMNUX=AMNUX+ASUHA(1)*KEQ/3 AMNU=AMNUX IF ( MODUS.EQ.2 .AND. KE.GT.3 ) AMNU=MIN(AMNUX,AMNUZ) AMNULL=AMNULL+AMNU IF ( AMNULL.EQ.0. .AND. MODUS.GT.0 ) AMNULL=ASUHA(5) 1000 UTAMNU=AMNULL RETURN END C======================================================================= FUNCTION UTAMNX(JCP,JCM) C----------------------------------------------------------------------- C RETURNS MINIMUM MASS FOR THE DECAY OF JCP---JCM (BY CALLING UTAMNU). C----------------------------------------------------------------------- PARAMETER (NFLAV=6) INTEGER JCM(NFLAV,2),JCP(NFLAV,2) SAVE C----------------------------------------------------------------------- DO 3 I=1,NFLAV IF ( JCP(I,1) .NE. 0 ) GOTO 1 IF ( JCP(I,2) .NE. 0 ) GOTO 1 3 CONTINUE KEU=JCM(1,1)-JCM(1,2) KED=JCM(2,1)-JCM(2,2) KES=JCM(3,1)-JCM(3,2) KEC=JCM(4,1)-JCM(4,2) UTAMNX=UTAMNU(KEU,KED,KES,KEC,5) RETURN 1 CONTINUE DO 4 I=1,NFLAV IF ( JCM(I,1) .NE. 0 ) GOTO 2 IF ( JCM(I,2) .NE. 0 ) GOTO 2 4 CONTINUE KEU=JCP(1,1)-JCP(1,2) KED=JCP(2,1)-JCP(2,2) KES=JCP(3,1)-JCP(3,2) KEC=JCP(4,1)-JCP(4,2) UTAMNX=UTAMNU(KEU,KED,KES,KEC,5) RETURN 2 CONTINUE KEU=JCP(1,1)-JCP(1,2) KED=JCP(2,1)-JCP(2,2) KES=JCP(3,1)-JCP(3,2) KEC=JCP(4,1)-JCP(4,2) KE=KEU+KED+KES+KEC IF ( MOD(KE+1,3) .EQ. 0 ) THEN KEU=KEU+1 ELSEIF ( MOD(KE-1,3) .EQ. 0 ) THEN KEU=KEU-1 ELSE CALL UTSTOP('UTAMNX: NO SINGLET POSSIBLE (1) ') ENDIF AMMS=UTAMNU(KEU,KED,KES,KEC,5) KEU=JCM(1,1)-JCM(1,2) KED=JCM(2,1)-JCM(2,2) KES=JCM(3,1)-JCM(3,2) KEC=JCM(4,1)-JCM(4,2) KE=KEU+KED+KES+KEC IF ( MOD(KE+1,3) .EQ. 0 ) THEN KEU=KEU+1 ELSEIF ( MOD(KE-1,3) .EQ. 0 ) THEN KEU=KEU-1 ELSE CALL UTSTOP('UTAMNX: NO SINGLET POSSIBLE (2) ') ENDIF UTAMNX=AMMS+UTAMNU(KEU,KED,KES,KEC,5) RETURN END C======================================================================= FUNCTION UTAMNY(JCP,JCM) C----------------------------------------------------------------------- C RETURNS MINIMUM MASS OF JCP+JCM (BY CALLING UTAMNU). C----------------------------------------------------------------------- PARAMETER (NFLAV=6) INTEGER JC(NFLAV,2),JCM(NFLAV,2),JCP(NFLAV,2) SAVE C----------------------------------------------------------------------- DO 7 NF=1,NFLAV JC(NF,1)=JCP(NF,1)+JCM(NF,1) JC(NF,2)=JCP(NF,2)+JCM(NF,2) 7 CONTINUE KEU=JC(1,1)-JC(1,2) KED=JC(2,1)-JC(2,2) KES=JC(3,1)-JC(3,2) KEC=JC(4,1)-JC(4,2) UTAMNY=UTAMNU(KEU,KED,KES,KEC,5) RETURN END C======================================================================= FUNCTION UTAMNZ(JC,MODUS) C----------------------------------------------------------------------- C RETURNS MINIMUM MASS OF JC (BY CALLING UTAMNU). C----------------------------------------------------------------------- PARAMETER (NFLAV=6) INTEGER JC(NFLAV,2) SAVE C----------------------------------------------------------------------- KEU=JC(1,1)-JC(1,2) KED=JC(2,1)-JC(2,2) KES=JC(3,1)-JC(3,2) KEC=JC(4,1)-JC(4,2) UTAMNZ=UTAMNU(KEU,KED,KES,KEC,MODUS) RETURN END C======================================================================= SUBROUTINE UTAMST(STS,AM,AMIN,IRET) C----------------------------------------------------------------------- C INPUT: STS = STRING (SINGLE) C OUTPUT: AM = MASS C AMIN = MINIMUM MASS C IRET = RETURN CODE (=3 IF AM**2.LT.AMIN**2, 0 ELSE) C----------------------------------------------------------------------- PARAMETER (NFLAV=6) PARAMETER (NSI=6) COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU REAL STS(NSI,2) INTEGER IC1(2),IC2(2),JC(NFLAV,2),JC1(NFLAV,2),JC2(NFLAV,2) SAVE C----------------------------------------------------------------------- IRET=0 AM2= (STS(4,1)+STS(4,2))**2 - (STS(3,1)+STS(3,2))**2 - * (STS(2,1)+STS(2,2))**2 - (STS(1,1)+STS(1,2))**2 AM=-AM2 IC1(1)=NINT(STS(4+1,1)) IC1(2)=NINT(STS(4+2,1)) IC2(1)=NINT(STS(4+1,2)) IC2(2)=NINT(STS(4+2,2)) CALL IDDECO(IC1,JC1) CALL IDDECO(IC2,JC2) DO 2 NF=1,NFLAV JC(NF,1)=JC1(NF,1)+JC2(NF,1) JC(NF,2)=JC1(NF,2)+JC2(NF,2) IF ( NF.GT.4 .AND. (JC(NF,1).NE.0 .OR. JC(NF,2).NE.0) ) THEN CALL UTSTOP('UTAMST: FLAVOUR > 4 ') ENDIF 2 CONTINUE KEU=JC(1,1)-JC(1,2) KED=JC(2,1)-JC(2,2) KES=JC(3,1)-JC(3,2) KEC=JC(4,1)-JC(4,2) AMIN=UTAMNU(KEU,KED,KES,KEC,4) IF ( AM2. LT. AMIN**2 ) THEN IRET=3 RETURN ELSE AM=SQRT(AM2) ENDIF RETURN END C======================================================================= SUBROUTINE UTAXIS(I,J,A1,A2,A3) C--------------------------------------------------------------------- C CALCULATES THE AXIS DEFINED BY THE PTLS I,J IN THE I,J CM SYSTEM C--------------------------------------------------------------------- PARAMETER (MXPTL=70000) COMMON /CPTL/ PPTL(5,MXPTL),TIVPTL(2,MXPTL),XORPTL(4,MXPTL) * ,IBPTL(4,MXPTL),ICLPTL(MXPTL),IDPTL(MXPTL) * ,IFRPTL(2,MXPTL),IORPTL(MXPTL),ISTPTL(MXPTL) * ,JORPTL(MXPTL),NPTL,NQJPTL(MXPTL) COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT SAVE C--------------------------------------------------------------------- A1=0. A2=0. A3=1. PI1=PPTL(1,I) PI2=PPTL(2,I) PI3=PPTL(3,I) PI4=PPTL(4,I) PJ1=PPTL(1,J) PJ2=PPTL(2,J) PJ3=PPTL(3,J) PJ4=PPTL(4,J) P1=PI1+PJ1 P2=PI2+PJ2 P3=PI3+PJ3 P4=PI4+PJ4 P5=SQRT(P4**2-P3**2-P2**2-P1**2) CALL UTLOBO(1,P1,P2,P3,P4,P5,PI1,PI2,PI3,PI4) CALL UTLOBO(1,P1,P2,P3,P4,P5,PJ1,PJ2,PJ3,PJ4) ERR=(PI1+PJ1)**2+(PI2+PJ2)**2+(PI3+PJ3)**2 IF ( ISH.GE.90 .AND. ERR .GT. 1.E-3 ) THEN CALL UTMSG('UTAXIS') WRITE(IFCH,*)'***** ERR=',ERR WRITE(IFCH,*)'PI:',PI1,PI2,PI3,PI4 WRITE(IFCH,*)'PJ:',PJ1,PJ2,PJ3,PJ4 CALL UTMSGF ENDIF A=SQRT( (PJ1-PI1)**2 + (PJ2-PI2)**2 + (PJ3-PI3)**2 ) IF ( A .EQ. 0. ) RETURN A1=(PI1-PJ1)/A A2=(PI2-PJ2)/A A3=(PI3-PJ3)/A RETURN END C======================================================================= SUBROUTINE UTCHM(ARP,ARM,II) C----------------------------------------------------------------------- C CHECKS WHETHER ARP**2=0. AND ARM**2=0. C----------------------------------------------------------------------- COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT DOUBLE PRECISION ARM(4),ARP(4),DIFM,DIFP SAVE C----------------------------------------------------------------------- IF(ISH.LT.90)RETURN DIFP=ARP(4)**2-ARP(1)**2-ARP(2)**2-ARP(3)**2 DIFM=ARM(4)**2-ARM(1)**2-ARM(2)**2-ARM(3)**2 IF ( ABS(DIFP) .GT. 1.D-3*ARP(4)**2 .OR. * ABS(DIFM) .GT. 1.D-3*ARM(4)**2 ) THEN CALL UTMSG('UTCHM ') WRITE(IFCH,*)'***** MASS NON ZERO - ',II WRITE(IFCH,*)'JET-MASS**2`S: ',DIFP,DIFM WRITE(IFCH,*)'ENERGY**2`S: ',ARP(4)**2,ARM(4)**2 WRITE(IFCH,*)(SNGL(ARP(I)),I=1,4) WRITE(IFCH,*)(SNGL(ARM(I)),I=1,4) CALL UTMSGF ENDIF RETURN END C======================================================================= SUBROUTINE UTCLEA(NPTL0) C----------------------------------------------------------------------- C OVERWRITES ISTPTL=2 PARTICLES IN /CPTL/, REDUCES SO NPTL. C----------------------------------------------------------------------- PARAMETER (MXPTL=70000) COMMON /CPTL/ PPTL(5,MXPTL),TIVPTL(2,MXPTL),XORPTL(4,MXPTL) * ,IBPTL(4,MXPTL),ICLPTL(MXPTL),IDPTL(MXPTL) * ,IFRPTL(2,MXPTL),IORPTL(MXPTL),ISTPTL(MXPTL) * ,JORPTL(MXPTL),NPTL,NQJPTL(MXPTL) COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT INTEGER NEWPTL(MXPTL) SAVE C----------------------------------------------------------------------- ISH0=ISH IF ( ISHSUB/100 .EQ. 18 ) ISH=MOD(ISHSUB,100) IF ( ISH .GE. 92 ) THEN WRITE(IFCH,*)('-',L=1,68) WRITE(IFCH,*)'SR UTCLEA. INITIAL.' WRITE(IFCH,*)('-',L=1,68) DO 34 N=1,NPTL WRITE(IFCH,116)IORPTL(N),JORPTL(N),N,IFRPTL(1,N),IFRPTL(2,N) * ,IDPTL(N),SQRT(PPTL(1,N)**2+PPTL(2,N)**2),PPTL(3,N),PPTL(5,N) * ,ISTPTL(N) 34 CONTINUE 116 FORMAT(1X,I6,I6,2X,I6,2X,I4,I4,I12,3(E10.2),I3,I3) ENDIF I=0 1 I=I+1 IF ( I .GT. NPTL ) GOTO 1000 IF ( ISTPTL(I) .EQ. 2 ) GOTO 2 NEWPTL(I)=I GOTO 1 2 I=I-1 J=I 3 I=I+1 4 J=J+1 IF ( J .GT. NPTL ) GOTO 5 NEWPTL(J)=0 IF ( ISTPTL(J) .EQ. 2 ) GOTO 4 NEWPTL(J)=I CALL UTREPL(I,J) GOTO 3 5 NPTL=I-1 IF ( NPTL .EQ. 0 ) THEN NPTL0=0 GOTO 1000 ENDIF 20 N0=NEWPTL(NPTL0) IF ( N0 .GT. 0 ) THEN NPTL0=N0 ELSE NPTL0=NPTL0-1 IF ( NPTL0 .GT. 0 ) GOTO 20 ENDIF DO 11 K=1,NPTL IO=IORPTL(K) IF ( IO .LE. 0 ) THEN IORPTL(K)=IO ELSE IORPTL(K)=NEWPTL(IO) ENDIF JO=JORPTL(K) IF ( JO .LE. 0 ) THEN JORPTL(K)=JO ELSE JORPTL(K)=NEWPTL(JO) ENDIF IF1=IFRPTL(1,K) IF ( IF1 .LE. 0 ) THEN IFRPTL(1,K)=IF1 ELSE IFRPTL(1,K)=NEWPTL(IF1) ENDIF IF2=IFRPTL(2,K) IF ( IF2 .LE. 0 ) THEN IFRPTL(2,K)=IF2 ELSE IFRPTL(2,K)=NEWPTL(IF2) ENDIF 11 CONTINUE DO 19 K=1,NPTL IF ( IFRPTL(1,K).EQ.0 .AND. IFRPTL(2,K).GT.0 ) * IFRPTL(1,K)=IFRPTL(2,K) IF ( IFRPTL(1,K).GT.0 .AND. IFRPTL(2,K).EQ.0 ) * IFRPTL(2,K)=IFRPTL(1,K) 19 CONTINUE 1000 CONTINUE IF ( ISH .GE. 92 ) THEN WRITE(IFCH,*)('-',L=1,68) WRITE(IFCH,*)'SR UTCLEA. FINAL.' WRITE(IFCH,*)('-',L=1,68) DO 35 N=1,NPTL WRITE(IFCH,116)IORPTL(N),JORPTL(N),N,IFRPTL(1,N),IFRPTL(2,N) * ,IDPTL(N),SQRT(PPTL(1,N)**2+PPTL(2,N)**2),PPTL(3,N),PPTL(5,N) * ,ISTPTL(N) 35 CONTINUE WRITE(IFCH,*)('-',L=1,79) ENDIF ISH=ISH0 RETURN END C======================================================================= SUBROUTINE UTHIST(X1,X2,Y1,Y2,N,X,Y,LITY,LILO,TEXT1,TEXT2,TEXT3) C---------------------------------------------------------------------- C WRITES ARRAYS X,Y IN HISTO-FORMAT C---------------------------------------------------------------------- COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP REAL X(N),Y(N) CHARACTER LILO*6,LITY*3,TEXT1*50,TEXT2*50,TEXT3*50 SAVE C---------------------------------------------------------------------- WRITE(IFCH,100)('-',I=1,69) WRITE(IFCH,100)('-',I=1,69) 100 FORMAT(1X,1H',69A1,1H') WRITE(IFCH,101)X1,X2,0.,Y1,Y2,0.,'_____',0 *,'___',LITY,'___','_______',LILO,0.,3,N,0. 101 FORMAT(1X,6F8.2,2X,1H',A5,1H',I11 */4X,1H',A3,1H',3X,1H',A3,A3,1H',3X,1H',A7,A6,1H',F8.2,2I6,F10.4) WRITE(IFCH,100)('-',I=1,69) WRITE(IFCH,102)0.,0.,TEXT1 WRITE(IFCH,102)0.,0.,TEXT2 WRITE(IFCH,102)0.,0.,TEXT3 102 FORMAT(4X,F4.2,2X,F4.2,2X,1H',A50,1H') WRITE(IFCH,100)('-',I=1,69) DO 36 K=1,N WRITE(IFCH,103)K,X(K),0.,Y(K),0.,0. 103 FORMAT(4X,I5,2X,5E12.4) 36 CONTINUE RETURN END C======================================================================= SUBROUTINE UTHSEA C----------------------------------------------------------------------- C CREATES HISTOGRAM OF SEA STRUCTURE FUNCTION C----------------------------------------------------------------------- PARAMETER (NSTRU=2049) COMMON /STRU/ QSEP(NSTRU),QSET(NSTRU),QVAP(NSTRU) * ,QVAT(NSTRU),XCUTAR,XSTRU(NSTRU) * ,IDTG REAL XAR(1000),YAR(1000) SAVE C----------------------------------------------------------------------- DX=1. X1=-1. DO 3 K=1,2 DX=DX*0.001 X1=X1-3. DO 2 N=1,1000 YAR(N)=0. XAR(N)=-DX*0.5+N*DX 2 CONTINUE DO 1 I=1,100000 X=UTINVT(NSTRU,XSTRU,QSEP,RANGEN()*QSEP(NSTRU)) N=1+X/DX IF ( N .LE. 1000 ) YAR(N)=YAR(N)+1. 1 CONTINUE CALL UTHIST(X1,X1+4,0.,5.,1000,XAR,YAR,'POC','LOGLOG' * ,'XAXIS X $ ' * ,'YAXIS COUNTS $ ' * ,'TITLE SEA QUARK STRUCTURE FUNCTION ') 3 CONTINUE RETURN END C======================================================================= FUNCTION UTINVT(N,X,Q,YY) C----------------------------------------------------------------------- C RETURNS X WITH Y=Q(X) C----------------------------------------------------------------------- COMMON /ACCUM/ AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT * ,NRPTL,NRSTR,NTEVT COMMON /CUTINV/ LUTINV COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT REAL Q(N),X(N) SAVE C----------------------------------------------------------------------- IF ( Q(N) .EQ. 0. ) THEN CALL UTSTOP('UTINVT: Q(N)=0. DIMENSIONS TOO BIG ') ENDIF Y = YY IF ( Y .LT. 0. ) THEN IF ( ISH .GE. 90 ) THEN CALL UTMSG('UTINVT') WRITE(IFCH,*)'***** Y=',Y,' < 0' CALL UTMSGF ENDIF Y=0. ELSEIF ( Y .GT. Q(N) ) THEN IF ( ISH .GE. 90 ) THEN CALL UTMSG('UTINVT') WRITE(IFCH,*)'***** Y=',Y,' > ',Q(N) CALL UTMSGF ENDIF Y=Q(N) ENDIF LU=1 LO=N 1 LZ=(LO+LU)/2 IF ( Q(LU).LE.Y .AND. Y.LE.Q(LZ) ) THEN LO=LZ ELSEIF ( Q(LZ).LT.Y .AND. Y.LE.Q(LO) ) THEN LU=LZ ELSE WRITE(IFCH,*)' ' WRITE(IFCH,*)'Q(1),Y,Q(N):',Q(1),Y,Q(N) WRITE(IFCH,*)'LU,LZ,LO:',LU,LZ,LO WRITE(IFCH,*)'Q(LU),Q(LZ),Q(LO):',Q(LU),Q(LZ),Q(LO) CALL UTSTOP('UTINVT: NO INTERVAL FOUND ') ENDIF IF ( LO-LU .GE. 2 ) GOTO 1 IF ( LO .LE. LU ) THEN CALL UTSTOP('UTINVT: LO.LE.LU ') ENDIF UTINVT=X(LU)+(Y-Q(LU))*(X(LO)-X(LU))/(Q(LO)-Q(LU)) LUTINV=LU RETURN END C======================================================================= SUBROUTINE UTKSIX(SIX,KMAX) C----------------------------------------------------------------------- C RETURNS KMAX FOR SIX C----------------------------------------------------------------------- PARAMETER (NSI=6) PARAMETER (NSIX=40) REAL SIX(NSI,NSIX) SAVE C----------------------------------------------------------------------- DO 10 K=0,NSIX-1 KMAX=K SIXSQR=0. DO 20 I=1,NSI SIXSQR=SIXSQR+SIX(I,K+1)**2 20 CONTINUE IF ( SIXSQR .LE. 1.E-5 ) RETURN 10 CONTINUE CALL UTSTOP('UTKSIX: DIMENSION NSIX TOO SMALL ') RETURN END C======================================================================= SUBROUTINE UTKSTR(STR,KMAX) C----------------------------------------------------------------------- C RETURNS KMAX FOR STR C----------------------------------------------------------------------- PARAMETER (NSI=6) PARAMETER (NSIX=40) REAL STR(NSI,NSIX+1) SAVE C----------------------------------------------------------------------- DO 10 K=0,NSIX KMAX=K STRSQR=0. DO 20 I=1,NSI STRSQR=STRSQR+STR(I,K+1)**2 20 CONTINUE IF ( STRSQR .LE. 1.E-5 ) RETURN 10 CONTINUE CALL UTSTOP('UTKSTR: DIMENSION NSIX TOO SMALL ') RETURN END C======================================================================= SUBROUTINE UTLOBO(ISIG,P1,P2,P3,P4,P5,X1,X2,X3,X4) C----------------------------------------------------------------------- C PERFORMS A LORENTZ BOOST C----------------------------------------------------------------------- COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP REAL BETA(4),Z(4) SAVE C----------------------------------------------------------------------- IF ( P5 .LE. 0. ) THEN CALL UTMSG('UTLOBO') WRITE(IFCH,*)'***** MASS <= 0.' WRITE(IFCH,*)'P(5): ',P1,P2,P3,P4,P5 CALL UTMSGF CALL UTSTOP('UTLOBO: MASS <= 0. ') ENDIF Z(1)=X1 Z(2)=X2 Z(3)=X3 Z(4)=X4 BETA(1)=-P1/P5 BETA(2)=-P2/P5 BETA(3)=-P3/P5 BETA(4)= P4/P5 BP=ISIG*(Z(1)*BETA(1)+Z(2)*BETA(2)+Z(3)*BETA(3)) AUXIL= ISIG*Z(4)+ISIG*BP/(BETA(4)+1.) Z(1)=Z(1)+BETA(1)*AUXIL Z(2)=Z(2)+BETA(2)*AUXIL Z(3)=Z(3)+BETA(3)*AUXIL Z(4)=BETA(4)*Z(4)+BP X1=Z(1) X2=Z(2) X3=Z(3) X4=Z(4) RETURN END C======================================================================= SUBROUTINE UTLOB2(ISIG,P1,P2,P3,P4,P5,X1,X2,X3,X4) C----------------------------------------------------------------------- C PERFORMS A LORENTZ BOOST, DOUBLE PREC. C----------------------------------------------------------------------- COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT DOUBLE PRECISION BETA(4),BP,DAUXIL,PP,P1,P2,P3,P4,P5,P5I * ,XX0,X1,X10,X2,X20,X3,X30,X4,X4X,X40,Z(4) SAVE C----------------------------------------------------------------------- IF ( ISH .GE. 90 ) THEN IF ( ISH .GE. 93 ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,101)SNGL(X1),SNGL(X2),SNGL(X3),SNGL(X4) * ,SNGL(X4**2-X3**2-X2**2-X1**2) 101 FORMAT(' UTLOB2:',F9.5,4F13.5) ENDIF PP=P4**2-P3**2-P2**2-P1**2 IF ( ABS(PP-P5**2) .GT. 1.D-3*P4**2 .AND. * ABS(PP-P5**2) .GT. 1.D-3 ) THEN CALL UTMSG('UTLOB2') WRITE(IFCH,*)'***** P**2 .NE. P5**2' WRITE(IFCH,*)'P**2,P5**2: ',PP,P5**2 WRITE(IFCH,*)'P: ',P1,P2,P3,P4,P5 CALL UTMSGF ENDIF X10=X1 X20=X2 X30=X3 X40=X4 ENDIF XX0=X4**2-X3**2-X2**2-X1**2 IF ( P5 .LE. 0.D0 ) THEN CALL UTMSG('UTLOB2') WRITE(IFCH,*)'***** P5 NEGATIVE.' WRITE(IFCH,*)'P(5): ',P1,P2,P3,P4,P5 CALL UTMSGF CALL UTSTOP('UTLOB2: P5 NEGATIVE. ') ENDIF Z(1)=X1 Z(2)=X2 Z(3)=X3 Z(4)=X4 P5I=1.D0/P5 BETA(4)= P5I*P4 BETA(1)=-P5I*P1 BETA(2)=-P5I*P2 BETA(3)=-P5I*P3 BP=ISIG*( BETA(1)*Z(1)+BETA(2)*Z(2)+BETA(3)*Z(3) ) DAUXIL = ISIG*( Z(4) + BP/(BETA(4)+1.D0) ) Z(1)=Z(1)+BETA(1)*DAUXIL Z(2)=Z(2)+BETA(2)*DAUXIL Z(3)=Z(3)+BETA(3)*DAUXIL Z(4)=BETA(4)*Z(4)+BP X1=Z(1) X2=Z(2) X3=Z(3) X4=Z(4) IF ( ISH .GE. 93 ) * WRITE(IFCH,101)SNGL(X1),SNGL(X2),SNGL(X3),SNGL(X4) * ,SNGL(X4**2-X3**2-X2**2-X1**2) X4X=X4 X4=SQRT(XX0+X1**2+X2**2+X3**2) IF ( ISH .GE. 90 ) THEN IF ( ISH .GE. 93 ) THEN WRITE(IFCH,101)SNGL(X1),SNGL(X2),SNGL(X3),SNGL(X4) * ,SNGL(X4**2-X3**2-X2**2-X1**2) WRITE(IFCH,*)' ' ENDIF IF ( ABS(X4-X4X) .GT. 1.D-2*ABS(X4) .AND. * ABS(X4-X4X) .GT. 1.D-2 ) THEN CALL UTMSG('UTLOB2') WRITE(IFCH,*)'***** X**2_INI .NE. X**2_FIN.' WRITE(IFCH,*)'X1 X2 X3 X4 X**2 (INITIAL/FINAL/CORRECTED):' WRITE(IFCH,101)SNGL(X10),SNGL(X20),SNGL(X30),SNGL(X40) * ,SNGL(X40**2-X30**2-X20**2-X10**2) WRITE(IFCH,101)SNGL(X1),SNGL(X2),SNGL(X3),SNGL(X4X) * ,SNGL(X4X**2-X3**2-X2**2-X1**2) WRITE(IFCH,101)SNGL(X1),SNGL(X2),SNGL(X3),SNGL(X4) * ,SNGL(X4**2-X3**2-X2**2-X1**2) CALL UTMSGF ENDIF ENDIF RETURN END C======================================================================= SUBROUTINE UTLOC(AR,N,A,L) C----------------------------------------------------------------------- REAL AR(N) SAVE C----------------------------------------------------------------------- DO 1 I=1,N IF ( A .LT. AR(I) ) THEN L=I-1 RETURN ENDIF 1 CONTINUE L=N RETURN END C======================================================================= SUBROUTINE UTLOW(CONE) C----------------------------------------------------------------------- C CONVERTS LOWER CASE CHARACTERS TO UPPER CASE CHARACTERS C----------------------------------------------------------------------- CHARACTER*1 CONE SAVE C----------------------------------------------------------------------- IF ( CONE .EQ. 'a' ) THEN CONE='A' ELSEIF ( CONE .EQ. 'b' ) THEN CONE='B' ELSEIF ( CONE .EQ. 'c' ) THEN CONE='C' ELSEIF ( CONE .EQ. 'd' ) THEN CONE='D' ELSEIF ( CONE .EQ. 'e' ) THEN CONE='E' ELSEIF ( CONE .EQ. 'f' ) THEN CONE='F' ELSEIF ( CONE .EQ. 'g' ) THEN CONE='G' ELSEIF ( CONE .EQ. 'h' ) THEN CONE='H' ELSEIF ( CONE .EQ. 'i' ) THEN CONE='I' ELSEIF ( CONE .EQ. 'j' ) THEN CONE='J' ELSEIF ( CONE .EQ. 'k' ) THEN CONE='K' ELSEIF ( CONE .EQ. 'l' ) THEN CONE='L' ELSEIF ( CONE .EQ. 'm' ) THEN CONE='M' ELSEIF ( CONE .EQ. 'n' ) THEN CONE='N' ELSEIF ( CONE .EQ. 'o' ) THEN CONE='O' ELSEIF ( CONE .EQ. 'p' ) THEN CONE='P' ELSEIF ( CONE .EQ. 'q' ) THEN CONE='Q' ELSEIF ( CONE .EQ. 'r' ) THEN CONE='R' ELSEIF ( CONE .EQ. 's' ) THEN CONE='S' ELSEIF ( CONE .EQ. 't' ) THEN CONE='T' ELSEIF ( CONE .EQ. 'u' ) THEN CONE='U' ELSEIF ( CONE .EQ. 'v' ) THEN CONE='V' ELSEIF ( CONE .EQ. 'w' ) THEN CONE='W' ELSEIF ( CONE .EQ. 'x' ) THEN CONE='X' ELSEIF ( CONE .EQ. 'y' ) THEN CONE='Y' ELSEIF ( CONE .EQ. 'z' ) THEN CONE='Z' ENDIF RETURN END C======================================================================= SUBROUTINE UTLOW6(CSIX) C----------------------------------------------------------------------- CHARACTER CSIX*6 SAVE C----------------------------------------------------------------------- DO 1 I=1,6 CALL UTLOW(CSIX(I:I)) 1 CONTINUE RETURN END C======================================================================= SUBROUTINE UTMSG(TXT) C----------------------------------------------------------------------- COMMON /ACCUM/ AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT * ,NRPTL,NRSTR,NTEVT DOUBLE PRECISION SEEDC,SEEDI COMMON /CSEED/ SEEDC,SEEDI COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT CHARACTER*6 TXT SAVE C----------------------------------------------------------------------- IMSG=IMSG+1 IF ( ISH.NE.90 .OR. ISHSUB.NE.0 ) WRITE(IFCH,*)' ' WRITE(IFCH,*)('-',J=1,77) WRITE(IFCH,100)TXT,NREVT+1,IPAGE,SEEDC 100 FORMAT(1X,'***** MSG FROM ',A6,'. EPS:',I7,I5,2X,D23.17) RETURN END C======================================================================= SUBROUTINE UTMSGF C----------------------------------------------------------------------- COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT SAVE C----------------------------------------------------------------------- IF ( ISH.EQ.90 .AND. ISHSUB.EQ.0 ) RETURN WRITE(IFCH,*)('-',J=1,77) WRITE(IFCH,*)' ' RETURN END C======================================================================= SUBROUTINE UTOVEL C---------------------------------------------------------------------- C FILLS ARRAY OVEL(1+I,1+J) CONTAINING THE LOGARITHM (LN) OF C I_OVER_J: C OVEL(1+I,1+J)=LOG(I!/J!/(J-I)!) I>=0 J>=0 C---------------------------------------------------------------------- PARAMETER (IOVMAX=100) PARAMETER (JOVMAX=100) COMMON /COVEL/ OVEL(1+IOVMAX,1+JOVMAX) COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT SAVE C---------------------------------------------------------------------- DO 1 I=0,IOVMAX OVEL(1+I,1)=0. OVEL(1+I,1+I)=0. 1 CONTINUE DO 2 J=1,JOVMAX-1 DO 3 I=J+1,IOVMAX OVEL(1+I,1+J)=OVEL(1+I,J)+LOG((I-J+1.)/J) 3 CONTINUE 2 CONTINUE IF ( ISH .GE. 90 ) THEN DO 5 J=1,49 DO 5 I=J+1,50 RELERR=ABS((EXP(OVEL(1+I,1+J)) * -EXP(OVEL(I,J))-EXP(OVEL(I,1+J)))/EXP(OVEL(1+I,1+J))) IF ( RELERR .GT. 1.E-4 ) THEN CALL UTMSG('UTOVEL') WRITE(IFCH,*)'***** OVEL(,) VIOLATES RECURRENCE RELATION' WRITE(IFCH,*)EXP(OVEL(1+I,1+J)) * ,EXP(OVEL(I,J))+EXP(OVEL(I,1+J)) CALL UTMSGF ENDIF 5 CONTINUE IF ( ISH .GE. 95 ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,*)' EXP( OVEL(1+I,1+J) )' WRITE(IFCH,*)' ' DO 6 I=0,15 WRITE(IFCH,*)(EXP( OVEL(1+I,1+J) ),J=0,MIN(4,I)) 6 CONTINUE ENDIF ENDIF RETURN END C======================================================================= SUBROUTINE UTPAGE C----------------------------------------------------------------------- C INCREASES IPAGE BY 1, CHANGES ISH C----------------------------------------------------------------------- COMMON /ACCUM/ AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT * ,NRPTL,NRSTR,NTEVT COMMON /CISHI/ ISHI COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT SAVE C----------------------------------------------------------------------- IPAGE=IPAGE+1 IF ( IPAGI .LE. 0 ) RETURN IF ( IPAGE .EQ. 1 ) ISHI=ISH ISH=0 IF ( IPAGE.GE.IPAGI/10000.AND.IPAGE.LE.MOD(IPAGI,10000) ) ISH=ISHI RETURN END C======================================================================= SUBROUTINE UTPART C---------------------------------------------------------------------- C FILLS ARRAY PARTX(K,N) CONTAINING THE NUMBER C OF PARTITIONS OF N INTO AT MOST K INTEGERS (K>=1 N>=1) . C FILLS ARRAY PART(K,N) CONTAINING THE NUMBER C OF PARTITIONS OF N INTO K INTEGERS (K>=1 N>=1) . C FILLS ARRAY IPART(N,J) CONTAINING THE PARTITIONS OF N. C---------------------------------------------------------------------- PARAMETER (NQUAX=12) PARAMETER (JPAMAX=NQUAX*NQUAX*NQUAX) PARAMETER (KPAMAX=NQUAX) COMMON /CPART/ PART(KPAMAX,NQUAX) COMMON /CPARTA/ PARTA(NQUAX),IPART(NQUAX,JPAMAX) COMMON /CPARTX/ PARTX(KPAMAX,NQUAX) COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT INTEGER ISWAP(JPAMAX) SAVE C---------------------------------------------------------------------- WRITE(IFMT,*)'EXECUTE SR UTPART ...' DO 10 N=1,NQUAX PARTX(1,N)=1. PART(1,N)=1. DO 10 J=1,JPAMAX IPART(N,J)=0 10 CONTINUE DO 1 K=2,KPAMAX DO 2 N=1,NQUAX U=0. DO 3 I=0,N/K IF ( N-I*K .EQ. 0 ) THEN U=U+1. ELSE U=U+PARTX(K-1,N-I*K) ENDIF 3 CONTINUE PARTX(K,N)=U 2 CONTINUE 1 CONTINUE DO 7 N=1,NQUAX PARTA(N)=PART(1,N) DO 7 K=2,KPAMAX PART(K,N)=PARTX(K,N)-PARTX(K-1,N) PARTA(N)=PARTA(N)+PART(K,N) 7 CONTINUE IF ( ISH .GE. 93 ) THEN 121 FORMAT(1X,79A1) WRITE(IFCH,*)' ' WRITE(IFCH,121)('-',IC=1,79) WRITE(IFCH,*)' PARTITIONS OF N INTO AT MOST K INTEGERS' WRITE(IFCH,121)('-',IC=1,79) WRITE(IFCH,101)((K),K=1,10),KPAMAX 101 FORMAT(9X,'K =',10I5,3X,I5) WRITE(IFCH,121)('-',IC=1,79) DO 8 N=1,NQUAX WRITE(IFCH,100)N,(NINT(PARTX(K,N)),K=1,10),NINT(PARTA(N)) 100 FORMAT(3X,'N = ',I2,3X,10I5,3X,I5) 8 CONTINUE ENDIF C N=1 C --- IPART(1,1)=-1 IPART(1,2)=-1 IPART(1,3)=1 C N>1 C --- DO 11 N=2,NQUAX WRITE(IFMT,*)'SR UTPART: N=',N IF ( ISH .GE. 95 ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,*)'N=',N ENDIF IPART(N,1)=-1 IPART(N,2)=-1 IPART(N,3)=N II=3 C N=N1+N2, MULTIPLY PARTITIONS OF N1 AND N2 C ----------------------------------------- DO 12 N1=1,N/2 N2=N-N1 IF ( ISH .GE. 95 ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,*)'N1,N2=',N1,N2 ENDIF K1MAX=-IPART(N1,1) K2MAX=-IPART(N2,1) IF ( K1MAX .LT. 0 .OR. K2MAX .LT. 0 ) THEN CALL UTSTOP('UTPART: KIMAX NEGATIVE ') ENDIF J1=2 DO 13 K1=1,K1MAX L1=-IPART(N1,J1) IF ( L1 .LT. 0 ) THEN CALL UTSTOP('UTPART: L1 NEGATIVE (1) ') ENDIF J2=2 DO 15 K2=1,K2MAX L2=-IPART(N2,J2) IF ( L2 .LT. 0 ) THEN CALL UTSTOP('UTPART: L2 NEGATIVE (1) ') ENDIF IPART(N,1)=IPART(N,1)-1 II=II+1 IF ( II .GT. JPAMAX ) GOTO 1000 IPART(N,II)=-L1-L2 II0=II+1 DO 17 I1=1,L1 II=II+1 IF ( II .GT. JPAMAX ) GOTO 1000 IPART(N,II)=IPART(N1,J1+I1) 17 CONTINUE DO 18 I2=1,L2 II=II+1 IF ( II .GT. JPAMAX ) GOTO 1000 IPART(N,II)=IPART(N2,J2+I2) 18 CONTINUE IF ( ISH .GE. 95 ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,*)'K1,K2=',K1,K2 WRITE(IFCH,103)N,-IPART(N,1),NINT(PARTA(N)) 103 FORMAT(/3X,'N = ',I2,' P(N) = ',I4 * ,' P0(N) = ',I4/) JY=2 DO 29 KY=1,-IPART(N,1) LY=-IPART(N,JY) WRITE(IFCH,102)KY,LY,(IPART(N,I) * ,I=JY+1,JY+MIN(20,LY)) 102 FORMAT(3X,I2,3X,I2,3X,20I3) JY=JY+LY+1 29 CONTINUE ENDIF IPRI=0 DO 19 I=II0,II-1 DO 19 J=I+1,II IF ( IPART(N,I) .LT. IPART(N,J) ) THEN IPRI=1 ISTI=IPART(N,I) IPART(N,I)=IPART(N,J) IPART(N,J)=ISTI ENDIF 19 CONTINUE IF ( IPRI.EQ.1 .AND. ISH.GE.95 ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,*)'SEQUENCE CHANGED' ENDIF JX=2 DO 28 KX=1,-IPART(N,1)-1 LX=-IPART(N,JX) IF ( LX .LT. 0 ) THEN CALL UTSTOP('UTPART: LX NEGATIVE ') ENDIF IF ( LX .EQ. L1+L2 ) THEN DO 22 L=1,LX IF ( IPART(N,JX+L) .NE. IPART(N,II0-1+L) ) GOTO 23 22 CONTINUE IF ( ISH .GE. 95 ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,*)'EXISTS ALREADY' ENDIF IPRI=1 DO 33 I=II0-1,II IPART(N,I)=0 33 CONTINUE II=II0-2 IPART(N,1)=IPART(N,1)+1 GOTO 30 23 CONTINUE ENDIF JX=JX+LX+1 28 CONTINUE 30 CONTINUE IF ( IPRI.EQ.1 .AND. ISH.GE.95 ) THEN WRITE(IFCH,103)N,-IPART(N,1),NINT(PARTA(N)) JY=2 DO 32 KY=1,-IPART(N,1) LY=-IPART(N,JY) WRITE(IFCH,102)KY,LY,(IPART(N,I) * ,I=JY+1,JY+MIN(20,LY)) JY=JY+LY+1 32 CONTINUE ENDIF J2=J2+L2+1 15 CONTINUE J1=J1+L1+1 13 CONTINUE 12 CONTINUE C ORDERING C -------- KM=-IPART(N,1) IF ( KM .LT. 0 ) THEN CALL UTSTOP('UTPART: KM NEGATIVE ') ENDIF J1=2 DO 20 K1=1,KM-1 L1=-IPART(N,J1) IF ( L1 .LT. 0 ) THEN CALL UTSTOP('UTPART: L1 NEGATIVE (2) ') ENDIF J2=2 DO 21 K2=1,KM L2=-IPART(N,J2) IF ( L2 .LT. 0 ) THEN CALL UTSTOP('UTPART: L2 NEGATIVE (2) ') ENDIF IF ( K2 .LE. K1 ) GOTO 21 IF ( L1 .GT. L2 ) THEN DO 24 L=1,L2+1 ISWAP(L)=IPART(N,J2-1+L) 24 CONTINUE DO 25 L=1,J2-J1 I=J2-L IPART(N,I+L2+1)=IPART(N,I) 25 CONTINUE DO 26 L=1,L2+1 IPART(N,J1-1+L)=ISWAP(L) 26 CONTINUE L1=-IPART(N,J1) IF ( L1 .LT. 0 ) THEN CALL UTSTOP('UTPART: L1 NEGATIVE (2) ') ENDIF IF ( ISH .GE. 95 ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,*)'ORDER CHANGED. K1,K2=',K1,K2 WRITE(IFCH,103)N,-IPART(N,1),NINT(PARTA(N)) JY=2 DO 31 KY=1,-IPART(N,1) LY=-IPART(N,JY) WRITE(IFCH,102)KY,LY,(IPART(N,I) * ,I=JY+1,JY+MIN(20,LY)) JY=JY+LY+1 31 CONTINUE ENDIF ENDIF J2=J2+L2+1 21 CONTINUE J1=J1+L1+1 20 CONTINUE IF ( ISH.GE.93 .AND. N.LE.8 ) THEN WRITE(IFCH,113)('-',IC=1,79),N,-IPART(N,1),('-',IC=1,79) 113 FORMAT(/1X,79A1/7X,'N = ',I2,' ---> ',I4, * ' PARTITIONS'/1X,79A1) JY=2 DO 27 KY=1,-IPART(N,1) LY=-IPART(N,JY) WRITE(IFCH,112)KY,(IPART(N,I),I=JY+1,JY+MIN(20,LY)) 112 FORMAT(2X,I2,'. PARTITION:',3X,20I3) JY=JY+LY+1 27 CONTINUE ENDIF IF ( -IPART(N,1) .NE. NINT(PARTA(N)) ) THEN CALL UTSTOP('UTPART: # OF PARTITIONS WRONG ') ENDIF 11 CONTINUE RETURN 1000 WRITE(IFCH,*)' ' WRITE(IFCH,*)('*',J=1,79) WRITE(IFCH,*)'***** N=',N WRITE(IFCH,*)'***** JPAMAX=',JPAMAX WRITE(IFCH,*)('*',J=1,79) CALL UTSTOP('UTPART: DIMENSION JPAMAX TOO SMALL. ') RETURN END C======================================================================= FUNCTION UTPCM(A,B,C) C----------------------------------------------------------------------- C CALCULATES CM MOMENTUM FOR A-->B+C C----------------------------------------------------------------------- SAVE C----------------------------------------------------------------------- VAL=(A**2-B**2-C**2)**2-(2.*B*C)**2 IF ( VAL.LT.0. .AND. VAL.GT.-1.E-4 ) THEN UTPCM=0. RETURN ENDIF UTPCM=SQRT(VAL)/(2.*A) RETURN END C======================================================================= SUBROUTINE UTQUAF(FU,N,X,Q,X0,X1,X2,X3) C----------------------------------------------------------------------- C RETURNS Q(I) = INTEGRAL (X(1)->X(I)) FU(X) DX C ACCELERATED VERSION BY D. HECK, KFK SEPT 20, 1993 C----------------------------------------------------------------------- PARAMETER (M=10) COMMON /ACCUM/ AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT * ,NRPTL,NRSTR,NTEVT COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT REAL Q(N),X(N) SAVE C----------------------------------------------------------------------- QUOT = 1./FLOAT(M-1) IF ( ISH .GE. 90 ) THEN IF ( X1.LT.X0 .OR. X2.LT.X1 .OR. X3.LT.X2 ) THEN CALL UTMSG('UTQUAF') WRITE(IFCH,*)' XI=',X0,X1,X2,X3 CALL UTMSGF ENDIF ENDIF I1 = N/3 I2 = 2*N/3 FAC1 = (X1-X0)/FLOAT(I1-1) DO 11 I=1,I1-1 X(I)=X0+(I-1.)*FAC1 11 CONTINUE FAC2 = (X2-X1)/FLOAT(I2-I1) DO 12 I=I1,I2-1 X(I)=X1+FLOAT(I-I1)*FAC2 12 CONTINUE FAC3 = (X3-X2)/FLOAT(N-I2) DO 13 I=I2,N X(I)=X2+FLOAT(I-I2)*FAC3 13 CONTINUE Q(1) = 0. Z = X(1) AUXIL = FU(Z) DO 2 I=2,N FACT = (X(I) - Z) * QUOT UTQUAD = AUXIL*0.5 DO 3 K=2,M-1 Z=Z+FACT UTQUAD=FU(Z)+UTQUAD 3 CONTINUE Z = X(I) AUXIL = FU(Z) Q(I)=(AUXIL*0.5+UTQUAD)*FACT+Q(I-1) 2 CONTINUE RETURN END C======================================================================= SUBROUTINE UTQZ(N,X,Q1,Q2,X0,X1,X2,X3) C----------------------------------------------------------------------- C RETURNS Q1(I) = INTEGRAL (X(1)->X(I)) FU1(X) DX (SEA QUARK STRUCT) C RETURNS Q2(I) = INTEGRAL (X(1)->X(I)) FU2(X) DX (VAL QUARK STRUCT) C ACCELERATED VERSION BY D. HECK, KFK OCT 20, 1993 C----------------------------------------------------------------------- PARAMETER (M=10) COMMON /ACCUM/ AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT * ,NRPTL,NRSTR,NTEVT COMMON /CIPIO/ IPIO COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT REAL Q1(N),Q2(N),X(N) SAVE C----------------------------------------------------------------------- IF ( ISH .GE. 90 ) THEN IF ( X1.LT.X0 .OR. X2.LT.X1 .OR. X3.LT.X2 ) THEN CALL UTMSG('UTQZ ') WRITE(IFCH,*)' XI=',X0,X1,X2,X3 CALL UTMSGF ENDIF ENDIF I1 = N/3 I2 = 2*N/3 FAC1 = (X1-X0)/FLOAT(I1-1) DO 11 I=1,I1-1 X(I)=(I-1.)*FAC1+X0 11 CONTINUE FAC2 = (X2-X1)/FLOAT(I2-I1) DO 12 I=I1,I2-1 X(I)=FLOAT(I-I1)*FAC2 +X1 12 CONTINUE FAC3 = (X3-X2)/FLOAT(N-I2) DO 13 I=I2,N X(I)=MIN( FLOAT(I-I2)*FAC3 +X2, 0.999999 ) 13 CONTINUE XCUT2 = XCUT**2 QUOT= 1./FLOAT(M-1) Q1(1)=0. Q2(1)=0. Z = X(1) DENOMI= 1./SQRT(Z**2 + XCUT2) IF ( IPIO .EQ. 0 ) THEN AUXIL1 = (1.-Z)**8.05 *DENOMI IF ( Z .NE. 0. ) THEN AUXIL2 = (1.-Z)**3.46 * Z**.419 * * (2.74793064*Z+0.62452969)* DENOMI ELSE AUXIL2 = 0. ENDIF DO 3 I=2,N FACT = (X(I) - Z) * QUOT UTQUA1 = 0.5*AUXIL1 UTQUA2 = 0.5*AUXIL2 DO 2 K=2,M-1 Z=Z+FACT DENOMI = 1./SQRT(Z**2 + XCUT2) UTQUA1 = DENOMI * (1.-Z)**8.05 + UTQUA1 IF ( Z .NE. 0. ) THEN UTQUA2 = (1.-Z)**3.46 * Z**.419 * * (2.74793064*Z+0.62452969) * DENOMI + UTQUA2 ENDIF 2 CONTINUE Z=X(I) DENOMI = 1./SQRT(Z**2 + XCUT2) AUXIL1 = DENOMI * (1.-Z)**8.05 Q1(I) = (AUXIL1*0.5+UTQUA1) * FACT*1.265 + Q1(I-1) IF ( Z .NE. 0. ) THEN AUXIL2=(1.-Z)**3.46 * Z**.419 * (2.74793064*Z+0.62452969) * * DENOMI Q2(I) = (AUXIL2*0.5+UTQUA2) * FACT + Q2(I-1) ELSE AUXIL2 = 0. Q2(I) = FACT* UTQUA2 + Q2(I-1) ENDIF 3 CONTINUE ELSE CUTLOG= LOG(XCUT) A0 = -5. + 6.6666667*XCUT2 - 0.53333333*XCUT2**2 BA0= A0*XCUT A1 = 5. - 1.875*XCUT2 QB = 1. - A1*XCUT2 A2 = -3.3333333 +0.26666667*XCUT2 A3 = 1.25 A4 = -0.2 AUXIL1 = (1.-Z)**5.0 * DENOMI IF ( Z .NE. 0. ) THEN AUXIL2 = (1.-Z)**0.7 * Z**0.4 * DENOMI ELSE AUXIL2 = 0. ENDIF DO 5 I=2,N FACT = (X(I) - Z) * QUOT UTQUA1 = 0.5*AUXIL1 UTQUA2 = 0.5*AUXIL2 DO 4 K=2,M-1 Z=Z+FACT DENOMI = 1./SQRT(Z**2 + XCUT2) UTQUA1 = DENOMI * (1.-Z)**5.0 + UTQUA1 IF ( Z .NE. 0. ) THEN UTQUA2 = DENOMI * (1.-Z)**0.7 * Z**0.4 + UTQUA2 ENDIF 4 CONTINUE Z = X(I) ROOT = SQRT(Z**2 + XCUT2) DENOMI= 1./ROOT CC AUXIL1=DENOMI * (1.-Z)**5.0 CC Q1(I) = (AUXIL1*0.5+UTQUA1) * FACT*0.9 + Q1(I-1) Q1(I) = ( QB * ( LOG(Z+ROOT) - CUTLOG ) - BA0 * + ROOT * (A0+Z*(A1+Z*(A2+Z*(A3+Z*A4)))) ) *0.9 IF ( Z .NE. 0. ) THEN AUXIL2 = DENOMI * (1.-Z)**0.7 * Z**0.4 Q2(I) = (AUXIL2*0.5+UTQUA2) * FACT*0.1730725 + Q2(I-1) ELSE AUXIL2 = 0. Q2(I) = FACT*0.1730725 * UTQUA2 + Q2(I-1) ENDIF 5 CONTINUE ENDIF RETURN END C======================================================================= SUBROUTINE UTREMB(PROJ,TARG,II) C----------------------------------------------------------------------- C REMEMBERS NEVT,NSTR,NPTL,PROJ,TARG C----------------------------------------------------------------------- PARAMETER (MXPTL=70000) PARAMETER (MXSTR=3000) PARAMETER (NSI=6) PARAMETER (NSIX=40) PARAMETER (NHA=NSIX+2) COMMON /CEVT/ BIMEVT,COLEVT,EGYEVT,PHIEVT,PMXEVT * ,KOLEVT,NEVT,NPJEVT,NTGEVT COMMON /CPTL/ PPTL(5,MXPTL),TIVPTL(2,MXPTL),XORPTL(4,MXPTL) * ,IBPTL(4,MXPTL),ICLPTL(MXPTL),IDPTL(MXPTL) * ,IFRPTL(2,MXPTL),IORPTL(MXPTL),ISTPTL(MXPTL) * ,JORPTL(MXPTL),NPTL,NQJPTL(MXPTL) COMMON /CREMB/ PROJRE(2,NSI,NHA),TARGRE(2,NSI,NHA) * ,NEVTRE(2),NPTLRE(2),NSTRRE(2) COMMON /CSTR/ PSTR(5,MXSTR),ROTSTR(3,MXSTR),XORSTR(4,MXSTR) * ,ICSTR(4,MXSTR),IORSTR(MXSTR),IRLSTR(MXSTR),NSTR REAL PROJ(NSI,NHA),TARG(NSI,NHA) SAVE C----------------------------------------------------------------------- NEVTRE(II)=NEVT NSTRRE(II)=NSTR NPTLRE(II)=NPTL DO 56 M=1,NHA SM=0. DO 57 N=1,NSI PROJRE(II,N,M)=PROJ(N,M) SM=SM+PROJ(N,M)**2 57 CONTINUE IF ( M.GE.3 .AND. SM.LT.1.E-5 ) GOTO 58 56 CONTINUE 58 CONTINUE DO 53 M=1,NHA SM=0. DO 54 N=1,NSI TARGRE(II,N,M)=TARG(N,M) SM=SM+TARG(N,M)**2 54 CONTINUE IF ( M.GE.3 .AND. SM.LT.1.E-5 ) GOTO 55 53 CONTINUE 55 CONTINUE RETURN END C======================================================================= SUBROUTINE UTREPL(I,J) C----------------------------------------------------------------------- C I IS REPLACED BY J IN /CPTL/ C----------------------------------------------------------------------- PARAMETER (MXPTL=70000) COMMON /CPTL/ PPTL(5,MXPTL),TIVPTL(2,MXPTL),XORPTL(4,MXPTL) * ,IBPTL(4,MXPTL),ICLPTL(MXPTL),IDPTL(MXPTL) * ,IFRPTL(2,MXPTL),IORPTL(MXPTL),ISTPTL(MXPTL) * ,JORPTL(MXPTL),NPTL,NQJPTL(MXPTL) COMMON /C2PTL/ AMIPTL(MXPTL),RADPTL(MXPTL),IAAPTL(MXPTL) SAVE C----------------------------------------------------------------------- AMIPTL(I) =AMIPTL(J) IAAPTL(I) =IAAPTL(J) IBPTL(1,I) =IBPTL(1,J) IBPTL(2,I) =IBPTL(2,J) IBPTL(3,I) =IBPTL(3,J) IBPTL(4,I) =IBPTL(4,J) ICLPTL(I) =ICLPTL(J) IDPTL(I) =IDPTL(J) IFRPTL(1,I)=IFRPTL(1,J) IFRPTL(2,I)=IFRPTL(2,J) IORPTL(I) =IORPTL(J) ISTPTL(I) =ISTPTL(J) JORPTL(I) =JORPTL(J) NQJPTL(I) =NQJPTL(J) DO 1 K=1,5 PPTL(K,I)=PPTL(K,J) 1 CONTINUE RADPTL(I) =RADPTL(J) TIVPTL(1,I)=TIVPTL(1,J) TIVPTL(2,I)=TIVPTL(2,J) XORPTL(1,I)=XORPTL(1,J) XORPTL(2,I)=XORPTL(2,J) XORPTL(3,I)=XORPTL(3,J) XORPTL(4,I)=XORPTL(4,J) RETURN END C======================================================================= SUBROUTINE UTRESM(ICP1,ICP2,ICM1,ICM2,AMP,IDPR,IADJ,IRETEN) C----------------------------------------------------------------------- PARAMETER (NFLAV=6) INTEGER ICM(2),ICP(2),JCM(NFLAV,2),JCP(NFLAV,2) SAVE C----------------------------------------------------------------------- ICM(1)=ICM1 ICM(2)=ICM2 ICP(1)=ICP1 ICP(2)=ICP2 CALL IDDECO(ICM,JCM) CALL IDDECO(ICP,JCP) DO 37 NF=1,NFLAV JCP(NF,1)=JCP(NF,1)+JCM(NF,1) JCP(NF,2)=JCP(NF,2)+JCM(NF,2) 37 CONTINUE CALL IDENCO(JCP,ICP,IRETEN) IDP=IDTRA(ICP,0,0,3) CALL IDRES(IDP,AMP,IDPR,IADJ) RETURN END C======================================================================= SUBROUTINE UTREST(PROJ,TARG,II) C----------------------------------------------------------------------- PARAMETER (NSI=6) PARAMETER (NSIX=40) PARAMETER (NHA=NSIX+2) COMMON /CEVT/ BIMEVT,COLEVT,EGYEVT,PHIEVT,PMXEVT * ,KOLEVT,NEVT,NPJEVT,NTGEVT COMMON /CREMB/ PROJRE(2,NSI,NHA),TARGRE(2,NSI,NHA) * ,NEVTRE(2),NPTLRE(2),NSTRRE(2) REAL PROJ(NSI,NHA),TARG(NSI,NHA) SAVE C----------------------------------------------------------------------- NEVT=NEVTRE(II) NSTR=NSTRRE(II) NPTL=NPTLRE(II) DO 66 M=1,NHA SM=0. DO 67 N=1,NSI PROJ(N,M)=PROJRE(II,N,M) SM=SM+PROJRE(II,N,M)**2 67 CONTINUE IF ( M.GE.3 .AND. SM.LT.1.E-5 ) GOTO 68 66 CONTINUE 68 CONTINUE DO 63 M=1,NHA SM=0. DO 64 N=1,NSI TARG(N,M)=TARGRE(II,N,M) SM=SM+TARGRE(II,N,M)**2 64 CONTINUE IF ( M.GE.3 .AND. SM.LT.1.E-5 ) GOTO 65 63 CONTINUE 65 CONTINUE RETURN END C======================================================================= SUBROUTINE UTROTA(ISIG,AX,AY,AZ,X,Y,Z) C----------------------------------------------------------------------- C PERFORMS A ROTATION C----------------------------------------------------------------------- SAVE C----------------------------------------------------------------------- IF ( AZ .GE. 0. ) THEN RX=AX RY=AY RZ=AZ ELSE RX=-AX RY=-AY RZ=-AZ ENDIF ALP=SIGN( ABS(UTACOS(RZ/SQRT(RZ**2+RY**2))), RY ) BET=SIGN( ABS(UTACOS(SQRT(RZ**2+RY**2)/SQRT(RZ**2+RY**2+RX**2))) * , RX ) COSA=COS(ALP) SINA=SIN(ALP) COSB=COS(BET) SINB=SIN(BET) IF ( ISIG .GT. 0 ) THEN XS=X*COSB-Y*SINA*SINB-Z*COSA*SINB YS= Y*COSA -Z*SINA ZS=X*SINB+Y*SINA*COSB+Z*COSA*COSB ELSEIF ( ISIG .LT. 0 ) THEN XS= X*COSB +Z*SINB YS=-X*SINB*SINA+Y*COSA+Z*COSB*SINA ZS=-X*SINB*COSA-Y*SINA+Z*COSB*COSA ENDIF X=XS Y=YS Z=ZS RETURN END C======================================================================= SUBROUTINE UTROT2(ISIG,AX,AY,AZ,X,Y,Z) C----------------------------------------------------------------------- C PERFORMS A ROTATION, DOUBLE PREC. C----------------------------------------------------------------------- COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU DOUBLE PRECISION ALP,AUXIL1,AUXIL2,AX,AY,AZ,BET,COSA,COSB * ,RX,RY,RZ,SINA,SINB,X,XS,Y,YS,Z,ZS SAVE C----------------------------------------------------------------------- IF ( AX**2.EQ.0.D0 .AND. AY**2.EQ.0.D0 .AND. AZ**2.EQ.0.D0 ) THEN WRITE(IFCH,*)' ' WRITE(IFCH,*)'AX**2,AY**2,AZ**2:',AX**2,AY**2,AZ**2 WRITE(IFCH,*)'AX,AY,AZ:',AX,AY,AZ CALL UTSTOP('UTROT2: ZERO VECTOR. ') ENDIF IF ( AZ .GE. 0.D0 ) THEN RX=AX RY=AY RZ=AZ ELSE RX=-AX RY=-AY RZ=-AZ ENDIF AUXIL1 = RZ**2+RY**2 IF ( AUXIL1 .NE. 0.D0 ) THEN AUXIL2 = SQRT(AUXIL1) ALP=SIGN( ABS(ACOS(RZ/AUXIL2)), RY ) BET=SIGN( ABS(ACOS( AUXIL2/SQRT(AUXIL1+RX**2) )), RX ) COSA=COS(ALP) SINA=SIN(ALP) COSB=COS(BET) SINB=SIN(BET) ELSE COSA=0.D0 COSB=0.D0 SINA=1.D0 SINB=1.D0 ENDIF IF ( ISIG .GT. 0 ) THEN XS=X*COSB-Y*SINA*SINB-Z*COSA*SINB YS= Y*COSA -Z*SINA ZS=X*SINB+Y*SINA*COSB+Z*COSA*COSB ELSEIF ( ISIG .LT. 0 ) THEN XS= X*COSB +Z*SINB YS=-X*SINB*SINA+Y*COSA+Z*COSB*SINA ZS=-X*SINB*COSA-Y*SINA+Z*COSB*COSA ENDIF X=XS Y=YS Z=ZS RETURN END C======================================================================= SUBROUTINE UTSTOP(TEXT) C----------------------------------------------------------------------- C RETURNS ERROR MESSAGE AND STOPS EXECUTION C----------------------------------------------------------------------- COMMON /ACCUM/ AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT * ,NRPTL,NRSTR,NTEVT DOUBLE PRECISION SEEDC,SEEDI COMMON /CSEED/ SEEDC,SEEDI COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /NEVNT/ NEVNT COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT CHARACTER STAR*1,TEXT*40 DATA STAR/'*'/ SAVE C----------------------------------------------------------------------- DO 1 I=1,2 IF ( I .EQ. 1 ) THEN IFI=IFCH ELSE IFI=IFMT ENDIF WRITE(IFI,*)' ' WRITE(IFI,*)(STAR,J=1,77) WRITE(IFI,*)'***** STOP IN ',TEXT CDH WRITE(IFI,*)'***** CURRENT EVENT NUMBER: ',NREVT+1 WRITE(IFI,*)'***** CURRENT EVENT NUMBER: ',NEVNT WRITE(IFI,*)'***** CURRENT PAGE NUMBER: ',IPAGE WRITE(IFI,*)'***** INITIAL SEED FOR CURRENT EVENT:',SEEDI WRITE(IFI,*)'***** RANDOM CALLS FOR CURRENT EVENT:',SEEDC WRITE(IFI,*)(STAR,J=1,77) WRITE(IFI,*)' ' 1 CONTINUE STOP END C======================================================================= SUBROUTINE UTTAIN(I,X,Y,Z,T,N,IOPT) C----------------------------------------------------------------------- C RETURNS INTERSECTION OF PTL-I-TRAJECTORY WITH TAUS-LINE. C N=0 IF OK, N=1 IF PTL LIVES LATER, N=2 IF EARLIER, C N=9 IF TIV1>TIV2, N=3,4,5 ELSE. C IOPT=0: FORMATION TIME CONSIDERED, IOPT=1 IF NOT C----------------------------------------------------------------------- PARAMETER (MXPTL=70000) COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /CPTL/ PPTL(5,MXPTL),TIVPTL(2,MXPTL),XORPTL(4,MXPTL) * ,IBPTL(4,MXPTL),ICLPTL(MXPTL),IDPTL(MXPTL) * ,IFRPTL(2,MXPTL),IORPTL(MXPTL),ISTPTL(MXPTL) * ,JORPTL(MXPTL),NPTL,NQJPTL(MXPTL) DOUBLE PRECISION DETAP,DETAT,TPRO,TTAR,TTAUS,TTP,TTT * ,ZPRO,ZTAR,ZZP,ZZT COMMON /CTTAUS/ DETAP,DETAT,TPRO,TTAR,TTAUS,TTP,TTT * ,ZPRO,ZTAR,ZZP,ZZT COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT DOUBLE PRECISION DD,DERR,TI1,TI2,TT,VV,VVP,VVT,XO3,XO4,ZZ,ZZA DATA DERR/1.D-2/ SAVE C----------------------------------------------------------------------- XO4=XORPTL(4,I) IF ( IOPT .EQ. 0 ) THEN TI1=TIVPTL(1,I) ELSEIF ( IOPT .EQ. 1 ) THEN TI1=XO4 ENDIF TI2=TIVPTL(2,I) IF ( TI1 .GT. TI2 ) GOTO 1009 PPT4I = 1./PPTL(4,I) VV=PPTL(3,I)*PPT4I XO3=XORPTL(3,I) ZZ=XO3+(TI2-XO4)*VV IF ( TTAUS .LE. 0.D0 ) THEN TZ=TTAUS ELSE IF ( ZZ .LE. ZZT ) THEN TZ=TTT+(ZZ-ZZT)*ZZT/TTT ELSEIF ( ZZ .GE. ZZP ) THEN TZ=TTP+(ZZ-ZZP)*ZZP/TTP ELSE IF ( TTAUS .GE. AINFIN ) THEN TZ=TTAUS IF ( ISH .GE. 90 ) THEN CALL UTMSG('UTTAIN') WRITE(IFCH,*)'***** LARGE TTAUS; SET TZ=TTAUS' WRITE(IFCH,*)'TTAUS=',TTAUS,'ZZ=',ZZ CALL UTMSGF ENDIF ELSE C*DH TZ=SQRT(TTAUS**2+ZZ**2) IF ( TI2 .LT. 0.D0 ) GOTO 1002 IF ( TTAUS**2+ZZ**2 .GE. TI2**2 ) GOTO 1002 GOTO 1006 ENDIF ENDIF ENDIF IF ( TZ .GE. TI2 ) GOTO 1002 1006 ZZ=XO3+(TI1-XO4)*VV IF ( TTAUS .GT. 0.D0 ) THEN IF ( ZZ .LE. ZZT ) THEN TZ=TTT+(ZZ-ZZT)*ZZT/TTT ELSEIF ( ZZ .GE. ZZP ) THEN TZ=TTP+(ZZ-ZZP)*ZZP/TTP ELSE IF ( TTAUS .GE. AINFIN ) THEN TZ=TTAUS IF ( ISH .GE. 90 ) THEN CALL UTMSG('UTTAIN') WRITE(IFCH,*)'***** LARGE TTAUS; SET TZ=TTAUS' WRITE(IFCH,*)'TTAUS=',TTAUS,'ZZ=',ZZ CALL UTMSGF ENDIF ELSE C*DH TZ=SQRT(TTAUS**2+ZZ**2) IF ( TI1 .LT. 0.D0 ) GOTO 1007 IF ( TTAUS**2+ZZ**2 .LE. TI1**2 ) GOTO 1001 GOTO 1007 ENDIF ENDIF ENDIF IF ( TZ .LE. TI1 ) GOTO 1001 1007 IF ( TTAUS .LE. 0.D0 ) THEN TT=TTAUS ZZ=XO3+(TT-XO4)*VV IF ( TT.LT.TI1 .OR. TT.GE.TI2 ) GOTO 1031 ELSE ZZA=XO3-XO4*VV VVT=ZZT/TTT TT=(TTT+(ZZA-ZZT)*VVT)/(1.D0-VV*VVT) ZZ=XO3+(TT-XO4)*VV IF ( ZZ .LE. ZZT ) THEN IF ( TT.LT.TI1 .OR. TT.GE.TI2 ) GOTO 1032 GOTO 1000 ENDIF VVP=ZZP/TTP TT=(TTP+(ZZA-ZZP)*VVP)/(1.D0-VV*VVP) ZZ=XO3+(TT-XO4)*VV IF ( ZZ .GE. ZZP ) THEN IF ( TT.LT.TI1 .OR. TT.GE.TI2 ) GOTO 1033 GOTO 1000 ENDIF DD=1.D0-VV**2 IF ( DD .EQ. 0.D0 ) THEN TT=-VV*(TTAUS**2+ZZA**2)*0.5D0/ZZA ELSE TT=(ZZA*VV+SQRT(ZZA**2+TTAUS**2*DD))/DD ENDIF ZZ=XO3+(TT-XO4)*VV IF ( TT.LT.TI1 .OR. TT.GE.TI2 ) GOTO 1034 IF ( TT .LT. 0.D0 ) GOTO 1035 IF ( ZZ.LE.ZZT .OR. ZZ.GE.ZZP ) GOTO 1004 IF ( ABS(TTAUS**2-(TT+ZZ)*(TT-ZZ)) * .GT. DERR*TTAUS**2 ) GOTO 1005 ENDIF 1000 N=0 1011 T=TT Z=ZZ X=XORPTL(1,I)+(T-XO4)*PPTL(1,I)*PPT4I Y=XORPTL(2,I)+(T-XO4)*PPTL(2,I)*PPT4I RETURN 1001 N=1 RETURN 1002 N=2 RETURN 1031 N=31 GOTO 1003 1032 N=32 GOTO 1003 1033 N=33 GOTO 1003 1034 N=34 1003 IF ( ABS(TT-TI1) .LE. DERR*ABS(TT) ) GOTO 1000 IF ( ABS(TT-TI2) .LE. DERR*ABS(TT) ) GOTO 1000 IF ( ISH .GE. 90 ) THEN CALL UTMSG('UTTAIN') WRITE(IFCH,*)'***** TI1 < TT < TI2 NOT FULFILLED - ',N WRITE(IFCH,*)SNGL(TI1),SNGL(TT),SNGL(TI2) CALL UTMSGF ENDIF GOTO 1011 1035 CONTINUE IF ( ISH .GE. 90 ) THEN CALL UTMSG('UTTAIN') WRITE(IFCH,*)'***** TT < 0 ( ',TT,' )' WRITE(IFCH,*)'VV,DD:',VV,DD WRITE(IFCH,*)'ZZA,TTAUS:',ZZA,TTAUS CALL UTMSGF ENDIF GOTO 1011 1004 N=4 IF ( ABS(ZZ-ZZT) .LE. DERR*ABS(ZZ) ) GOTO 1000 IF ( ABS(ZZ-ZZP) .LE. DERR*ABS(ZZ) ) GOTO 1000 IF ( ISH .GE. 90 ) THEN CALL UTMSG('UTTAIN') WRITE(IFCH,*)'***** ZZT < ZZ < ZZP NOT FULFILLED' WRITE(IFCH,*)SNGL(ZZT),SNGL(ZZ),SNGL(ZZP) CALL UTMSGF ENDIF GOTO 1011 1005 N=5 IF ( ABS(TTAUS**2-(TT+ZZ)*(TT-ZZ)) .LE. DERR ) GOTO 1000 IF ( ISH .GE. 90 ) THEN CALL UTMSG('UTTAIN') WRITE(IFCH,*)'***** TTAUS**2 .NE. (TT+ZZ)*(TT-ZZ)' WRITE(IFCH,*)SNGL(TTAUS**2),SNGL((TT+ZZ)*(TT-ZZ)) CALL UTMSGF ENDIF GOTO 1011 1009 N=9 RETURN END C======================================================================= SUBROUTINE UTTAIX(I,TAU,ZOR,TOR,Z,T) C----------------------------------------------------------------------- C RETURNS INTERSECTION Z,T OF PTL-I-TRAJECTORY WITH HYPERBOLA H. C H: (T-TOR)**2-(Z-ZOR)**2=TAU**2 . C ZOR, TOR DOUBLE PRECISION. C----------------------------------------------------------------------- PARAMETER (MXPTL=70000) COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT COMMON /CPTL/ PPTL(5,MXPTL),TIVPTL(2,MXPTL),XORPTL(4,MXPTL) * ,IBPTL(4,MXPTL),ICLPTL(MXPTL),IDPTL(MXPTL) * ,IFRPTL(2,MXPTL),IORPTL(MXPTL),ISTPTL(MXPTL) * ,JORPTL(MXPTL),NPTL,NQJPTL(MXPTL) DOUBLE PRECISION CC,DD,DERR,TOR,TORS,TT,TTAU,VV,ZOR,ZORS,ZZ SAVE C----------------------------------------------------------------------- DERR=1.D-3 TTAU=TAU ZORS=XORPTL(3,I)-ZOR TORS=XORPTL(4,I)-TOR VV=PPTL(3,I)/PPTL(4,I) IF ( ABS(VV) .GT. 1.D0 ) THEN IF ( ISH.GE.90 .AND. ABS(VV).GT.1.001D0 ) THEN CALL UTMSG('UTTAIX') WRITE(IFCH,*)'***** !V! > 1' WRITE(IFCH,*)'V: ',VV WRITE(IFCH,*)'P,E: ',PPTL(3,I),PPTL(4,I) CALL UTMSGF ENDIF VV=SIGN(1.D0,VV) ENDIF CC=ZORS-TORS*VV DD=1.D0-VV**2 IF ( DD.EQ.0.D0 .AND. CC.EQ.0.D0 ) THEN IF ( TAU .EQ. 0. ) THEN TT=0. ELSE TT=AINFIN ENDIF ZZ=TT GOTO 1000 ELSEIF ( DD .EQ. 0.D0 ) THEN TT=-(TTAU**2+CC**2)*0.5D0/(CC*VV) ELSEIF ( DD .LT. 1.D-8 ) THEN TT=-(TTAU**2+CC**2)*0.5D0/(CC*VV) IF(ISH.GE.90)THEN CALL UTMSG('UTTAIX') WRITE(IFCH,*)'***** DD = ',DD,' TREATED AS ZERO' CALL UTMSGF ENDIF ELSE TT=(CC*VV+SQRT(CC**2+TTAU**2*DD))/DD ENDIF ZZ=CC+TT*VV IF ( ISH .GE. 90 ) THEN IF ( ABS(TTAU**2-(TT+ZZ)*(TT-ZZ)) .GT. DERR*TTAU**2 .AND. * ABS(TTAU**2-(TT+ZZ)*(TT-ZZ)) .GT. DERR .AND. * TORS**2-ZORS**2 .LT. 1.D6 ) THEN CALL UTMSG('UTTAIX') WRITE(IFCH,*)'***** TTAU**2 .NE. (TT+ZZ)*(TT-ZZ)' WRITE(IFCH,*)SNGL(TTAU**2),SNGL((TT+ZZ)*(TT-ZZ)) WRITE(IFCH,*)'TAU,T,Z:' WRITE(IFCH,*)TAU,TT,ZZ WRITE(IFCH,*)'#,ID(PTL):',I,IDPTL(I) WRITE(IFCH,*)'ZOR,TOR(STR):',ZOR,TOR WRITE(IFCH,*)'ZORS,TORS,P,E(PTL):' WRITE(IFCH,*)SNGL(ZORS),SNGL(TORS),PPTL(3,I),PPTL(4,I) CALL UTMSGF ENDIF ENDIF 1000 Z=ZZ+ZOR T=TT+TOR RETURN END C======================================================================= SUBROUTINE UTTAUS(Z,SZ) C----------------------------------------------------------------------- C RETURNS INV Z-COORD SZ CORRESPONDING TO TTAUS AND Z. C----------------------------------------------------------------------- COMMON /CNSTA/ AINFIN,PI,PIOM,PROM DOUBLE PRECISION DETAP,DETAT,TPRO,TTAR,TTAUS,TTP,TTT * ,ZPRO,ZTAR,ZZP,ZZT COMMON /CTTAUS/ DETAP,DETAT,TPRO,TTAR,TTAUS,TTP,TTT * ,ZPRO,ZTAR,ZZP,ZZT COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT DOUBLE PRECISION ZZ SAVE C----------------------------------------------------------------------- IF ( TTAUS .LE. 0.D0 ) THEN SZ=Z RETURN ENDIF ZZ=Z IF ( ZZ .LE. ZZT ) THEN SZ=TTAUS*DETAT+(ZZ-ZZT)/TTAR ELSEIF ( ZZ .GE. ZZP ) THEN SZ=TTAUS*DETAP+(ZZ-ZZP)/TPRO ELSE IF ( SNGL(TTAUS) .GE. AINFIN ) THEN SZ=0. IF ( ISH .GE. 90 ) THEN CALL UTMSG('UTTAUS') WRITE(IFCH,*)'***** LARGE TTAUS; SET TZ=TTAUS, SZ=0' WRITE(IFCH,*)'TTAUS=',TTAUS,'ZZ=',ZZ CALL UTMSGF ENDIF ELSE TZ=SQRT(TTAUS**2+ZZ**2) SZ=TTAUS*0.5D0*LOG((TZ+ZZ)/(TZ-ZZ)) ENDIF ENDIF RETURN END C======================================================================= SUBROUTINE UTTAUT(Z,TZ) C----------------------------------------------------------------------- C RETURNS TZ = TIME CORRESPONDING TO TTAUS AND Z C----------------------------------------------------------------------- COMMON /CNSTA/ AINFIN,PI,PIOM,PROM DOUBLE PRECISION DETAP,DETAT,TPRO,TTAR,TTAUS,TTP,TTT * ,ZPRO,ZTAR,ZZP,ZZT COMMON /CTTAUS/ DETAP,DETAT,TPRO,TTAR,TTAUS,TTP,TTT * ,ZPRO,ZTAR,ZZP,ZZT COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT DOUBLE PRECISION ZZ SAVE C----------------------------------------------------------------------- ZZ=Z IF ( ZZ .LE. ZZT ) THEN TZ=TTT+(ZZ-ZZT)*ZZT/TTT ELSEIF ( ZZ .GE. ZZP ) THEN TZ=TTP+(ZZ-ZZP)*ZZP/TTP ELSE IF ( TTAUS .GE. AINFIN ) THEN TZ=TTAUS IF ( ISH .GE. 90 ) THEN CALL UTMSG('UTTAUT') WRITE(IFCH,*)'***** LARGE TTAUS; SET TZ=TTAUS' WRITE(IFCH,*)'TTAUS=',TTAUS,'ZZ=',ZZ CALL UTMSGF ENDIF ELSE TZ=SQRT(TTAUS**2+ZZ**2) ENDIF ENDIF RETURN END C======================================================================= C C SUBROUTINE UTTIMA(TEXT) C C----------------------------------------------------------------------- C RETURNS TIME. C----------------------------------------------------------------------- C COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP C COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY C * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA C * ,YHAHA,YMXIMI,YPJTL C * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM C * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH C * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI C * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG C * ,MODSHO,NDECAX,NDECAY,NEVENT C CHARACTER*15 TEXT C----------------------------------------------------------------------- C TIMAA=0. C TIMA=0. C-C CALL TIMAX(TIMAA) C-C CALL TIMAD(TIMA) C IF ( TEXT .EQ. ' ' ) RETURN C IF ( ISH .GE. 91 ) WRITE(IFCH,*)' ' C WRITE(IFCH,100)TEXT,TIMA/5.,TIMAA/5. C IF ( ISH .GE. 91 ) WRITE(IFCH,*)' ' C100 FORMAT(1X,A15,5X,F12.5,5X,F12.5) C RETURN C END C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= C C ENTRY UTTIMT C C----------------------------------------------------------------------- C-C CALL TIMAST(1E10) C RETURN C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= C C ENTRY UTTIMX(TIMAAX) C C----------------------------------------------------------------------- C TIMAAX=0. C-C CALL TIMAX(TIMAAX) C RETURN C END C======================================================================= SUBROUTINE UTTUCL C---------------------------------------------------------------------- C FILLS ARRAY TUCL(1+K,1+N) CONTAINING THE LOGARITHM (LN) OF C THE NUMBER OF K-TUPELS N_I WITH SUM_I N_I = N: C TUCL(1+K,1+N)=LOG((N+1)*(N+2)...*(N+K-1)/(K-1)!) K>=0 N>=0 . C DOUBLE PRECISION TUCL. C---------------------------------------------------------------------- PARAMETER (KTUMAX=100) PARAMETER (NTUMAX=100) DOUBLE PRECISION TUCL COMMON /CTUCL/ TUCL(1+KTUMAX,1+NTUMAX) COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT DOUBLE PRECISION DD,RELERR SAVE C---------------------------------------------------------------------- TUCL(1,1)=-100.D0 TUCL(2,1)=0.D0 DO 7 K=2,KTUMAX TUCL(1+K,1)=0.D0 7 CONTINUE DO 2 N=2,NTUMAX+1 TUCL(1,N)=-100.D0 TUCL(2,N)=0.D0 DO 1 K=2,KTUMAX DD=(N+K-2.D0)/(K-1.D0) TUCL(1+K,N)=TUCL(K,N)+LOG(DD) 1 CONTINUE 2 CONTINUE IF ( ISH .GE. 93 ) THEN DO 5 K=2,50 DO 4 N=1,50 RELERR=ABS((EXP(TUCL(1+K,1+N))-EXP(TUCL(1+K,N)) * -EXP(TUCL(K,1+N)))/EXP(TUCL(1+K,1+N))) IF ( RELERR .GT. 1.D-4 ) THEN CALL UTMSG('UTTUCL') WRITE(IFCH,*)'***** TUCL(,) VIOLATES RECURRENCE RELATION' WRITE(IFCH,*)SNGL(EXP(TUCL(1+K,1+N))) * ,SNGL(EXP(TUCL(1+K,N))+EXP(TUCL(K,1+N))) CALL UTMSGF ENDIF 4 CONTINUE 5 CONTINUE WRITE(IFCH,*)' ' WRITE(IFCH,121)('-',IC=1,79) 121 FORMAT(1X,79A1) WRITE(IFCH,*)' DEGENERACY OF ENERGY LEVELS OF K-DIMENSIONAL' * ,' OSCILLATOR' WRITE(IFCH,121)('-',IC=1,79) WRITE(IFCH,*)' ==' * ,' NUMBER OF K-TUPELS OF LENGTH N (SUM_I N_I = N)' WRITE(IFCH,121)('-',IC=1,79) WRITE(IFCH,*)' K:',' 1',' 2',' 3',' 4' WRITE(IFCH,121)('-',IC=1,79) DO 8 N=0,50 WRITE(IFCH,*)N,(SNGL(EXP( TUCL(1+K,1+N) )),K=1,4) 8 CONTINUE ENDIF RETURN END