C 00000006 C 00000007 C PROGRAM JETS(TAPE1,TAPE2,TAPE3,TAPE11,INPUT,OUTPUT,TAPE5=INPUT, 00000008 C 1TAPE6=OUTPUT) 00000009 C 00000010 C P R O G R A M J E T S 00000011 C 00000012 C CLUSTER ALGORITMS FOR RECONSTRUCTION OF JETS 00000013 C IN HIGHT-ENERGY COLLISION EVENTS 00000014 C 00000015 C 00000016 C BY MARCELLO GALLI 82 00000017 C 00000018 DIMENSION P1(4,100) 00000019 C ....... NX MUST HAVE DIM 2 =NPMAX+80 00000020 DIMENSION NX(4,200),AGRAF(101,51) 00000021 C 00000022 DIMENSION DST(100,100) 00000023 C 00000024 COMMON /REC12/INEV,NPART,TITL,ECM,NVMX,NQUAI,NQUAMX 00000025 COMMON /PART/MP1,MP2,P(6,100) 00000026 C ************** WARNING: COMMONS /REC12/ AND /PART/ ARE USED IN 00000027 C ************** SUBROUTINES PRNTC2 AND INPTP1 00000028 C ************** COERENCE MUST BE ASSURED 00000029 C 00000030 DIMENSION PCLS(4,20),ICLS(2,20) 00000031 DIMENSION NCL(100),MST(2,100),NUMP(100),DU(100) 00000032 DIMENSION PJ(4,20),UI(100),JI(100),NIT(100),IAUS(200) 00000033 C ............. IAUS MUST BE > 2*NPMAX (FOR SUBROUTINE CLUST3) 00000034 DATA PI/3.14159265/ 00000035 EQUIVALENCE(AGRAF(1,1),DST(1,1)) 00000036 C DIMENSION PARAMETERS ::::::::::::::::::::::::::::::: 00000037 NPMAX=100 00000038 NQUAMX=20 00000039 C 00000040 MGR1=101 00000041 MGR2=51 00000042 MMP1=4 00000043 MPJ=4 00000044 MPCLS=4 00000045 MICLS=2 00000046 MMST=2 00000047 C 00000048 MP1=6 00000049 MP2=NPMAX 00000050 C 00000051 MDST=NPMAX 00000052 C 00000053 MNX1=4 00000054 MNX2=NPMAX+100 00000055 C 00000056 REWIND 1 00000057 C INITIALIZE STATISTICAL SUMMARY TABLE 00000058 CALL MEMOR1(1,NSTMP,NP,NC,NPMAX,NQUAMX,NCL,MPCLS, 00000059 1PCLS,MICLS,ICLS,MDST,DST) 00000060 100 CONTINUE 00000061 C +++++++++++++++++++++++++ INPUT ++++++++++++ 00000062 CALL INPTKI(NUMALG,3,10H ALGORITHM ) 00000063 IF(NUMALG.GT.100) GO TO 500 00000064 CALL INPTKI(NDIST,3,10HDISTANCE ) 00000065 C DEFINE DSTPK :DUMMY PARAMETER FOR SUBROUTINE DISTF2 00000066 DSTPK=0.0 00000067 CALL INPTKI(NUMEV,10,10H NUM EVENT ) 00000068 CALL INPTKI(NSTMP,0,10HPRINTING ) 00000069 200 CALL INPTKI(NPOST1,0,10H TAPE1 POS ) 00000070 C 00000071 C >>>>>>>>>>>>>............. SET TAPE 1 ....... 00000072 IF(NPOST1.EQ.0) GO TO 310 00000073 IF(NPOST1.GT.0) GO TO 400 00000074 REWIND 1 00000075 GO TO 200 00000076 400 DO 10 I=1,NPOST1 00000077 CALL INPTP1(0) 00000078 10 CONTINUE 00000079 310 CONTINUE 00000080 C 00000081 C ..................... INPUT CUTOFFS 00000082 CALL INPTKR(CUTP,0.,10HINF CUTOFF ) 00000083 CALL INPTKR(CUTPU,0.,10HSUP CUTOFF ) 00000084 C 00000085 C 00000086 C 00000087 C ################################################## 00000088 C 00000089 C #################### ALGORITHM MINIMAL SPANNING TREE 00000090 C 00000091 C ############################################################ 00000092 C 00000093 IF(NUMALG.NE.1) GO TO 501 00000094 C 00000095 C +++++++++++++++++++++++++ INPUT OF PARAMETERS +++++ 00000096 CALL INPTKR(DMST,1.2,10HMST BREAK ) 00000097 CALL INPTKR(EMIN,2.,10H EMIN CLUS ) 00000098 CALL INPTKI(NMIN,2,10H N MIN ) 00000099 C 00000100 C *********************::*** 20 20 20 LOOPS ON EVENTS 20****** 00000101 DO 20 I=1,NUMEV 00000102 CALL INPTP1(NSTMP) 00000103 C 00000104 C ........................ INITIALIZE PARAMETERS 00000105 NP=NPART 00000106 NQUA=NQUAI 00000107 NC=0 00000108 CALL EMPNUM(NP,NUMP) 00000109 C 00000110 C ++++++++++++++++ CUTOFFS +++++++++++++ 00000111 C 00000112 C 00000113 IF(CUTP.GT.1.E-30) CALL CUTPJ1(4,1,NSTMP,CUTP,NQUA,NP,MP1,MP2,P,NQ00000114 1AMX,MLTJ,NPMAX,NUMP,MPJ,NQUAMX,PJ) 00000115 IF(NP.LE.1) GO TO 114 00000116 IF(CUTPU.GT.1.E-30) CALL CUTPJ1(4,-1,NSTMP,CUTPU,NQUA,NP,MP1,MP2,P00000117 1,NQUAMX,MLTJ,NPMAX,NUMP,MPJ,NQUAMX,PJ) 00000118 IF(NP.LE.1) GO TO 114 00000119 C 00000120 IF(NSTMP.GE.3) WRITE(6,7679) NP 00000121 7679 FORMAT(35H NUMBER OF PARTICLES AFTER CUTOFFS: ,I10,/) 00000122 C 00000123 C 00000124 C +++++++++++++++++++CONSTRUCT M S T ++++++++++++++ 00000125 C 00000126 CALL DMTOM1(NDIST,DSTPK,MP1,MP2,P,NP,MMST,IMST,MST,CST,NPM 00000127 1AX,UI,JI,NIT,DU) 00000128 C 00000129 C +++++++++++++++++++++++++++; BREAKS THE M S T ++++++ 00000130 C 00000131 CALL SPZMST(DMST,MMST,IMST,MST,NPMAX,IAUS,NP,DU) 00000132 C 00000133 120 CONTINUE 00000134 C ++++++++++++++++++++++++++++ MAKES CLUSTERS FROM MST +++++00000135 CALL CLSMST(NP,NC,MMST,IMST,MST,NPMAX,NCL,MPCLS,NQUAMX,PCLS, 00000136 1MICLS,NQUAMX,ICLS,MP1,MP2,P) 00000137 C IF(NSTMP.GE.5) CALL PRNT1(1,NCL,NP,1,10H NCL ) 00000138 C IF(NSTMP.GT.6) CALL PRNTC2(0,NP,NC,MMST,IMST,MST,DU,NUMP, 00000139 C 1MPCLS,PCLS,MICLS,ICLS,NPMAX,NCL) 00000140 C 00000141 C ++++++++++++ PRINTS MST ++++++++++++++++++++ 00000142 IF(NSTMP.GT.10) CALL PRNTC2(1,NP,NC,MMST,IMST,MST,DU,NUMP, 00000143 1MPCLS,PCLS,MICLS,ICLS,NPMAX,NCL) 00000144 C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++00000145 C 00000146 C +++++++++++++++++++ CLUSTERS ARE TESTED +++++++++ 00000147 C 00000148 CALL ESMC2(NC,NP,NMIN,EMIN,COSMIN,MPCLS,NQUAMX,PCLS,NPMAX,NCL, 00000149 1MP1,MP2,P,MICLS,NQUAMX,ICLS) 00000150 C 00000151 C +++++++++++++++++++++ PRINTS ++++++++++++++++++++++++ 00000152 IF(NSTMP.GT.4) CALL PRNTNC(NP,NCL,MP1,MP2,P) 00000153 IF(NSTMP.GT.2) CALL PRNTC2(0,NP,NC,MMST,IMST,MST,DU,NUMP, 00000154 1MPCLS,PCLS,MICLS,ICLS,NPMAX,NCL) 00000155 C ++++++++++ STATISTICAL SUMMARY 00000156 CALL MEMOR1(2,NSTMP,NP,NC,NPMAX,NQUAMX,NCL,MPCLS,PCLS, 00000157 1MICLS,ICLS,MDST,DST) 00000158 C 00000159 C 00000160 600 CONTINUE 00000161 C 00000162 C ............................ GRAPHIC ............... 00000163 C 00000164 IF(NSTMP.LT.5) GO TO 114 00000165 KGRAF=4 00000166 N=NP 00000167 WRITE(6,1111) 00000168 1111 FORMAT(//,1H1,29X,29H THETA-PHI*SEN(THETA) GRAPHIC ,/, 00000169 158H NUMBERS REFERS TO ENERGY (GEV*10), LETTERS IDENTYFY JETS ,//)00000170 CALL COORD1(N,KGRAF,MP1,MP2,P,MDST,MDST,DST,MNX1,MNX2,NX,NPMAX,NUM00000171 1P,NCL) 00000172 CALL GRAF2(N,MNX1,MNX2,NX,MGR1,MGR2,AGRAF) 00000173 114 CONTINUE 00000174 20 CONTINUE 00000175 C ****************** THE LOOP ON EVENTS ENDS ******************** 00000176 C 00000177 C 00000178 C ############ END OF ALGORITHM NUMBER 1 : MST 00000179 C ########################################## 00000180 GO TO 100 00000181 C 00000182 C 00000183 501 IF(NUMALG.NE.2) GO TO 502 00000184 C ############################################# 00000185 C 00000186 C ALGORITHM 2: DENDOGRAM ( DENDRAL) 00000187 C 00000188 C ############################################# 00000189 C 00000190 CALL INPTKR(DNSTP,0.6,10H STOP DEND ) 00000191 CALL INPTKR(DISTP,1.E+20,10H STOP DIST ) 00000192 CALL INPTKR(EMIN,2.5,10H E MIN ) 00000193 CALL INPTKI(NMIN,2,10H N MIN ) 00000194 C 00000195 C 00000196 C ************************* LOOP ON EVENTS 00000197 C 00000198 DO 1 I=1,NUMEV 00000199 C 00000200 C ............................... READS INPUT FROM TAPE1 00000201 CALL INPTP1(NSTMP) 00000202 C ................THE FOLLOWING IS FOR DENDOGRAM PRINTING 00000203 NW2=0 00000204 C .................. NUMBER OF RECORDS WRITTEN ON UNIT 2 00000205 IF(NSTMP.GT.10) REWIND 2 00000206 C 00000207 C ........................ INITIALIZE PARAMETERS 00000208 C NP= NUMBER OF PARTICLES AFTER CUTOFFS 00000209 C NQUA=NUMBER OF JETS AFTERS CUTOFFS 00000210 C 00000211 NP=NPART 00000212 NQUA=NQUAI 00000213 C NUMP : NUMBERS OF INPUT PARTICLES 00000214 CALL EMPNUM(NP,NUMP) 00000215 C 00000216 IF(CUTP.GT.1.E-30) CALL CUTPJ1(4,1,NSTMP,CUTP,NQUA,NP,MP1,MP2,P,NQ00000217 1AMX,MLTJ,NPMAX,NUMP,MPJ,NQUAMX,PJ) 00000218 IF(NP.LE.1) GO TO 1 00000219 IF(CUTPU.GT.1.E-30) CALL CUTPJ1(4,-1,NSTMP,CUTPU,NQUA,NP,MP1,MP2,P00000220 1,NQUAMX,MLTJ,NPMAX,NUMP,MPJ,NQUAMX,PJ) 00000221 IF(NP.LE.1) GO TO 1 00000222 C 00000223 IF(NSTMP.GE.3) WRITE(6,7679) NP 00000224 C 00000225 C ++++++++++ INITIALIZE NCL AND NP1 +++++++++++++ 00000226 C (MST IS INITIALIZED FOR SUBROUTINE COMB1) 00000227 DO 11 II=1,NP 00000228 MST(1,II)=II 00000229 MST(2,II)=0 00000230 DU(II)=0.0 00000231 NCL(II)=0 00000232 DO 11 IJ=1,MMP1 00000233 P1(IJ,II)=P(IJ,II) 00000234 11 CONTINUE 00000235 C N :DECREASING INDEX FOR LOOP ON DENDOGRAM 00000236 N=NP 00000237 C COMPUTE DISTANCE MATRIX 00000238 C 00000239 CALL DIST3(NSTMP,NP,NDIST,DSTPK,MP1,MP2,P,MDST,DST) 00000240 C 00000241 C ++++++++++++++ SET THE NUMBER OF ITERATIONS 00000242 N1=NP*DNSTP 00000243 IF(N1.LT.0) N1=-DNSTP 00000244 IF(N1.GE.NP.OR.N1.LE.0) N1=NP-1 00000245 C 00000246 C ************************* LOOPS ON DENDOGRAM 00000247 C 00000248 DO 2 II=1,N1 00000249 C +++++++++++++MINIMUM DISTANCE:A(K1,L1)=MIN DST(I,J) +++++ 00000250 CALL DSTMN(N,MDST,DST,K,L,A) 00000251 C 00000252 C STOPS IF THE MINIMUM DISTANCE IS REACHED 00000253 IF(A.GT.DISTP) GO TO 101 00000254 C DU ARE THE DISTANCES 00000255 DU(N)=A 00000256 C 00000257 C ................... SETS NCL ............. 00000258 CALL COMB2(NP,K,L,N,4,P1,MMST,MST,NP,NCL) 00000259 C 00000260 C 00000261 C 00000262 C +++++++++++++++ SAVE NCL FOR PRINTING 00000263 IF(NSTMP.LE.10) GO TO 13 00000264 WRITE(2) (NCL(J),J=1,NP) 00000265 NW2=NW2+1 00000266 13 CONTINUE 00000267 C ++++++++++++++++++++++ UPDATES DISTANCE MATRIX: DST 00000268 C +++++++++++++ RECOMPUTE DISTANCES ++++++++++++++++++ 00000269 CALL CAMBD1(NDIST,DSTPK,L,K,N,MDST,DST,4,N,P1) 00000270 C 00000271 IF(N.LE.3) GO TO 101 00000272 N=N-1 00000273 2 CONTINUE 00000274 101 CONTINUE 00000275 C ***************** LOOP ON DENDOGRAM ENDS ********* 00000276 C ************************************************** 00000277 C +++++++++++++++++++++++++++++++++++++++++++++++ 00000278 C +++++++++++++++++ PRINTS DENDOGRAM ++++++++++++++++++++00000279 C IF(NSTMP.LE.11) GO TO 103 00000280 C WRITE(6,900) 00000281 C900 FORMAT(//,20H DENDOGRAM HISTORY ) 00000282 C WRITE(6,1001) (JJ,(P1(J,JJ),J=1,4),MST(1,JJ),MST(2,JJ),DU(JJ),J 00000283 C 1J,NCL(JJ),JJ=1,NP) 00000284 C1001 FORMAT(5H NUM=,I5,4H PX=,E12.5,4H PY=,E12.5,4H PZ=,E12.5, 00000285 C 13H E=,E12.5,6H PART:,I4,12H ADDED TO :,I4,7H D MIN:,E12.5, 00000286 C 15H NCL(,I4,2H)=,I4) 00000287 C103 CONTINUE 00000288 IF(NSTMP.GT.10) CALL PRNTD(NP,NW2,MDST,DST) 00000289 C ++++++++++++++++++++++++++++++++++++++++++++++++ 00000290 C ++++++ MAKES CLUSTERS USING NCL +++= 00000291 C ..................... COMPUTES MOMENTA OF CLUSTERS 00000292 C 00000293 CALL CLUST3(NP,NC,NCL,IAUS,MP1,P,MPCLS,NQUAMX,PCLS,MICLS,ICLS) 00000294 C 00000295 C IF(NSTMP.GE.5) CALL PRNT1(1,NCL,NP,1,10H NCL ) 00000296 C IF(NSTMP.GT.6) CALL PRNTC2(0,NP,NC,MMST,IMST,MST,DU,NUMP, 00000297 C 1MPCLS,PCLS,MICLS,ICLS,NPMAX,NCL) 00000298 C +++++++++++++++++++ TESTS ON CLUSTERS +++++++++ 00000299 C 00000300 CALL ESMC2(NC,NP,NMIN,EMIN,COSMIN,MPCLS,NQUAMX,PCLS,NPMAX,NCL, 00000301 1MP1,MP2,P,MICLS,NQUAMX,ICLS) 00000302 C 00000303 C 00000304 C 00000305 C 00000306 IF(NSTMP.GE.4) CALL PRNTNC(NP,NCL,MP1,MP2,P) 00000307 IF(NSTMP.GT.2) CALL PRNTC2(0,NP,NC,MMST,IMST,MST,DU,NUMP, 00000308 1MPCLS,PCLS,MICLS,ICLS,NPMAX,NCL) 00000309 C 00000310 C ............................ GRAPHIC ............... 00000311 C 00000312 IF(NSTMP.LT.5) GO TO 107 00000313 KGRAF=4 00000314 N=NP 00000315 WRITE(6,1111) 00000316 CALL COORD1(N,KGRAF,MP1,MP2,P,MDST,MDST,DST,MNX1,MNX2,NX,NPMAX,NUM00000317 1P,NCL) 00000318 CALL GRAF2(N,MNX1,MNX2,NX,MGR1,MGR2,AGRAF) 00000319 107 CONTINUE 00000320 C .............................. STATISTICAL SUMMARY.......... 00000321 C 00000322 CALL MEMOR1(2,NSTMP,NP,NC,NPMAX,NQUAMX,NCL,MPCLS,PCLS, 00000323 1MICLS,ICLS,MDST,DST) 00000324 C 00000325 1 CONTINUE 00000326 C **************** LOOP ON EVENTS ENDS HERE ******** 00000327 GO TO 100 00000328 502 CONTINUE 00000329 IF(NUMALG.NE.3) GO TO 503 00000330 C ##################################################### 00000331 C 00000332 C ################# ALGORITHM NUMBER 3 : TREE 00000333 C 00000334 C ######################################################## 00000335 C 00000336 C +++++++++++++++++++++++++ INPUT PARAMETERS +++++ 00000337 CALL INPTKR(DMST,2.,10HTREE BREAK ) 00000338 CALL INPTKR(EMIN,2.,10H E MIN ) 00000339 CALL INPTKI(NMIN,2,10H N MIN ) 00000340 C 00000341 C *********************::*** 21 21 21 LOOP ON EVENTS 21 21****** 00000342 DO 21 I=1,NUMEV 00000343 CALL INPTP1(NSTMP) 00000344 C 00000345 C ........................ INITIALIZE PARAMETERS 00000346 NP=NPART 00000347 NQUA=NQUAI 00000348 NC=0 00000349 CALL EMPNUM(NP,NUMP) 00000350 C 00000351 IF(CUTP.GT.1.E-30) CALL CUTPJ1(4,1,NSTMP,CUTP,NQUA,NP,MP1,MP2,P,NQ00000352 1AMX,MLTJ,NPMAX,NUMP,MPJ,NQUAMX,PJ) 00000353 IF(NP.LE.1) GO TO 601 00000354 IF(CUTPU.GT.1.E-30) CALL CUTPJ1(4,-1,NSTMP,CUTPU,NQUA,NP,MP1,MP2,P00000355 1,NQUAMX,MLTJ,NPMAX,NUMP,MPJ,NQUAMX,PJ) 00000356 IF(NP.LE.1) GO TO 601 00000357 C 00000358 IF(NSTMP.GE.3) WRITE(6,7679) NP 00000359 C 00000360 C 00000361 C 00000362 C +++++++++++++++++++++++ ORDER MATRIX: P(.,I) 00000363 C ++++++++++++++++P IS SET IN A DECREASING ENERGY ORDER 00000364 C 00000365 CALL ORDP(NP,MP1,MP2,P,NPMAX,NUMP) 00000366 C 00000367 C +++++++++++++++++++++++++++++ MAKES T R E E +++++++++++++ 00000368 C 00000369 CALL TREE1(NP,IMST,NDIST,DSTPK,MMST,NPMAX,MST, 00000370 1NPMAX,DU,MP1,MP2,P) 00000371 C 00000372 C +++++++++++++++++++++++++++; BREAKS THE T R E E ++++++ 00000373 C 00000374 CALL SPZMST(DMST,MMST,IMST,MST,NPMAX,IAUS,NP,DU) 00000375 C 00000376 220 CONTINUE 00000377 C ++++++++++++++++++++++++++++ MAKES CLUSTERS FROM TREE +++++00000378 CALL CLSMST(NP,NC,MMST,IMST,MST,NPMAX,NCL,MPCLS,NQUAMX,PCLS, 00000379 1MICLS,NQUAMX,ICLS,MP1,MP2,P) 00000380 C IF(NSTMP.GE.5) CALL PRNT1(1,NCL,NP,1,10H NCL ) 00000381 C 00000382 C ++++++++++++ PRINTING ++++++++++++++++++++ 00000383 IF(NSTMP.GT.10) CALL PRNTC2(2,NP,NC,MMST,IMST,MST,DU,NUMP, 00000384 1MPCLS,PCLS,MICLS,ICLS,NPMAX,NCL) 00000385 C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++00000386 C IF(NSTMP.GT.6) CALL PRNTC2(0,NP,NC,MMST,IMST,MST,DU,NUMP, 00000387 C 1MPCLS,PCLS,MICLS,ICLS,NPMAX,NCL) 00000388 C 00000389 C +++++++++++++++++++ TEST ON CLUSTERS +++++++++ 00000390 C 00000391 CALL ESMC2(NC,NP,NMIN,EMIN,COSMIN,MPCLS,NQUAMX,PCLS,NPMAX,NCL, 00000392 1MP1,MP2,P,MICLS,NQUAMX,ICLS) 00000393 C 00000394 C 00000395 C +++++++++++++++++++++ PRINTS ++++++++++++++++++++++++ 00000396 IF(NSTMP.GT.4) CALL PRNTNN(NP,NCL,NUMP,MP1,MP2,P) 00000397 IF(NSTMP.GT.2) CALL PRNTC2(0,NP,NC,MMST,IMST,MST,DU,NUMP, 00000398 1MPCLS,PCLS,MICLS,ICLS,NPMAX,NCL) 00000399 C ++++++++++ STATISTICAL SUMMARY 00000400 CALL MEMOR1(2,NSTMP,NP,NC,NPMAX,NQUAMX,NCL,MPCLS,PCLS, 00000401 1MICLS,ICLS,MDST,DST) 00000402 C 00000403 C 00000404 C ............................ GRAPHIC ............... 00000405 C 00000406 IF(NSTMP.LT.5) GO TO 214 00000407 KGRAF=4 00000408 N=NP 00000409 WRITE(6,1111) 00000410 CALL COORD1(N,KGRAF,MP1,MP2,P,MDST,MDST,DST,MNX1,MNX2,NX,NPMAX,NUM00000411 1P,NCL) 00000412 CALL GRAF2(N,MNX1,MNX2,NX,MGR1,MGR2,AGRAF) 00000413 214 CONTINUE 00000414 C 00000415 601 CONTINUE 00000416 21 CONTINUE 00000417 C ****************** THE LOOP ON EVENTS ENDS HERE***************** 00000418 C 00000419 C ################################# ALGORITHM 3 ENDS 00000420 GO TO 100 00000421 503 CONTINUE 00000422 C ###################################################### 00000423 C 00000424 IF(NUMALG.NE.4) GO TO 504 00000425 C 00000426 C ################################################## 00000427 C 00000428 C A L G O R I T M H N U M B E R 4 00000429 C 00000430 C RECONSTRUCTION OF A PREFIXED NUMBER OF JETS USING MST 00000431 C ################################################## 00000432 C 00000433 C ...................... INPUT PARAMETERS 00000434 CALL INPTKR(DNSTP,0.4,10H STOP DEND ) 00000435 CALL INPTKR(EMIN,1.,10H E MIN ) 00000436 CALL INPTKI(NMIN,1,10H MIN PART ) 00000437 C 00000438 C ******************************************************* 00000439 C ********* LOOP ON EVENTS *********** 00000440 C 00000441 DO 41 I=1,NUMEV 00000442 C 00000443 C ............................READS MOMENTA FROM TAPE 1 00000444 CALL INPTP1(NSTMP) 00000445 C 00000446 C ........................ INITIALIZE PARAMETERS 00000447 C 00000448 NP=NPART 00000449 NQUA=NQUAI 00000450 CALL EMPNUM(NP,NUMP) 00000451 C 00000452 IF(CUTP.GT.1.E-30) CALL CUTPJ1(4,1,NSTMP,CUTP,NQUA,NP,MP1,MP2,P,NQ00000453 1AMX,MLTJ,NPMAX,NUMP,MPJ,NQUAMX,PJ) 00000454 IF(NP.LE.1) GO TO 401 00000455 IF(CUTPU.GT.1.E-30) CALL CUTPJ1(4,-1,NSTMP,CUTPU,NQUA,NP,MP1,MP2,P00000456 1,NQUAMX,MLTJ,NPMAX,NUMP,MPJ,NQUAMX,PJ) 00000457 IF(NP.LE.1) GO TO 401 00000458 C 00000459 IF(NSTMP.GE.3) WRITE(6,7679) NP 00000460 C 00000461 NITER=0 00000462 EMIN1=EMIN 00000463 NMIN1=NMIN 00000464 DNSTP1=DNSTP 00000465 C *LOOP* IF THE NUMBER OF JETS IS NOT RECOGNIZED CHANGES 00000466 C PARAMETER VALUES 00000467 475 CONTINUE 00000468 C 00000469 CALL NULL(NP,1,NCL) 00000470 NC=0 00000471 C ........................MAKES M S T 00000472 C 00000473 CALL DMTOM1(NDIST,DSTPK,MP1,MP,P,NP,MMST,IMST,MST,CST,NPMAX,UI, 00000474 1JI,NIT,DU) 00000475 C 00000476 C IF(NSTMP.GT.10) CALL PRNTC2(1,NP,NC,MMST,IMST,MST,DU,NUMP, 00000477 C 1MPCLS,PCLS,MICLS,ICLS,NPMAX,NCL) 00000478 C 00000479 C .................... ORDER MST FOR CREASING DISTANCES 00000480 C 00000481 CALL ORDTRE(IMST,MMST,NPMAX,MST,NPMAX,DU) 00000482 IF(NSTMP.GT.11) CALL PRNTC2(1,NP,NC,MMST,IMST,MST,DU,NUMP, 00000483 1MPCLS,PCLS,MICLS,ICLS,NPMAX,NCL) 00000484 C......................MAKES CLUSTERS FROM ORDERED TREE 00000485 C ....FIX MINIMUM NUMBER OF ITERATIONS 00000486 N1=DNSTP1*NP 00000487 IF(N1.LT.0) N1=-DNSTP1 00000488 IF(N1.EQ.NP) N1=NP-1 00000489 IF(N1.GT.NP.OR.N1.LE.0) N1=1 00000490 C 00000491 C 00000492 C 00000493 C ************************************************************* 00000494 C *********** LOOP : ON MST EDGES *42II00000495 C 00000496 DO 42 II=1,IMST 00000497 C ........... PARTICLES OF THE ROW II ARE CLUSTERED 00000498 CALL FAQUA(II,NP,NC,MP1,MP2,P,MPCLS,NQUAMX,PCLS,MICLS,ICLS, 00000499 1NPMAX,NCL,MMST,NPMAX,MST) 00000500 C 00000501 C IF(NSTMP.GT.12.AND.II.EQ.1) WRITE(6,4404) 00000502 C4404 FORMAT(//,19H CLUSTERING HISTORY ) 00000503 C IF(NSTMP.GT.12) WRITE(6,4400) NC,(PCLS(4,J),ICLS(1,J),J=1,NC)00000504 C4400 FORMAT(9H CLUSTER:,I4,(8H E,PART:,5(E12.5,I5,1X))) 00000505 IF(NC.LT.NQUAI) GO TO 42 00000506 IF(II.LT.N1) GO TO 42 00000507 NCONT=0 00000508 NCONT1=0 00000509 DO 43 IJ=1,NC 00000510 IF(PCLS(4,IJ).GT.EMIN1) NCONT=NCONT+1 00000511 IF(ICLS(1,IJ).GT.NMIN1) NCONT1=NCONT1+1 00000512 43 CONTINUE 00000513 IF(NCONT.GE.NQUA.AND.NCONT1.GE.NQUA) GO TO 410 00000514 42 CONTINUE 00000515 C 00000516 C :**************** END OF LOOP NUMBER 42 ******** 00000517 C *********************************************************: 00000518 C .............. REITERATES IF NC.NE.NQUA 00000519 NITER=NITER+1 00000520 IF(NITER.GE.1) NMIN1=1 00000521 IF(NITER.GE.2) EMIN1=0.01 00000522 IF(NITER.GE.3) DNSTP1=-1 00000523 3006 FORMAT(22H WARNING REITERATION:,I5,42H WITH PARAMETERS: NCRIT,DNST00000524 1P,EMIN,NMIN: ,I5,2X,E12.5,2X,E12.5,2X,I5) 00000525 WRITE(6,3005) INEV,I 00000526 3005 FORMAT(7H EVENT:,I10,8H NUMBER:,I10) 00000527 WRITE(6,3007)NITER,DNSTP1,EMIN1,NMIN1 00000528 3007 FORMAT(22H WARNING!,REITERATION:,I10,16H WHIT PARAMETERS , 00000529 118H DNSTP,EMIN,NMIN= ,2E12.5,I10) 00000530 IF(NITER.LE.3) GO TO 475 00000531 WRITE(6,4444) INEV 00000532 4444 FORMAT(41H !!!!!!!!!!!!!!!! WARNING !!!!!!!!!!!!! ,/, 00000533 114H EVENT NUMBER:,I10,17H NOT RECOGNIZED ) 00000534 GO TO 401 00000535 410 CONTINUE 00000536 C ..................SELECTS THE MOST ENERGETIC CLUSTERS 00000537 CALL SCELT(NC,NP,NQUAI,MPCLS,NQUAMX,PCLS,MICLS,ICLS,NPMAX,NCL) 00000538 C 00000539 C 00000540 CALL AGGPAR(5,DSTPK,NP,NC,MPCLS,PCLS,MICLS,ICLS,NCL,MP1,P) 00000541 C 00000542 C 00000543 IF(NSTMP.GE.2) CALL PRNTC2(0,NP,NC,MMST,IMST,MST,DU,NUMP, 00000544 1MPCLS,PCLS,MICLS,ICLS,NPMAX,NCL) 00000545 IF(NSTMP.GT.4) CALL PRNTNC(NP,NCL,MP1,MP2,P) 00000546 C 00000547 C ............................ GRAPHIC ............... 00000548 C 00000549 IF(NSTMP.LT.5) GO TO 434 00000550 KGRAF=4 00000551 N=NP 00000552 WRITE(6,1111) 00000553 CALL COORD1(N,KGRAF,MP1,MP2,P,MDST,MDST,DST,MNX1,MNX2,NX,NPMAX,NUM00000554 1P,NCL) 00000555 CALL GRAF2(N,MNX1,MNX2,NX,MGR1,MGR2,AGRAF) 00000556 434 CONTINUE 00000557 C .............................. STATISTICAL SUMMARY.......... 00000558 C 00000559 CALL MEMOR1(2,NSTMP,NP,NC,NPMAX,NQUAMX,NCL,MPCLS,PCLS, 00000560 1MICLS,ICLS,MDST,DST) 00000561 C 00000562 C 00000563 401 CONTINUE 00000564 41 CONTINUE 00000565 C **************** THE LOOP ON EVENTS ENDS HERE ******** 00000566 GO TO 100 00000567 504 CONTINUE 00000568 C 00000569 C ################################################## 00000570 C 00000571 C A L G O R I T M H N U M B E R 5 00000572 C 00000573 IF(NUMALG.NE.5) GO TO 505 00000574 C ########################################### 00000575 C #######RECONSTRUCTION OF A FIXED NUMBER OF JETS USING DENDOGRAM 00000576 C 00000577 C ########################################################## 00000578 C 00000579 C +++++++++++++++++++++++++ INPUT PARAMETERS +++++ 00000580 CALL INPTKR(DNSTP,1.33,10H STOP DEND ) 00000581 CALL INPTKI(NCRIT,3,10HSTOP CRIT ) 00000582 C 00000583 CALL INPTKR(EMIN,2.,10H E MIN ) 00000584 CALL INPTKI(NMIN,2,10H MIN PART ) 00000585 C 00000586 C ************** LOOP ON EVENTS 00000587 DO 31 I=1,NUMEV 00000588 C 00000589 C ....................READS TAPE 1 FILLS COMMONS:/REC12/PART/ 00000590 CALL INPTP1(NSTMP) 00000591 C 00000592 C ........................ INIZIALIZE PARAMETERS 00000593 C 00000594 NP=NPART 00000595 NQUA=NQUAI 00000596 CALL EMPNUM(NP,NUMP) 00000597 C 00000598 IF(CUTP.GT.1.E-30) CALL CUTPJ1(4,1,NSTMP,CUTP,NQUA,NP,MP1,MP2,P,NQ00000599 1AMX,MLTJ,NPMAX,NUMP,MPJ,NQUAMX,PJ) 00000600 IF(NP.LE.1) GO TO 31 00000601 IF(CUTPU.GT.1.E-30) CALL CUTPJ1(4,-1,NSTMP,CUTPU,NQUA,NP,MP1,MP2,P00000602 1,NQUAMX,MLTJ,NPMAX,NUMP,MPJ,NQUAMX,PJ) 00000603 IF(NP.LE.1) GO TO 31 00000604 C 00000605 IF(NSTMP.GE.3) WRITE(6,7679) NP 00000606 C 00000607 C ++++++++++ INITIALIZE NCL AND NP1 +++++++++++++ 00000608 C ............. REITERATES FOR NC.NE.NQUA 00000609 NITER=0 00000610 NMIN1=NMIN 00000611 DNSTP1=DNSTP 00000612 NCRIT1=NCRIT 00000613 EMIN1=EMIN 00000614 C ********************** LOOP 00000615 375 NC=0 00000616 C 00000617 DO 32 II=1,NP 00000618 MST(1,II)=II 00000619 MST(2,II)=0 00000620 DU(II)=0.0 00000621 NCL(II)=0 00000622 DO 32 IJ=1,MMP1 00000623 P1(IJ,II)=P(IJ,II) 00000624 32 CONTINUE 00000625 C N = DECREASING INDEX IN THE LOOP ON DENDOGRAM 00000626 N=NP 00000627 C .............. NUMBER OF RECORDS WRITTEN ON UNIT 2 00000628 NW2=0 00000629 C ......................... FOR PRINTING 00000630 IF(NSTMP.GT.10) REWIND 2 00000631 C 00000632 CALL DIST3(NSTMP,NP,NDIST,DSTPK,MP1,MP2,P,MDST,DST) 00000633 C 00000634 C :*******************************************************: 00000635 C ***************************** LOOP ON DENDOGRAM 00000636 NSTOP=0 00000637 C ..............FIX MINIMUN NUMBER OF ITERATIONS 00000638 N1=DNSTP1*NP 00000639 IF(N1.LT.0) N1=-DNSTP1 00000640 IF(N1.EQ.NP) N1=NP-1 00000641 IF(N1.GT.NP.OR.N1.LE.0) N1=1 00000642 C 00000643 DO 34 II=1,NP 00000644 C ++++++++++ MINIMUM DISTANCE:A(K1,L1)=MIN DST(I,J) +++++ 00000645 CALL DSTMN(N,MDST,DST,K,L,A) 00000646 C 00000647 C 00000648 C 00000649 IF(NCL(MST(1,K)).GT.0.AND.NCL(MST(1,L)).GT.0) NC=NC-1 00000650 IF(NCL(MST(1,K)).LE.0.AND.NCL(MST(1,L)).LE.0) NC=NC+1 00000651 DU(N)=A 00000652 C 00000653 IF(NC.GE.NQUA) NSTOP=II 00000654 C 00000655 CALL COMB2(NP,K,L,N,4,P1,MMST,MST,NP,NCL) 00000656 C IF(NSTMP.GT.12.AND.II.EQ.1) WRITE(6,4404) 00000657 C 00000658 IF(NSTMP.LE.10) GO TO 36 00000659 WRITE(2) (NCL(J),J=1,NP) 00000660 NW2=NW2+1 00000661 36 CONTINUE 00000662 C 00000663 C >>>>>>>>>>>>>>>> STOP CRITERIUM NUMBER 2 00000664 C 00000665 C ............... STOPS AFTER N1 IF NC =NQUA 00000666 C 00000667 IF(NCRIT1.EQ.2.AND.II.GT.N1.AND.NSTOP.GT.0.AND.NC.EQ.NQUA) 00000668 1 GOTO 300 00000669 IF(NCRIT1.NE.3.OR.NC.LE.NQUA.OR.II.LE.N1) GO TO 301 00000670 C 00000671 C >>>>>>>>>>>>>>>>> STOP CRITERIUM NUMBER 3 00000672 C 00000673 C ....... STOPS AFTER N1 IF FOUND NQUA JETS>EMIN1,NMIN1 00000674 C 00000675 C 00000676 C ............ MAKES CLUSTERS FROM NCL... 00000677 C 00000678 CALL CLUST3(NP,NCC,NCL,IAUS,MP1,P,MPCLS,NQUAMX,PCLS,MICLS,ICLS) 00000679 IF(NCC.NE.NC) WRITE(6,3008) I 00000680 NC=NCC 00000681 C IF(NSTMP.GT.12) WRITE(6,4400) NC,(PCLS(4,J),ICLS(1,J),J=1,NC)00000682 NCONT=0 00000683 NCONT1=0 00000684 DO 33 IJ=1,NC 00000685 IF(PCLS(4,IJ).GE.EMIN1) NCONT=NCONT+1 00000686 IF(ICLS(1,IJ).GE.NMIN1) NCONT1=NCONT1+1 00000687 33 CONTINUE 00000688 IF(NCONT.LT.NQUA.OR.NCONT1.LT.NQUA) GO TO301 00000689 C ......................SELECT NC CLUSTERS 00000690 CALL SCELT(NC,NP,NQUA,MPCLS,NQUAMX,PCLS,MICLS,ICLS,NPMAX,NCL) 00000691 C 00000692 GO TO 302 00000693 301 CONTINUE 00000694 C 00000695 C ++++++++++++++++++++++ UPDATES DISTENCE MATRIX 00000696 C +++++++++++++ COMPUTES DISTANCES ++++++++++++++++++ 00000697 CALL CAMBD1(NDIST,DSTPK,L,K,N,MDST,DST,4,N,P1) 00000698 C 00000699 IF(N.LE.3) GO TO 300 00000700 N=N-1 00000701 34 CONTINUE 00000702 C ***************** LOOP ON DENDOGRAM ENDS ********* 00000703 C ************************************************** 00000704 300 CONTINUE 00000705 IF(NC.EQ.NQUA) GO TO 330 00000706 C ............ REITERATES IF THE NUMBER OF JETS IS MISSED 00000707 C ...CHANGE FIRST STOP CRITERIUM ,THEN : EMIN, NMIN 00000708 NITER=NITER+1 00000709 NMIN1=1 00000710 IF(NITER.GE.2) EMIN1=0.01 00000711 IF(NITER.GE.3) DNSTP1=-1 00000712 IF(NITER.GE.4) NCRIT1=2 00000713 WRITE(6,3005) INEV,I 00000714 WRITE(6,3006)NITER,NCRIT1,DNSTP1,EMIN1,NMIN1 00000715 IF(NITER.LE.4) GO TO 375 00000716 WRITE(6,3008) I 00000717 3008 FORMAT(38H !!!!!!!!!!!!!!! WARNING !!!!!!!!!!!! ,/, 00000718 131H RECOSTRUSTION OF EVENT NUMBER:,I6,15H IS IMPOSSIBLE ) 00000719 GO TO 31 00000720 330 CONTINUE 00000721 C ++++++++++++++++++++++++++++++++++++++++++++++++ 00000722 C ++++++ MAKES CLUSTERS +++= 00000723 C 00000724 CALL CLUST3(NP,NCC,NCL,IAUS,MP1,P,MPCLS,NQUAMX,PCLS,MICLS,ICLS) 00000725 IF(NCC.NE.NQUA) WRITE(6,3008) I 00000726 NC=NCC 00000727 302 CONTINUE 00000728 C IF(NSTMP.GE.5) CALL PRNT1(1,NCL,NP,1,10H NCL ) 00000729 C +++++++++++++++++++++++++++++++++++++++++++++++ 00000730 C +++++++++++++++++ PRINTING ++++++++++++++++++++00000731 C IF(NSTMP.LE.11) GO TO 373 00000732 C WRITE(6,900) 00000733 C WRITE(6,1001) (JJ,(P1(J,JJ),J=1,4),MST(1,JJ),MST(2,JJ),DU(JJ),J 00000734 C 1J,NCL(JJ),JJ=1,NP) 00000735 C373 CONTINUE 00000736 IF(NSTMP.GT.10) CALL PRNTD(NP,NW2,NPMAX,DST) 00000737 C ++++++++++++++++++++++++++++++++++++++++++++++++ 00000738 C 00000739 C 00000740 CALL AGGPAR(5,DSTPK,NP,NC,MPCLS,PCLS,MICLS,ICLS,NCL,MP1,P) 00000741 C 00000742 C 00000743 IF(NSTMP.GE.4) CALL PRNTNC(NP,NCL,MP1,MP2,P) 00000744 C 00000745 C ............................ GRAPHIC ............... 00000746 C 00000747 IF(NSTMP.LT.5) GO TO 334 00000748 KGRAF=4 00000749 N=NP 00000750 WRITE(6,1111) 00000751 CALL COORD1(N,KGRAF,MP1,MP2,P,MDST,MDST,DST,MNX1,MNX2,NX,NPMAX,NUM00000752 1P,NCL) 00000753 CALL GRAF2(N,MNX1,MNX2,NX,MGR1,MGR2,AGRAF) 00000754 334 CONTINUE 00000755 C ........................STATISTICAL SUMMARY.................. 00000756 C 00000757 CALL MEMOR1(2,NSTMP,NP,NC,NPMAX,NQUAMX,NCL,MPCLS,PCLS, 00000758 1MICLS,ICLS,MDST,DST) 00000759 C 00000760 C 00000761 31 CONTINUE 00000762 C **************** LOOP ON EVENTS ENDS HERE ******** 00000763 GO TO 100 00000764 505 CONTINUE 00000765 IF(NUMALG.NE.6) GO TO 506 00000766 C 00000767 C ################################################## 00000768 C 00000769 C A L G O R I T M H N U M B E R 6 00000770 C 00000771 C RICONSTRUCTION OF A FIXED NUMBER OF JETS BASED ON TREE 00000772 C ################################################## 00000773 C 00000774 C ...................... INPUT PARAMETERS 00000775 CALL INPTKR(DNSTP,0.4,10H STOP TREE ) 00000776 CALL INPTKR(EMIN,2.,10H E MIN ) 00000777 CALL INPTKI(NMIN,2,10H MIN PART ) 00000778 C 00000779 C ******************************************************* 00000780 C ********* LOOP ON EVENTS *********** 00000781 C 00000782 DO 51 I=1,NUMEV 00000783 C 00000784 C ......................READS MOMENTA FROM TAPE 1 00000785 CALL INPTP1(NSTMP) 00000786 C 00000787 C ........................ INITIALIZE PARAMETERS 00000788 C 00000789 NP=NPART 00000790 NQUA=NQUAI 00000791 CALL EMPNUM(NP,NUMP) 00000792 C 00000793 IF(CUTP.GT.1.E-30) CALL CUTPJ1(4,1,NSTMP,CUTP,NQUA,NP,MP1,MP2,P,NQ00000794 1AMX,MLTJ,NPMAX,NUMP,MPJ1,NQUAMX,PJ) 00000795 IF(NP.LE.1) GO TO 591 00000796 IF(CUTPU.GT.1.E-30) CALL CUTPJ1(4,-1,NSTMP,CUTPU,NQUA,NP,MP1,MP2,P00000797 1,NQUAMX,MLTJ,NPMAX,NUMP,MPJ,NQUAMX,PJ) 00000798 IF(NP.LE.1) GO TO 591 00000799 C 00000800 IF(NSTMP.GE.3) WRITE(6,7679) NP 00000801 C 00000802 C 00000803 C ..................... ORDER PARTICLES FOR CREASING ENERGY 00000804 CALL ORDP(NP,MP1,MP2,P,NPMAX,NUMP) 00000805 C ......................... MAKES TREE , 00000806 CALL TREE1(NP,IMST,NDIST,DSTPK,MMST,NPMAX,MST,NPMAX,DU,MP1,MP2,P 00000807 1) 00000808 C 00000809 C IF(NSTMP.GT.10) CALL PRNTC2(2,NP,NC,MMST,IMST,MST,DU,NUMP, 00000810 C 1MPCLS,PCLS,MICLS,ICLS,NPMAX,NCL) 00000811 C 00000812 C .................... ORDER TREE FOR CREASING DISTANCES 00000813 C 00000814 CALL ORDTRE(IMST,MMST,NPMAX,MST,NPMAX,DU) 00000815 IF(NSTMP.GT.11) CALL PRNTC2(2,NP,NC,MMST,IMST,MST,DU,NUMP, 00000816 1MPCLS,PCLS,MICLS,ICLS,NPMAX,NCL) 00000817 C............................. MAKES CLUSTERS 00000818 NITER=0 00000819 EMIN1=EMIN 00000820 NMIN1=NMIN 00000821 DNSTP1=DNSTP 00000822 C ........ REITERATES IF THE NUMBER OF JETS IS MISSED 00000823 C ****************** LOOP 00000824 575 CONTINUE 00000825 NC=0 00000826 C 00000827 CALL NULL(NP,1,NCL) 00000828 C ................... FIX MINIMUM NUMBER OF ITERATIONS 00000829 N1=DNSTP1*NP 00000830 IF(N1.LT.0) N1=-DNSTP1 00000831 IF(N1.EQ.NP) N1=NP-1 00000832 IF(N1.GT.NP.OR.N1.LE.0) N1=1 00000833 C 00000834 C 00000835 C ************************************************************* 00000836 C *********** LOOP ON CLUSTERING OF PARTICLES *52II00000837 C 00000838 DO 52 II=1,IMST 00000839 C ........... CLUSTERS PARTICLES OF THE ROW II OF THE TREE 00000840 CALL FAQUA(II,NP,NC,MP1,MP2,P,MPCLS,NQUAMX,PCLS,MICLS,ICLS, 00000841 1NPMAX,NCL,MMST,NPMAX,MST) 00000842 C IF(NSTMP.GT.12.AND.II.EQ.1) WRITE(6,4404) 00000843 C IF(NSTMP.GT.12) WRITE(6,4400) NC,(PCLS(4,J),ICLS(1,J),J=1,NC)00000844 C ........................ TESTS FOR STOPPING PROCEDURE 00000845 IF(NC.LT.NQUA) GO TO 52 00000846 IF(II.LT.N1) GO TO 52 00000847 NCONT=0 00000848 NCONT1=0 00000849 DO 53 IJ=1,NC 00000850 IF(PCLS(4,IJ).GT.EMIN1) NCONT=NCONT+1 00000851 IF(ICLS(1,IJ).GT.NMIN1) NCONT1=NCONT1+1 00000852 53 CONTINUE 00000853 IF(NCONT.GE.NQUA.AND.NCONT1.GE.NQUA) GO TO 519 00000854 52 CONTINUE 00000855 C 00000856 C :**************** END OF LOOP 52 ******** 00000857 C *********************************************************: 00000858 C .............. REITERATES IF NC.NE.NQUA 00000859 NITER=NITER+1 00000860 IF(NITER.GE.1) NMIN1=1 00000861 IF(NITER.GE.2) EMIN1=0.01 00000862 IF(NITER.GE.3) DNSTP1=-1 00000863 WRITE(6,3005) INEV,I 00000864 WRITE(6,3007)NITER,DNSTP1,EMIN1,NMIN1 00000865 IF(NITER.LE.3) GO TO 575 00000866 WRITE(6,4444) INEV 00000867 GOTO 591 00000868 519 CONTINUE 00000869 C IF(NSTMP.GE.6) CALL PRNTC2(0,NP,NC,MMST,IMST,MST,DU,NUMP, 00000870 C 1MPCLS,PCLS,MICLS,ICLS,NPMAX,NCL) 00000871 CALL SCELT(NC,NP,NQUAI,MPCLS,NQUAMX,PCLS,MICLS,ICLS,NPMAX,NCL) 00000872 C 00000873 C 00000874 CALL AGGPAR(5,DSTPK,NP,NC,MPCLS,PCLS,MICLS,ICLS,NCL,MP1,P) 00000875 C 00000876 C 00000877 IF(NSTMP.GE.2) CALL PRNTC2(0,NP,NC,MMST,IMST,MST,DU,NUMP, 00000878 1MPCLS,PCLS,MICLS,ICLS,NPMAX,NCL) 00000879 IF(NSTMP.GE.3) CALL PRNTNN(NP,NCL,NUMP,MP1,MP2,P) 00000880 C 00000881 C ............................ GRAPHIC .............. 00000882 C 00000883 IF(NSTMP.LT.5) GO TO 534 00000884 KGRAF=4 00000885 N=NP 00000886 WRITE(6,1111) 00000887 CALL COORD1(N,KGRAF,MP1,MP2,P,MDST,MDST,DST,MNX1,MNX2,NX,NPMAX,NUM00000888 1P,NCL) 00000889 CALL GRAF2(N,MNX1,MNX2,NX,MGR1,MGR2,AGRAF) 00000890 534 CONTINUE 00000891 C .....................STATISTICAL SUMMARY .................. 00000892 C 00000893 C 00000894 CALL MEMOR1(2,NSTMP,NP,NC,NPMAX,NQUAMX,NCL,MPCLS,PCLS, 00000895 1MICLS,ICLS,MDST,DST) 00000896 C 00000897 C 00000898 C 00000899 591 CONTINUE 00000900 51 CONTINUE 00000901 C **************** LOOP ON EVENTS ENDS HERE ******** 00000902 GO TO 100 00000903 506 CONTINUE 00000904 C 00000905 500 CONTINUE 00000906 WRITE(11,1000) NUMALG,NDIST,INEV 00000907 WRITE(6,1000) NUMALG,NDIST,INEV 00000908 1000 FORMAT(18H ALGORITM NUMBER:,I5,17H DISTANCE NUMBER:,I5, 00000909 117H TAPE1 POSITION :,I5) 00000910 C 00000911 C 00000912 C ...........................STATISTICAL SUMMARY .............. 00000913 CALL MEMOR1(3,NSTMP,NP,NC,NPMAX,NQUAMX,NCL,MPCLS,PCLS, 00000914 1MICLS,ICLS,MDST,DST) 00000915 C 00000916 C 00000917 STOP 00000918 END 00000919 SUBROUTINE MEMOR1(K,NSTMP,NP,NC,NPMX,NQMX,NCL,MPCLS,PCLS,MICLS,ICL00000920 1S,MDST,IDST) 00000921 C :*****************************************************************00000922 C STATISTICAL SUMMARY 00000923 C 00000924 C K=1 INITIALIZE 00000925 C K=2 SET VALUES 00000926 C K=3 PRINTING 00000927 C ******************************************************** 00000928 C 00000929 C 00000930 DIMENSION MEMT(20),MEM100(20),NCL(NPMX),PCLS(MPCLS,NQMX),ICLS(MICL00000931 1S,NQMX),IDST(MDST,MDST) 00000932 REAL MEM100 00000933 IF(K.NE.1) GO TO 100 00000934 REWIND 3 00000935 NW3=0 00000936 EMAX=0. 00000937 EMIN=10.E+30 00000938 NPMAX=1 00000939 NPMIN=100000000. 00000940 C 00000941 NCALL=0 00000942 MAX=20 00000943 DO 10 I=1,MAX 00000944 10 MEMT(I)=0 00000945 RETURN 00000946 100 CONTINUE 00000947 IF(K.NE.2) GO TO 200 00000948 NCALL=NCALL+1 00000949 C NUMBER OF EVENTS WITH NC JETS 00000950 N1=NC 00000951 IF(N1.GT.MAX) N1=MAX 00000952 IF(N1.LE.0) N1=1 00000953 MEMT(N1)=MEMT(N1)+1 00000954 C 00000955 IF(NC.LT.1) RETURN 00000956 NW3=NW3+1 00000957 DO 20 I=1,NC 00000958 IF(PCLS(4,I).GT.EMAX) EMAX=PCLS(4,I) 00000959 IF(PCLS(4,I).LT.EMIN) EMIN=PCLS(4,I) 00000960 IF(ICLS(1,I).GT.NPMAX) NPMAX=ICLS(1,I) 00000961 20 CONTINUE 00000962 WRITE(3) MPCLS,NC,((PCLS(J,JJ),J=1,MPCLS),JJ=1,NC), 00000963 1(ICLS(1,J),J=1,NC) 00000964 C 00000965 C 00000966 RETURN 00000967 200 CONTINUE 00000968 IF(NCALL.LE.0) GO TO 900 00000969 DO 90 I=1,MAX 00000970 90 MEM100(I)=100.0*MEMT(I)/NCALL 00000971 900 CONTINUE 00000972 WRITE(6,1000) NCALL 00000973 1000 FORMAT(//,28H NUMBER OF ANALIZED EVENTS: ,I10) 00000974 WRITE(6,2000) (J,MEMT(J),MEM100(J),J=1,MAX) 00000975 2000 FORMAT( 23H NUMBER OF EVENTS WITH ,I10,6H JETS , 00000976 112H RECOGNIZED=,I10, 00000977 120H CORRESPONDING TO ,F7.2,10H PER CENT ) 00000978 IF(NW3.LE.0) RETURN 00000979 WRITE(6,1000) NW3 00000980 REWIND 3 00000981 CALL NULL(MDST,MDST,IDST) 00000982 MD1=NPMAX 00000983 IF(MD1.GT.MDST) MD1=MDST 00000984 MD2=50 00000985 IF(MD2.GT.MDST) MD2=MDST 00000986 EINT=(EMAX-EMIN) 00000987 IF(EINT.LE.0) EINT=1. 00000988 DO 30 I=1,NW3 00000989 READ(3) MDUM,NC,((PCLS(J,JJ),J=1,MDUM),JJ=1,NC),(ICLS(1,J),J=1,NC)00000990 DO 40 II=1,NC 00000991 INDEX=ICLS(1,II) 00000992 IF(INDEX.GT.MD1) INDEX=MD1 00000993 IF(INDEX.LT.1) INDEX=1 00000994 IDST(1,INDEX)=IDST(1,INDEX)+1 00000995 INDEX=MD2*(PCLS(4,II)-EMIN)/EINT+1 00000996 IF(INDEX.GT.MD2) INDEX=MD2 00000997 IF(INDEX.LT.1) INDEX=1 00000998 IDST(2,INDEX)=IDST(2,INDEX)+1 00000999 40 CONTINUE 00001000 30 CONTINUE 00001001 C 00001002 WRITE(6,3000) 00001003 3000 FORMAT(//,39H MULTIPLICITY OF RECONSTRUCTED JETS ,//) 00001004 DO 50 I=1,MD1 00001005 WRITE(6,3001) I,IDST(1,I) 00001006 3001 FORMAT(15H JETS WITH : ,I10,14H PARTICLES = ,I10) 00001007 50 CONTINUE 00001008 WRITE(6,4000) 00001009 4000 FORMAT(//,15H ENERGY OF JETS ,/) 00001010 DO 60 I=1,MD2 00001011 E=EMIN+EINT*(I-1)/MD2 00001012 WRITE(6,4001) I,E,IDST(2,I) 00001013 4001 FORMAT(10H INTERVAL:,I10, 12H INF ENERGY:,E12.5, 17H NUMBER OF JE00001014 1TS: ,I10) 00001015 60 CONTINUE 00001016 C 00001017 C 00001018 RETURN 00001019 END 00001020 SUBROUTINE PRNTC2(K,NP,NC,MMST,IMST,MST,DU,NUMP,MPCLS,PCLS, 00001021 1MICLS,ICLS,MNCL,NCL) 00001022 C *************************************************************** 00001023 C 00001024 C PRINTS : 00001025 C K=1 PRINTS MST 00001026 C K=0 PRINTS RECONSTRUCTED JETS 00001027 C K=2 PRINTS TREE 00001028 C 00001029 C **************************************************************** 00001030 C 00001031 DIMENSION MST(MMST,NC),DU(NC),PCLS(MPCLS,NC),ICLS(MICLS,NC) 00001032 DIMENSION NCL(MNCL) 00001033 DIMENSION NUMP(MNCL) 00001034 COMMON /REC12/INEV,NPART,TITL,ECM,NVMX,NQUAI,NQUAMX 00001035 COMMON /PART/MP1,MP2,P(6,100) 00001036 DATA DUM,NDUM/0.0,0/ 00001037 IF(K.NE.1) GO TO 100 00001038 IF(IMST.LE.0) RETURN 00001039 WRITE(6,1000) 00001040 1000 FORMAT(//,20X,22H MINIMAL SPANNING TREE,//,4X, 00001041 187H NODE CONNECTED TO NODE , DISTANCE NODE BEL00001042 2ONGS TO CLUSTER ) 00001043 DO 10 I=1,IMST 00001044 10 WRITE(6,1010) I,MST(1,I),MST(2,I),DU(I),I,NCL(I) 00001045 1010 FORMAT(3X,1H=,I5,2H= ,I5,10X,I5,4X,E12.5,10X,I5,14X,I5) 00001046 N1=IMST+1 00001047 WRITE(6,1010) N1,(NDUM,J=1,2),DUM,N1,NCL(NP) 00001048 RETURN 00001049 100 CONTINUE 00001050 IF(K.NE.2) GO TO 200 00001051 C 00001052 C PRINT TREE 00001053 C 00001054 WRITE(6,2000) 00001055 2000 FORMAT(//,40X,10H T R E E ,//,9X, 00001056 14HEDGE,6X,33HPART CONNECTED TO PART, DISTANCE) 00001057 DO 20 I=1,IMST 00001058 WRITE(6,2010) I,NUMP(MST(1,I)),NUMP(IABS(MST(2,I))),DU(I) 00001059 20 CONTINUE 00001060 2010 FORMAT(5X,I7,5X,I7,9X,I7,5X,E12.5) 00001061 RETURN 00001062 200 CONTINUE 00001063 C 00001064 C 00001065 C 00001066 C PRINTS RECONSTRUCTED JETS 00001067 C 00001068 WRITE(6,9000) INEV,NPART,TITL,ECM,NVMX,NQUAI 00001069 9000 FORMAT(//,7X,13H EVENT NUMBER,I10,21H NUMBER OF PARTICLES:,I10, 00001070 17H TITLE:,A10,1X,E12.5,I10,16H NUMBER OF JETS:,I10) 00001071 WRITE(6,9010) NC,NP 00001072 9010 FORMAT(7X,18H JETS RECOGNIZED: ,5X,I7,23H, PARTICLES : ,I00001073 17) 00001074 IF(NC.LE.0) RETURN 00001075 DO 90 I=1,NC 00001076 90 WRITE(6,9015) I,ICLS(1,I),(PCLS(J,I),J=1,MPCLS) 00001077 9015 FORMAT(11H JET NUMBER,I7,10H PARTICLES,I7,9H MOMENTA:,(1X,4E12.5)00001078 1) 00001079 RETURN 00001080 END 00001081 SUBROUTINE PRNTD(NP,NW2,NPMAX,DST) 00001082 C ******************************* 00001083 C 00001084 C PRINTS DENDOGRAM ( ON TAPE 2) 00001085 C 00001086 C ******************************** 00001087 C 00001088 DIMENSION DST(NPMAX,NPMAX) 00001089 C 00001090 IF(NP.LE.0.OR.NW2.LE.0) RETURN 00001091 REWIND 2 00001092 C 00001093 DO 10 I=1,NW2 00001094 10 READ(2) (DST(J,I),J=1,NP) 00001095 WRITE(6,1003) 00001096 1003 FORMAT(//,12H DENDOGRAM ) 00001097 WRITE(6,2000) 00001098 2000 FORMAT(//,111H STEP : 1...2...3...4...5... AT EACH STEP THE PARTI00001099 1CLES IDENTIFYED BY THE SAME NUMBER ARE CLUSTERED TOGETHER ,/00001100 2,9H PARTICLE ) 00001101 J2M=0 00001102 15 J1M=J2M+1 00001103 J2M=J1M+29 00001104 IF(NW2.LT.J2M) J2M=NW2 00001105 DO 17 J=1,NP 00001106 17 WRITE(6,1005) J,(DST(J,JJ),JJ=J1M,J2M) 00001107 1005 FORMAT(1X,31I4) 00001108 IF(NW2.GT.J2M) GO TO 15 00001109 C 00001110 RETURN 00001111 END 00001112 SUBROUTINE INPTP1(NSTMP) 00001113 C ************************************************** 00001114 C 00001115 C READS MOMENTA OF PARTICLES FROM UNIT 1 00001116 C FILLS COMMON/REC12/ 00001117 C FILLS COMMON/PART/ 00001118 C FOR NSTMP>=2 PRINTS EVENT SPECIFICATIONS 00001119 C 00001120 C 00001121 C ############################################ 00001122 C 00001123 COMMON /REC12/INEV,NPART,TITL,ECM,NVMX,NQUA,NQUAMX 00001124 COMMON /PART/ M1,M2,P(6,400) 00001125 C 00001126 100 CONTINUE 00001127 C 00001128 READ(1)INEV,NQUA,NPART,ECM,TITL,NVMX 00001129 IF(NPART.LE.M2.AND.NQUA.LE.NQUAMX) GO TO 200 00001130 READ(1) A 00001131 4000 FORMAT(21H I SKIP EVENT NUMBER:,I10,34H THAT IS TOO LARGE,WITH PA00001132 1RTICLES:,I10,11H AND JETS:,I10) 00001133 WRITE(11,4000) INEV,NPART,NQUA 00001134 WRITE(6,4000) INEV,NPART,NQUA 00001135 GO TO 100 00001136 200 CONTINUE 00001137 IF(NSTMP.GE.2) WRITE(6,1000) INEV,NQUA,NPART,TITL,ECM,NVMX 00001138 READ(1)((P(JJ,J),JJ=1,6),J=1,NPART) 00001139 1000 FORMAT(//,30H1READ FROM TAPE1 EVENT NUMBER:,I10, 00001140 116H NUMBER OF JETS:,I10,21H NUMBER OF PARTICLES:,I10, 00001141 2/,18H TITLES OF TAPE1: ,A10,5X,E12.5,5X,I5,5X,I5) 00001142 IF(NSTMP.GT.20)WRITE(6,2000) (J,(P(JJ,J),JJ=1,6 ),J=1,NPART) 00001143 2000 FORMAT(10H PART NUM=,I4,4H PX:,E12.5,5H PY:,E12.5,5H PZ:, 00001144 1E12.5,5H E:,E12.5,5H MASS,E12.5,5X,A10) 00001145 RETURN 00001146 END 00001147 FUNCTION DISTF2(KT,DSTPK,PK,PL) 00001148 C ********************************************** 00001149 C 00001150 C COMPUTES DISTANCES 00001151 C 00001152 DIMENSION PK(4),PL(4) 00001153 C 00001154 DATA PI/3.14159265/ 00001155 GO TO(100,200,300,400,500,600,700),KT 00001156 100 CONTINUE 00001157 C ++++++++++++++++ DISTANCE THETA**2/(/PL/*/PK/) +++ 00001158 QUADL=(PL(1)**2+PL(2)**2+PL(3)**2) 00001159 QUADK=(PK(1)**2+PK(2)**2+PK(3)**2) 00001160 SCKI=PK(1)*PL(1)+PK(2)*PL(2)+PK(3)*PL(3) 00001161 SQQ=SQRT(QUADL*QUADK) 00001162 IF(SQQ.EQ.0) GO TO 999 00001163 COSPP=SCKI/SQQ 00001164 IF(COSPP.GT.1) COSPP=1. 00001165 IF(COSPP.LT.-1) COSPP=-1. 00001166 DISTF2=(ACOS(COSPP))**2/SQQ 00001167 RETURN 00001168 200 CONTINUE 00001169 C +++++++++++++++++ DISTANCE THETA**2 ++++++++++++++ 00001170 QUADL=(PL(1)**2+PL(2)**2+PL(3)**2) 00001171 QUADK=(PK(1)**2+PK(2)**2+PK(3)**2) 00001172 SCKI=PK(1)*PL(1)+PK(2)*PL(2)+PK(3)*PL(3) 00001173 SQQ=SQRT(QUADL*QUADK) 00001174 IF(SQQ.EQ.0) GO TO 999 00001175 COSPP=SCKI/SQQ 00001176 IF(COSPP.GT.1) COSPP=1. 00001177 IF(COSPP.LT.-1) COSPP=-1. 00001178 DISTF2=(ACOS(COSPP))**2 00001179 RETURN 00001180 300 CONTINUE 00001181 C ++++++++++++++ DISTANCE /THETA/ ++++++++++++++++++ 00001182 QUADL=(PL(1)**2+PL(2)**2+PL(3)**2) 00001183 QUADK=(PK(1)**2+PK(2)**2+PK(3)**2) 00001184 SCKI=PK(1)*PL(1)+PK(2)*PL(2)+PK(3)*PL(3) 00001185 SQQ=SQRT(QUADL*QUADK) 00001186 COSPP=SCKI/SQQ 00001187 IF(SQQ.EQ.0) GO TO 999 00001188 IF(COSPP.GT.1) COSPP=1. 00001189 IF(COSPP.LT.-1) COSPP=-1. 00001190 DISTF2=ACOS(COSPP) 00001191 RETURN 00001192 400 CONTINUE 00001193 500 CONTINUE 00001194 C +++++++++++++++++++++ DISTANCE P( MIN ) *SIN(THETA) 00001195 C +++++++++++++ ADD 1 TO SEN(THETA) IF THETA>2PI 00001196 C 00001197 QUADL=(PL(1)**2+PL(2)**2+PL(3)**2) 00001198 QUADK=(PK(1)**2+PK(2)**2+PK(3)**2) 00001199 SCKI=PK(1)*PL(1)+PK(2)*PL(2)+PK(3)*PL(3) 00001200 SQQ=SQRT(QUADL*QUADK) 00001201 IF(SQQ.EQ.0) GO TO 999 00001202 COSPP=SCKI/SQQ 00001203 IF(COSPP.GT.1) COSPP=1. 00001204 IF(COSPP.LT.-1) COSPP=-1. 00001205 THETA=ACOS(COSPP) 00001206 SINTH=SIN(THETA) 00001207 IF(THETA.GT.PI/2.) SINTH=SINTH+1 00001208 DISTF2=SQRT(AMIN1(QUADL,QUADK))*SINTH 00001209 RETURN 00001210 600 CONTINUE 00001211 C ++++++++++++++++++++++ DISTANCE THETA*P(I)*P(K) 00001212 C 00001213 QUADL=(PL(1)**2+PL(2)**2+PL(3)**2) 00001214 QUADK=(PK(1)**2+PK(2)**2+PK(3)**2) 00001215 SCKI=PK(1)*PL(1)+PK(2)*PL(2)+PK(3)*PL(3) 00001216 SQQ=SQRT(QUADL*QUADK) 00001217 IF(SQQ.EQ.0) GO TO 999 00001218 COSPP=SCKI/SQQ 00001219 IF(COSPP.GT.1) COSPP=1. 00001220 IF(COSPP.LT.-1) COSPP=-1. 00001221 DISTF2=ACOS(COSPP) 00001222 DISTF2=SQQ*DISTF2 00001223 RETURN 00001224 C 00001225 700 CONTINUE 00001226 RETURN 00001227 999 CONTINUE 00001228 WRITE(6,1000) PL(1),PL(2),PL(3),QUADL,PK(1),PK(2),PK(3),QUADK 00001229 1000 FORMAT(52H !!!!! WARNING !!!! FOUND /P/=0 IN SUBROUTINE DISTF2 , 00001230 1 /,2(4H P=,3E12.5,6H /P/= ,E12.5)) 00001231 RETURN 00001232 END 00001233 SUBROUTINE INPTKI(NPAR,NDEF,PROMP) 00001234 C ******************************************* 00001235 C 00001236 C 00001237 C READ INTEGER PARAMETER NPAR FROM TAPE 5 00001238 C IF ZERO ASSUMES THE DEFAULT : NDEF 00001239 C PROMPTS FOR IMPUT (PRINTS PROMP ON TAPE 11 ) 00001240 C 00001241 C <<<,,,,,,,, ONLY FOR IBM:: 00001242 REAL*8 PROMP 00001243 C 00001244 WRITE(11,1000) PROMP 00001245 1000 FORMAT(22H ENTER PARAMETER : ,A10) 00001246 READ(5,2000) A 00001247 2000 FORMAT(E 40.0) 00001248 NPAR=A 00001249 IF(NPAR.EQ.0) NPAR=NDEF 00001250 WRITE(11,3000) PROMP,NPAR,NDEF 00001251 WRITE(6,3000) PROMP,NPAR,NDEF 00001252 3000 FORMAT(17H READ PARAMETER: ,A10,2X,I5,9H DEFAULT: ,I5) 00001253 RETURN 00001254 END 00001255 SUBROUTINE INPTKR(PAR,DEF,PROMP) 00001256 C ********************************************: 00001257 C 00001258 C 00001259 C READS REAL PARAMETER PAR FROM UNIT 5 E40.0 00001260 C IF 0.>=PAR>1.E-40 SET PAR=DEF 00001261 C PRINTS PROMP ON UNIT 11 00001262 C 00001263 C <<<<<,,,,,,, ONLY FOR IBM:: 00001264 REAL*8 PROMP 00001265 C 00001266 WRITE(11,1000) PROMP 00001267 1000 FORMAT(22H ENTER PARAMETER : ,A10) 00001268 READ(5,2000) PAR 00001269 2000 FORMAT(E40.0) 00001270 IF(PAR.GE.0..AND.PAR.LT.1.E-40) PAR=DEF 00001271 WRITE(11,3000) PROMP,PAR,DEF 00001272 WRITE(6,3000) PROMP,PAR,DEF 00001273 3000 FORMAT(17H READ PARAMETER : ,A10,2X,E12.5,9H DEFAULT:,E12.5) 00001274 RETURN 00001275 END 00001276 SUBROUTINE EMPNUM(M1,N) 00001277 C ********************************** 00001278 C 00001279 C FILLS N(M1) WITH NUMBERS : 1,2,3, , ... ,M1 00001280 C 00001281 DIMENSION N(M1) 00001282 DO 10 I=1,M1 00001283 10 N(I)=I 00001284 RETURN 00001285 END 00001286 SUBROUTINE PRNT1(K,A,N,M,B) 00001287 C ******************************************* 00001288 C PRINTS MATRIX A(N,M) FORMAT K,TITLE B 00001289 DIMENSION A(N,M) 00001290 WRITE(6,2000) B 00001291 DO 10 I=1,M 00001292 IF(K.EQ.0) WRITE(6,1000)I,(A(J,I),J=1,N) 00001293 IF(K.EQ.1) WRITE(6,3000)I,(A(J,I),J=1,N) 00001294 1000 FORMAT(5H =COL,I3,2H =,(1X,10E12.5)) 00001295 10 CONTINUE 00001296 2000 FORMAT(1X,A10) 00001297 3000 FORMAT(5H =COL,I3,2H =,(1X,10I10)) 00001298 RETURN 00001299 END 00001300 SUBROUTINE CUTPJ1(K,KK,NSTMP,CUTP,NQUA,NP,MP1,MP2,P,MMJ,MLTJ,M7,NU00001301 1MP,MPJ1,MPJ2,PJ) 00001302 C *********************************************************** 00001303 C 00001304 C DELETE PARTICLES WITH P(K,I) < CUTP, 00001305 C 00001306 C FOR KK < 1 DELETE PARTICLES WITH P(K,I)>CUTPU 00001307 C 00001308 C ***************************************************** 00001309 C 00001310 DIMENSION P(MP1,MP2),MLTJ(MMJ),NUMP(M7),PJ(MPJ1,MPJ2) 00001311 I=0 00001312 10 I=I+1 00001313 11 IF(I.GT.NP) RETURN 00001314 IF(KK*P(K,I).GE.KK*CUTP) GO TO 10 00001315 C ........................... DELETE PARTICLE 00001316 CALL DEST(MP1,NP,I,I,P) 00001317 CALL DEST(1,NP,I,I,NUMP) 00001318 NP=NP-1 00001319 GO TO 11 00001320 END 00001321 SUBROUTINE DMTOM1(KTIPD,DSTPK,MP1,MP2,P,N,MS2,IMST,MST,CST,M1,UI,J00001322 1I,NIT,DU) 00001323 C ************************************************************** 00001324 C 00001325 C KEWIN,WHITNEY- ALGORITM 422, COMM ACM 15, 273 (1972) 00001326 C MAKES MINIMAL SPANNING TREE (MST) 00001327 C 00001328 DIMENSION P(MP1,MP2),MST(MS2,N),UI(M1),JI(M1) 00001329 DIMENSION NIT(M1),DU(M1) 00001330 CST=0. 00001331 NITP=N-1 00001332 KP=N 00001333 IMST=0 00001334 DO 100 I=1,NITP 00001335 NIT(I)=I 00001336 UI(I)=DISTF2(KTIPD,DSTPK,P(1,I),P(1,KP)) 00001337 100 JI(I)=KP 00001338 200 DO300 I=1,NITP 00001339 NI=NIT(I) 00001340 D=DISTF2(KTIPD,DSTPK,P(1,NI),P(1,KP)) 00001341 IF(UI(I).LE.D) GOTO 300 00001342 UI(I)=D 00001343 JI(I)=KP 00001344 300 CONTINUE 00001345 UK=UI(1) 00001346 DO 400 I=1,NITP 00001347 IF(UI(I).GT.UK) GOTO 400 00001348 UK=UI(I) 00001349 K=I 00001350 400 CONTINUE 00001351 IMST=IMST+1 00001352 MST(1,IMST)=NIT(K) 00001353 MST(2,IMST)=JI(K) 00001354 CST=CST+UK 00001355 KP=NIT(K) 00001356 DU(IMST)=UI(K) 00001357 UI(K)=UI(NITP) 00001358 NIT(K)=NIT(NITP) 00001359 JI(K)=JI(NITP) 00001360 NITP=NITP-1 00001361 500 IF(NITP.NE.0) GOTO 200 00001362 RETURN 00001363 END 00001364 SUBROUTINE SPZMST(DMST,MST1,IMST,MST,M1,IAUS,MDU1,DU) 00001365 C ********************************************************** 00001366 C 00001367 C CUTS MST 00001368 C 00001369 DIMENSION MST(MST1,IMST),IAUS(M1),DU(MDU1) 00001370 D=DMED(IMST,MDU1,DU,M1,IAUS)*DMST 00001371 DO 10 I=1,IMST 00001372 IF(D.LE.DU(I)) MST(2,I)=-MST(2,I) 00001373 10 CONTINUE 00001374 RETURN 00001375 END 00001376 SUBROUTINE CLSMST(N,NC,MST1,IMST,MST,MNCL,NCL,MP1,MP2,PCLS,M3,M4,I00001377 1CLS,MPZ1,MPZ2,P) 00001378 C ******************************************************************00001379 C 00001380 C MAKES CLUSTERS FROM MST 00001381 C DEFINES: PCLS( 00001382 C ICLS ( 00001383 C NCL( 00001384 C 00001385 C 00001386 DIMENSION MST(MST1,IMST),NCL(MNCL),PCLS(MP1,MP2),ICLS(M3,M4) 00001387 DIMENSION P(MPZ1,MPZ2) 00001388 C INITIALIZE NCL(N) FOR EACH NODE NC=NUMBER OF CLUSTER 00001389 DO 60 I=1,N 00001390 60 NCL(I)=0 00001391 NC=0 00001392 C MAKES CLUSTERS, NCL,PCLS,ICLS 00001393 C 11111111111 LOOP ON MST 00001394 DO 70 I=1,IMST 00001395 IF(MST(2,I).LT.0) GOTO 300 00001396 C THE NODE IS NOT CONNECTED ( GOES ON ) 00001397 IF(NCL(MST(2,I)).GT.0) GOTO 200 00001398 C THE NODE IS CONNECTED TO AN EXISTING CLUSTER 00001399 C DEFINES A NEW CLUSTER WITH THE NODE BEING PROCESSED 00001400 NC=NC+1 00001401 NCL(MST(2,I))=NC 00001402 DO 75 IJ=1,4 00001403 75 PCLS(IJ,NC)=P(IJ,MST(2,I)) 00001404 ICLS(1,NC)=1 00001405 C ADD TO THE CLUSTER THE NODE 00001406 200 NCL(MST(1,I))=NCL(MST(2,I)) 00001407 DO 77 IJ=1,4 00001408 77 PCLS(IJ,NCL(MST(1,I)))=PCLS(IJ,NCL(MST(1,I)))+P(IJ,MST(1,I)) 00001409 ICLS(1,NCL(MST(1,I)))=ICLS(1,NCL(MST(1,I)))+1 00001410 300 CONTINUE 00001411 70 CONTINUE 00001412 RETURN 00001413 END 00001414 SUBROUTINE ESMC2(NC,N,NMIN,EMIN,COSMIN,MPC1,MPC2,PCLS,MNCL,NCL, 00001415 1MP1,MP2,P,MICL1,MICL2,ICLS) 00001416 C ************************************************************ 00001417 C 00001418 C TEST CLUSTERS 00001419 C 00001420 C ****************************************************** 00001421 C 00001422 DIMENSION PCLS(MPC1,MPC2),NCL(MNCL),P(MP1,MP2),ICLS(MICL1,MICL2) 00001423 IF(N.LE.0) RETURN 00001424 IF(NC.LE.0) RETURN 00001425 C RENUMBER ACCEPTED CLUSTERS 00001426 NC1=0 00001427 DO 10 I=1,NC 00001428 IF(PCLS(4,I).LT.EMIN.OR.ICLS(1,I).LT.NMIN) GOTO 100 00001429 NC1=NC1+1 00001430 ICLS(2,I)=NC1 00001431 GO TO 10 00001432 100 ICLS(2,I)=O 00001433 10 CONTINUE 00001434 C RECOMPUTES NCL 00001435 DO 20 I=1,N 00001436 IF(NCL(I).GT.0) NCL(I)=ICLS(2,NCL(I)) 00001437 20 CONTINUE 00001438 C RECOMPUTES ICLS(1,) = NUMBER OF NODES OF THE CLUSTER 00001439 DO 30 I=1,NC 00001440 IF(ICLS(2,I).LE.0) GOTO 200 00001441 ICLS(1,ICLS(2,I))=ICLS(1,I) 00001442 C RECOMPUTES PCLS 00001443 DO 40 J1=1,4 00001444 40 PCLS(J1,ICLS(2,I))=PCLS(J1,I) 00001445 200 CONTINUE 00001446 30 CONTINUE 00001447 C NC IS THE NEW CLUSTER 00001448 NC=NC1 00001449 IF(NC.LE.0) RETURN 00001450 C ASSIGN PARTICLES TO REMAININGS CLUSTERS 00001451 COSMI1=1-COSMIN 00001452 DO 50 I=1,N 00001453 IF(NCL(I).GT.0) GOTO 300 00001454 C LOOKS FOR THE NEAREST CLUSTER 00001455 D=10.E30 00001456 DO 60 IJ=1,NC 00001457 DD=DISTF2(5,DSTPK,P(1,I),PCLS(1,IJ)) 00001458 IF(DD.GT.D) GOTO 60 00001459 D=DD 00001460 K=IJ 00001461 60 CONTINUE 00001462 NCL(I)=K 00001463 ICLS(1,K)=ICLS(1,K)+1 00001464 DO 70 I2=1,4 00001465 70 PCLS(I2,K)=PCLS(I2,K)+P(I2,I) 00001466 300 CONTINUE 00001467 50 CONTINUE 00001468 RETURN 00001469 END 00001470 SUBROUTINE COORD1(NP,K,MP1,MP2,P,MX1,MX2,X,MNX1,MNX2,NX,MNMP,NUMP,00001471 1NCL) 00001472 C ******************* 00001473 C 00001474 C COMPUTES THE COORDINATES OF THE GRAPHIC 00001475 C 00001476 C ***************************************************************** 00001477 C 00001478 DIMENSION P(MP1,MP2),X(MX1,MX2),NX(MNX1,MNX2),NUMP(MNMP) 00001479 DIMENSION NCL(MNMP) 00001480 DATA PI/3.14159265/ 00001481 C O K--2 (NUM PART) 00001482 IF(NP.LT.1) GO TO 555 00001483 IF(K.NE.2.AND.K.NE.4) K=4 00001484 C FIX RANGES 00001485 C ++++++++++++++++++ THETA FHI*SEN(THETA) +++++ 00001486 LY12=0 00001487 LX12=51 00001488 DNT21X=100/(2*PI) 00001489 DNT21Y=50/PI 00001490 C COORDINATES 00001491 C X(1,.)=X =FHI*SEN(THETA) 00001492 C X(2,.)=Y = (THETA) 00001493 C X(3,I)= COD =QUARK=NCL(.) 00001494 C X(4,.)=NUM=E 00001495 C FOR K=2: X(3,I)=E (CODICE) 00001496 C FOR K=2: X(4,I)=NUMP (NUMERO) 00001497 C E IS MULTIPLIED BY 10 00001498 C 00001499 C +++++++++++++++++++++++ THETA - FHI *SEN(THETA) ++++++++ 00001500 DO 50 I=1,NP 00001501 AMD= P(1,I)**2+P(2,I)**2+P(3,I)**2 00001502 AMD=SQRT(AMD) 00001503 X(2,I)=ACOS(P(3,I)/AMD) 00001504 XX=ABS(SIN(X(2,I))) 00001505 X(1,I)=XX*ACOS(P(1,I)/AMD) 00001506 IF (P(2,I).LT.0.) X(1,I)=-X(1,I) 00001507 X(3,I)=NCL(I) 00001508 X(4,I)=P(4,I)*10. 00001509 IF(K.NE.2) GO TO 100 00001510 X(3,I)=P(4,I)*10. 00001511 X(4,I)=NUMP(I) 00001512 100 CONTINUE 00001513 50 CONTINUE 00001514 C +++++++++++++++++++++ COORDINATES +++++++++ 00001515 C NX(1,.)=X(4,.) NUMBER (E)OR NUMP IF K=2 00001516 C NX(2,.)=X(1,.) TRASF LIN (COORD X ) 00001517 C NX(3,.)=X(2,.) TRASF LIN(COORD Y ) 00001518 C NX(4,.)=X(3,.) CODE (JET)OR E IF K=2 00001519 DO 10 I=1,NP 00001520 NX(1,I)=X(4,I) 00001521 NX(2,I)=LX12+DNT21X*X(1,I) 00001522 NX(3,I)=LY12+DNT21Y*X(2,I) 00001523 NX(4,I)=X(3,I) 00001524 10 CONTINUE 00001525 C ++++++++++++++++++++++ AXES OF THE GRAPHIC +++++++++++ 00001526 C +++++++++++++++++++++++ THETA - FHI *SEN(THETA) ++++++++ 00001527 N1=NP +1 00001528 NPP=NP+80 00001529 DO 55 I=N1,NPP 00001530 NX(1,I)=0. 00001531 NX(3,I)=(I-NP)/2+5 00001532 NX(4,I)=100 00001533 NX(2,I)=LX12+PI*DNT21X*ABS(SIN(NX(3,I)/DNT21Y))*(-1)**I 00001534 55 CONTINUE 00001535 NP=NPP 00001536 555 CONTINUE 00001537 RETURN 00001538 END 00001539 C 00001540 SUBROUTINE GRAF2(NP,MNX1,MNX2,NX,MA1,MA2,A) 00001541 C ************************************ 00001542 C 00001543 C GRAPHIC PRINTS A(MA1,MA2) WITH IN POSIZ. NX(2, ) 00001544 C NX(3,.) CHARACTER SPECIFIED BY THE NUMBER NX(4,.) 00001545 C PRECEEDED BY THE NUMBER NX(1,.) 00001546 C 00001547 C 00001548 C ************************************************************** 00001549 C 00001550 DIMENSION NX(MNX1,MNX2),A(MA1,MA2) 00001551 DIMENSION CH1(28),CH2(10) 00001552 DATA CH1/4HAAAA,4HBBBB,4HCCCC,4HDDDD,4HEEEE,4HFFFF, 00001553 14HGGGG,4HHHHH,4HIIII,4HJJJJ,4HKKKK,4HLLLL,4HMMMM,4HNNNN, 00001554 24HOOOO,4HPPPP,4HQQQQ,4HRRRR,4HSSSS,4HTTTT,4HUUUU,4HVVVV, 00001555 34HWWWW,4HXXXX,4HYYYY,4HZZZZ,4H$$$$,4H****/ 00001556 DATA CH2/4H0000,4H1111,4H2222,4H3333,4H4444,4H5555, 00001557 14H6666,4H7777,4H8888,4H9999/ 00001558 DATA BIANC/4H / 00001559 C . PRECEEDING INSTRUCTION IS FOR IBM 00001560 C DATA BIANC/10H / 00001561 NCHMX=28 00001562 MA12=MA1*MA2 00001563 CALL RIEMP(BIANC,MA12,A) 00001564 DO 10 I=1,NP 00001565 LA1=NX(2,I) 00001566 LA2=NX(3,I) 00001567 IF(LA1.LT.1) LA1=1 00001568 IF(LA2.LT.1) LA2=1 00001569 IF(LA1.GT.MA1) LA1=MA1 00001570 IF(LA2.GT.MA2) LA2=MA2 00001571 IF(NX(4,I).GT.NCHMX) NX(4,I)=NCHMX 00001572 IF(NX(4,I).LE.0) NX(4,I)=1 00001573 98 IF(A(LA1,LA2).EQ.BIANC) GO TO 101 00001574 C ..............LOOKS FOR THE FIRST BLANK TO THE RIGHT 00001575 49 ILA1=LA1 00001576 51 ILA1=ILA1+1 00001577 IF(ILA1.GE.MA1) GO TO 101 00001578 IF(A(ILA1,LA2).NE.BIANC) GO TO 51 00001579 ILLA1=LA1 00001580 52 ILLA1=ILLA1-1 00001581 IF(ILLA1.LE.1) GOTO101 00001582 IF(A(ILLA1,LA2).EQ.BIANC) GO TO 102 00001583 GO TO 52 00001584 102 CONTINUE 00001585 20 CONTINUE 00001586 A(ILA1,LA2)=A(ILA1-1,LA2) 00001587 ILA1=ILA1-1 00001588 IF(ILA1.LE.1) GO TO 101 00001589 IF(ILA1.LE.ILLA1) GO TO 99 00001590 GO TO 20 00001591 99 CONTINUE 00001592 GOTO 98 00001593 101 A(LA1,LA2)=CH1(NX(4,I)) 00001594 IF(NX(1,I).LT.0) NX(1,I)=0 00001595 M1=NX(1,I) 00001596 100 M2=M1/10 00001597 MC=M1-M2*10 00001598 LA1=LA1-1 00001599 IF(LA1.LT.1) GO TO 200 00001600 IF(A(LA1,LA2).EQ.BIANC) GO TO 201 00001601 ILA1=LA1 00001602 61 ILA1=ILA1+1 00001603 IF(ILA1.GE.MA1) GO TO 201 00001604 IF(A(ILA1,LA2).NE.BIANC) GO TO 61 00001605 LA1=LA1+1 00001606 C 00001607 30 CONTINUE 00001608 A(ILA1,LA2)=A(ILA1-1,LA2) 00001609 ILA1=ILA1-1 00001610 IF(ILA1.LE.1) GO TO 201 00001611 IF(ILA1.LE.LA1) GO TO 201 00001612 GO TO 30 00001613 201 A(LA1,LA2)=CH2(MC+1) 00001614 M1=M2 00001615 IF(M2.GT.0) GO TO 100 00001616 200 CONTINUE 00001617 10 CONTINUE 00001618 WRITE(6,1500)(((CH2(J),J=2,10),CH2(1)),JJ=1,10) 00001619 1500 FORMAT(3X,130A1) 00001620 DO 50 I=1,MA2 00001621 I26=I-26 00001622 WRITE(6,2000) I26,(A(J,I),J=1,MA1) 00001623 2000 FORMAT(1X,I3,130A1,1H+) 00001624 50 CONTINUE 00001625 WRITE(6,1500)(((CH2(J),J=2,10),CH2(1)),JJ=1,10) 00001626 RETURN 00001627 END 00001628 SUBROUTINE DIST3(NSTMP,NP,KT,DSTPK,MP1,MP2,P,MDST,DST) 00001629 C ************************************************ 00001630 C 00001631 C FILLS THE MATRIX DST(NP,NP) 00001632 C 00001633 DIMENSION P(MP1,MP2),DST(MDST,MDST) 00001634 C 00001635 DO 10 I=2,NP 00001636 I1=I-1 00001637 DO 10 II=1,I1 00001638 DST(II,I)=DISTF2(KT,DSTPK,P(1,II),P(1,I)) 00001639 10 CONTINUE 00001640 IF(NSTMP.LT.30) GO TO 100 00001641 WRITE(6,1000) 00001642 DO 20 I=2,NP 00001643 I1=I-1 00001644 WRITE(6,2000) (I,(DST(II,I),II=1,I1)) 00001645 1000 FORMAT(//,35H DISTANCE MATRIX:DST(II,I),II=1,I-1 ) 00001646 2000 FORMAT(5H COL:,I3,3H = ,(1X,10E12.5)) 00001647 20 CONTINUE 00001648 100 CONTINUE 00001649 RETURN 00001650 END 00001651 SUBROUTINE DSTMN(N,M1,DST,K,L,A) 00001652 C *********************************** 00001653 DIMENSION DST(M1,M1) 00001654 C LOOKS FORT THE MINIMUM DISTANCE IN DST 00001655 K=N+1 00001656 L=N+1 00001657 A=999E+40 00001658 DO 10 I=1,N 00001659 I1=I+1 00001660 IF(I1.GT.N) GO TO 10 00001661 DO 20 II=I1,N 00001662 IF(DST(I,II).GE.A) GO TO 100 00001663 A=DST(I,II) 00001664 K=I 00001665 L=II 00001666 100 CONTINUE 00001667 20 CONTINUE 00001668 10 CONTINUE 00001669 RETURN 00001670 END 00001671 SUBROUTINE COMB2(NP,K,L,N,M4,P1,M2,NP1,M,NCL) 00001672 C ******************************************** 00001673 C 00001674 C MIX ROWS IN THE MATRIX P1 00001675 C 00001676 C 00001677 C *********************************************** 00001678 C 00001679 DIMENSION P1(M4,N),NP1(M2,N),NCL(M) 00001680 DO 10 I=1,M4 00001681 B=P1(I,L) 00001682 P1(I,K)=P1(I,K)+B 00001683 P1(I,L)=P1(I,N) 00001684 P1(I,N)=B 00001685 10 CONTINUE 00001686 C 00001687 IF(NCL(NP1(1,K)).LE.0) NCL(NP1(1,K))=NP1(1,K)+NP 00001688 NDISTR=NCL(NP1(1,L)) 00001689 NCL(NP1(1,L))=NCL(NP1(1,K)) 00001690 NP1(2,N)=NP1(1,K) 00001691 NB=NP1(1,L) 00001692 NP1(1,L)=NP1(1,N) 00001693 NP1(1,N)=NB 00001694 IF(NDISTR.LE.0) RETURN 00001695 DO 20 I=1,M 00001696 IF(NCL(I).EQ.NDISTR) NCL(I)=NCL(NP1(1,K)) 00001697 20 CONTINUE 00001698 RETURN 00001699 END 00001700 C 00001701 SUBROUTINE CAMBD1(KT,DKT,L,K,N,M1,A,M,M2,P) 00001702 C ****************************************** 00001703 DIMENSION A(M1,M1),P(M,M2) 00001704 C 00001705 L1=L-1 00001706 IF(L1.LE.0) GO TO 100 00001707 DO 10 I=1,L1 00001708 10 A(I,L)=A(I,N) 00001709 100 CONTINUE 00001710 L1=L+1 00001711 N1=N-1 00001712 IF(N1-L1.LT.0) GO TO 200 00001713 DO 20 I=L1,N1 00001714 20 A(L,I)=A(I,N) 00001715 200 CONTINUE 00001716 K1=K-1 00001717 IF(K1.LE.0) GO TO 300 00001718 DO 30 I=1,K1 00001719 30 A(I,K)=DISTF2(KT,DKT,P(1,I),P(1,K)) 00001720 300 CONTINUE 00001721 K1=K+1 00001722 N1=N-1 00001723 IF(N1-K1.LT.0) GO TO 400 00001724 DO 40 I=K1,N1 00001725 40 A(K,I)=DISTF2(KT,DKT,P(1,I),P(1,K)) 00001726 400 CONTINUE 00001727 RETURN 00001728 END 00001729 SUBROUTINE CLUST3(NP,NC,NCL,NCL1,MP1,P,MPC4,MPC,PCLS,MPC2,ICLS) 00001730 C ***************************************************** 00001731 C 00001732 C MAKES CLUSTERS FROM NCL 00001733 C DEFINES COMMON /PCLS/ AND NC 00001734 C ›!!!!!!!!!!! NCL1 MUST BE 2*NP (SUBROUTINE COMB) 00001735 C 00001736 C ****************************** 00001737 C 00001738 DIMENSION NCL(NP),NCL1(NP),P(MP1,NP),PCLS(MPC4,MPC),ICLS(MPC2,MPC)00001739 NP2=NP*2 00001740 DO 10 I=1,NP2 00001741 10 NCL1(I)=NP+2 00001742 C ORDER NCL 00001743 NC=0 00001744 DO 20 I=1,NP 00001745 IF(NCL(I).LE.0) GO TO 20 00001746 IF(NCL1(NCL(I)).LE.NC) GO TO 100 00001747 NC=NC+1 00001748 NCL1(NCL(I))=NC 00001749 100 NCL(I)=NCL1(NCL(I)) 00001750 20 CONTINUE 00001751 C COMPUTES PCLS,ICLS 00001752 IF(NC.EQ.0) RETURN 00001753 DO 30 I=1,NC 00001754 ICLS(1,I)=0 00001755 DO 30 IJ=1,4 00001756 30 PCLS(IJ,I)=0. 00001757 DO 40 I=1,NP 00001758 N1=NCL(I) 00001759 IF(N1.LE.0) GO TO 140 00001760 PCLS(1,N1)=PCLS(1,N1)+P(1,I) 00001761 PCLS(2,N1)=PCLS(2,N1)+P(2,I) 00001762 PCLS(3,N1)=PCLS(3,N1)+P(3,I) 00001763 PCLS(4,N1)=PCLS(4,N1)+P(4,I) 00001764 ICLS(1,N1)=ICLS(1,N1)+1 00001765 140 CONTINUE 00001766 40 CONTINUE 00001767 RETURN 00001768 END 00001769 SUBROUTINE ORDP(NP,MP1,MP2,P,MNP,NPOS) 00001770 C ***************************************** 00001771 C 00001772 C ORDER THE PARTICLES FOR DECREASING ENERGY (P (4, .) 00001773 C 00001774 DIMENSION P(MP1,MP2),NPOS(MNP) 00001775 C 00001776 C ***************** # 30 30 30 30 30 30 30 30 *************00001777 N1=1 00001778 30 IF(N1.GE.NP) RETURN 00001779 C 00001780 C ............LOOKS FOR THE MOST ENERGETIC ONE 00001781 PMX=P(4,N1) 00001782 K=N1 00001783 DO 10 I=N1,NP 00001784 IF(P(4,I).LE.PMX) GO TO 100 00001785 K=I 00001786 PMX=P(4,K) 00001787 100 CONTINUE 00001788 10 CONTINUE 00001789 C ..................... EXCHANGE PART K (E MAX) WITH N1 00001790 DO 20 I=1,MP1 00001791 DUM=P(I,K) 00001792 P(I,K)=P(I,N1) 00001793 P(I,N1)=DUM 00001794 20 CONTINUE 00001795 C .......................... EXCHANGE COORD OF K AND N1 00001796 NDUM=NPOS(K) 00001797 NPOS(K)=NPOS(N1) 00001798 NPOS(N1)=NDUM 00001799 C ....................... REDUCE N1 AND GO ON 00001800 N1=N1+1 00001801 GO TO 30 00001802 C ********************* 30 30 END OF LOOP 30 ****** 00001803 C 00001804 END 00001805 SUBROUTINE TREE1(NP,IMST,KD,DPK,MST1,MST2,MST,MD,D,MP1,MP2,P) 00001806 C **************************************************************** 00001807 C 00001808 C MAKES A TREE Ä 00001809 C 00001810 DIMENSION MST(MST1,MST2),D(MD),P(MP1,MP2) 00001811 C INIZIALIZZA MST 00001812 IMST=1 00001813 K=1 00001814 MST(1,1)=2 00001815 MST(2,1)=1 00001816 D(1)=DISTF2(KD,DPK,P(1,2),P(1,1)) 00001817 C ........................... LOOP ON PARTICLES TO ADD 00001818 C *********************** 10 10 10 10 10 10 10 ************00001819 C 00001820 DO 10 I=3,NP 00001821 DMX=DISTF2(KD,DPK,P(1,I),P(1,1)) 00001822 K=1 00001823 C ...................... LOOP ON ADDED PARTICLES 00001824 C LOOKS FOR THE NEAREST ONE 00001825 C *********************** # 20 20 20 20 20 20 20 **************** 00001826 N2=I-1 00001827 DO 20 IJ=2,N2 00001828 DD=DISTF2(KD,DPK,P(1,I),P(1,IJ)) 00001829 IF(DMX.LE.DD) GO TO 100 00001830 DMX=DD 00001831 K=IJ 00001832 100 CONTINUE 00001833 20 CONTINUE 00001834 C *********************** FINE LOOP 20 20 20 20 20 *************** 00001835 C 00001836 C ADD THE PARTICLE TO THE EXISTING TREE 00001837 IMST=IMST+1 00001838 MST(1,IMST)=I 00001839 MST(2,IMST)=K 00001840 D(IMST)=DMX 00001841 10 CONTINUE 00001842 C 00001843 C *********************END OF LOOP # 10 10 10 10 10 10 *************00001844 RETURN 00001845 END 00001846 SUBROUTINE NULL(M1,M2,A) 00001847 C ************************************* 00001848 C 00001849 C SET A(M1,M2)= 0.0 00001850 C 00001851 DIMENSION A(M1,M2) 00001852 DO 10 I=1,M1 00001853 DO 10 II=1,M2 00001854 10 A(I,II)=0.0 00001855 RETURN 00001856 END 00001857 SUBROUTINE ORDTRE(IMST,M1,M2,MST,M3,DU) 00001858 C *************************************** 00001859 C 00001860 C ORDER MST AND DU FOR CREASING DISTANCES 00001861 C 00001862 C ****************************************************** 00001863 C 00001864 DIMENSION MST(M1,M2) , DU(M3) 00001865 IF(IMST.LE.1) RETURN 00001866 N=IMST 00001867 100 AMX=DU(1) 00001868 K=1 00001869 DO 10 I=2,N 00001870 IF(AMX.GE.DU(I)) GO TO 200 00001871 AMX=DU(I) 00001872 K=I 00001873 200 CONTINUE 00001874 10 CONTINUE 00001875 C ......... SCAMBIO DU 00001876 CALL SCAMB(DU(K),DU(N)) 00001877 CALL SCAMB(MST(1,K),MST(1,N)) 00001878 CALL SCAMB(MST(2,K),MST(2,N)) 00001879 IF(N.LE.2) RETURN 00001880 N=N-1 00001881 GO TO 100 00001882 END 00001883 SUBROUTINE FAQUA(K,NP,NC,M1P,M,P,M4PC,MPC,PCLS,M2I,ICLS,MM,NCL, 00001884 1 M1,M2,MST) 00001885 C *************************************************************** 00001886 C 00001887 C MAKES CLUSTERS FROM A TREE 00001888 C 00001889 C *************************************************************** 00001890 C 00001891 DIMENSION P(M1P,M),PCLS(M4PC,MPC),ICLS(M2I,MPC),NCL(MM),MST(M1,M2)00001892 LOGICAL NEW1,NEW2 00001893 NEW1=NCL(MST(1,K)).LE.0 00001894 NEW2=NCL(MST(2,K)).LE.0 00001895 IF(NEW1.AND.NEW2) GO TO 100 00001896 IF(.NOT.NEW1.AND..NOT.NEW2) GO TO 200 00001897 KN=1 00001898 IF(NEW2)KN=2 00001899 KV=2 00001900 IF(NEW2) KV=1 00001901 NCL(MST(KN,K))=NCL(MST(KV,K)) 00001902 DO 10 I=1,M4PC 00001903 10 PCLS(I,NCL(MST(KV,K)))=PCLS(I,NCL(MST(KV,K)))+P(I,MST(KN,K)) 00001904 ICLS(1,NCL(MST(KV,K)))=ICLS(1,NCL(MST(KV,K)))+1 00001905 RETURN 00001906 100 CONTINUE 00001907 NC=NC+1 00001908 NCL(MST(1,K))=NC 00001909 NCL(MST(2,K))=NC 00001910 ICLS(1,NC)=2 00001911 DO 20 I=1,M4PC 00001912 20 PCLS(I,NC)=P(I,MST(1,K))+P(I,MST(2,K)) 00001913 RETURN 00001914 200 CONTINUE 00001915 NDST=NCL(MST(1,K)) 00001916 NCON=NCL(MST(2,K)) 00001917 DO 30 I=1,M4PC 00001918 PCLS(I,NCON)=PCLS(I,NCON)+PCLS(I,NDST) 00001919 30 PCLS(I,NDST)=PCLS(I,NC) 00001920 ICLS(1,NCON)=ICLS(1,NCON)+ICLS(1,NDST) 00001921 ICLS(1,NDST)=ICLS(1,NC) 00001922 DO 40 I=1,NP 00001923 IF(NCL(I).EQ.NDST) NCL(I)=NCON 00001924 IF(NCL(I).EQ.NC) NCL(I)=NDST 00001925 40 CONTINUE 00001926 NC=NC-1 00001927 RETURN 00001928 END 00001929 SUBROUTINE SCELT(NC,NP,NQUAI,MPC4,MPC,PCLS,MPC2,ICLS,MNCL,NCL) 00001930 C ************************************************************** 00001931 C 00001932 C SELECT IN PCLS(.,NC) THE MOST ENERGETICS CLUSTERS 00001933 C 00001934 C ********************************************************** 00001935 C 00001936 DIMENSION PCLS(MPC4,MPC),NCL(MNCL),ICLS(MPC2,MPC) 00001937 C 00001938 N1=NC-NQUAI 00001939 IF(N1.LE.0) RETURN 00001940 DO 5 IK=1,N1 00001941 C 00001942 EMIN=PCLS(4,1) 00001943 K=1 00001944 DO 10 I=1,NC 00001945 IF(EMIN.LE.PCLS(4,I)) GO TO 10 00001946 K=I 00001947 EMIN=PCLS(4,K) 00001948 10 CONTINUE 00001949 DO 20 I=1,MPC4 00001950 20 PCLS(I,K)=PCLS(I,NC) 00001951 ICLS(1,K)=ICLS(1,NC) 00001952 DO 30 IJ=1,NP 00001953 IF(NCL(IJ).EQ.K) NCL(IJ)=0 00001954 IF(NCL(IJ).EQ.NC) NCL(IJ)=K 00001955 30 CONTINUE 00001956 NC=NC-1 00001957 5 CONTINUE 00001958 RETURN 00001959 END 00001960 SUBROUTINE AGGPAR(KD,DSTPK,NP,NC,MPC4,PCLS,MPC2,ICLS,NCL,MP1,P) 00001961 C ******************************************************************00001962 C 00001963 C ADDS PARTICLES NOT BELONGING TO ANY CLUSTER TO THE NEAREST ONE 00001964 C 00001965 C ******************************************************* 00001966 DIMENSION PCLS(MPC4,NC),ICLS(MPC2,NC),NCL(NP),P(MP1,NP) 00001967 DO 10 I=1,NP 00001968 IF(NCL(I).GT.0) GO TO 100 00001969 DMIN=DISTF2(KD,DSTPK,P(1,I),PCLS(1,1)) 00001970 K=1 00001971 IF(NC.LE.0) GO TO 250 00001972 DO 20 II=2,NC 00001973 D=DISTF2(KD,DSTPK,P(1,I),PCLS(1,II)) 00001974 IF(D.GE.DMIN) GO TO 200 00001975 DMIN=D 00001976 K=II 00001977 200 CONTINUE 00001978 20 CONTINUE 00001979 250 CONTINUE 00001980 DO 30 IJ=1,4 00001981 30 PCLS(IJ,K)=PCLS(IJ,K)+P(IJ,I) 00001982 ICLS(1,K)=ICLS(1,K)+1 00001983 NCL(I)=K 00001984 100 CONTINUE 00001985 10 CONTINUE 00001986 RETURN 00001987 END 00001988 SUBROUTINE SCAMB(A,B) 00001989 C ********************* 00001990 DUM=A 00001991 A=B 00001992 B=DUM 00001993 RETURN 00001994 END 00001995 SUBROUTINE RIEMP(K,M,NN) 00001996 C *************************************** 00001997 C FILLS NN(M) WITH K 00001998 C ************************************ 00001999 C 00002000 DIMENSION NN(M) 00002001 DO 10 I=1,M 00002002 10 NN(I)=K 00002003 RETURN 00002004 END 00002005 FUNCTION DMED(IMST,MDU1,DU,M1,AUS) 00002006 C **************************************** 00002007 C 00002008 C MEDIAN OF THE VECTOR DU(MDU1) M1<=MDU1 00002009 C 00002010 DIMENSION DU(MDU1),AUS(M1) 00002011 DO 10 I=1,IMST 00002012 10 AUS(I)=DU(I) 00002013 N1=IMST/2 00002014 MDUF=IMST 00002015 DO 20 IJ=1,N1 00002016 K=1 00002017 DO 30 I=2,MDUF 00002018 IF(AUS(I).GT.AUS(K)) K=I 00002019 30 CONTINUE 00002020 DMED=AUS(K) 00002021 AUS(K)=AUS(MDUF) 00002022 MDUF=MDUF-1 00002023 20 CONTINUE 00002024 RETURN 00002025 END 00002026 SUBROUTINE DEST(N1,N2,K1,K2,P) 00002027 C ************************************* 00002028 C DELETE ROWS IN P 00002029 DIMENSION P(N1,N2) 00002030 IF(K1.GT.K2) RETURN 00002031 IF(N2.LE.K2) RETURN 00002032 I1=K2+1 00002033 I2=N2 00002034 ITOT=K2-K1+1 00002035 DO 10 I=I1,I2 00002036 IT=I-ITOT 00002037 DO 20 IJ=1,N1 00002038 20 P(IJ,IT)=P(IJ,I) 00002039 10 CONTINUE 00002040 RETURN 00002041 END 00002042 SUBROUTINE PRNTNC(NP,NCL,MP1,MP2,P) 00002043 C ******************************** 00002044 DIMENSION NCL(NP),P(MP1,MP2) 00002045 WRITE(6,1000) 00002046 1000 FORMAT(100H PARTICLE BELONGS TO CLUSTER , MOMENTA: PX 00002047 1PY PZ E MASS ) 00002048 WRITE(6,2000)(J,NCL(J),(P(JJ,J),JJ=1,6),J=1,NP) 00002049 2000 FORMAT(1X,I6,15X,I5,12X,5E12.5,A10) 00002050 RETURN 00002051 END 00002052 SUBROUTINE PRNTNN(NP,NCL,NUMP,MP1,MP2,P) 00002053 C **************************************** 00002054 DIMENSION NCL(NP),NUMP(NP),P(MP1,MP2) 00002055 2000 FORMAT(1X,I6,15X,I5,12X,5E12.5,A10) 00002056 WRITE(6,1000) 00002057 1000 FORMAT(100H PARTICLE BELONGS TO CLUSTER , MOMENTA: PX 00002058 1PY PZ E MASS ) 00002059 WRITE(6,2000)(NUMP(J),NCL(NUMP(J)),(P(JJ,NUMP(J)),JJ=1,6),J=1,NP) 00002060 RETURN 00002061 END 00002062