THbtp/hbt_event_processor.f

   1 CCC ********************************************************************
   2 CCC  Modifications for ALICE-ROOT application at CERN - 12/15/2000
   3 CCC  1.  Removed all Fortran Data Structures in favor of labelled
   4 CCC      common blocks.  The syntax of the structure_variable to
   5 CCC      common variable name change is:
   6 CCC      In STAR code    In ALICE code
   7 CCC        A(i).B     ==>  A_B(i)
   8 CCC        A(i).B(j)  ==>  A_B(j,i)
   9 CCC  2.  All remaining references in the comments and write statements
  10 CCC      to the data structures are interpreted as applying to the
  11 CCC      new common variables.
  12 CCC  3.  The UNIX random number generator, ran(), was replaced with
  13 CCC      a function which calls a modified version of the CERNLIB
  14 CCC      random number generator, ranlux, herein called ranlux2.  The
  15 CCC      latter allows a user supplied seed value.
  16 CCC  4.  Increased the following array sizes for the LHC Pb+Pb design
  17 CCC      multiplicity criteria of dN_{ch}/dy = 8000 assuming 80% of
  18 CCC      this is pi(+) and pi(-), which are the largest populations
  19 CCC      that this code is required to process.
  20 CCC
  21 CCC      The following are for the max number of tracks that can be
  22 CCC      stored in each sector without overflow:
  23 CCC         common_mesh.inc - increased max_trk_save from 30 to 150
  24 CCC         common_sec_track.inc  - inc. max_trk_sec from 30 to 150
  25 CCC         common_sec_track2.inc - inc. max_trk_sec2 from 30 to 150
  26 CCC
  27 CCC      The following determine the maximum number of tracks that can
  28 CCC      be processed in an event:
  29 CCC         common_track.inc - increased trk_maxlen from 6500 to 25000
  30 CCC         common_track2.inc - increased trk2_maxlen from 6500 to 25000
  31 CCC
  32 C
  33 C     DESCRIPTION OF METHOD:
  34 C     =====================
  35 C
  36 C          This program produces relativistic heavy-ion collision
  37 C     events in which the particle momenta for selected particle ID
  38 C     types and for selected kinematic acceptance ranges are randomly
  39 C     adjusted such that specified one-body distributions and two-body
  40 C     correlation functions are reproduced.  The input to the code may
  41 C     be a set of events from any STAR event generator, so long as the
  42 C     format is in the STAR Geant (GSTAR) text format standard (see
  43 C     STAR Note #235).  The basic method is similar to that of Metropolis
  44 C     et al. and is fully described in Ray and Hoffmann, Phys. Rev. C 54,
  45 C     2582 (1996).  Briefly the steps in the algorithm include:
  46 C
  47 C        (1) For an initial particle distribution of specified particle
  48 C            ID types (maximum of two types allowed) and momentum
  49 C            acceptance ranges [given in terms of transverse momentum
  50 C            (p_T), azimuthal angle (phi) and pseudorapidity (eta)] the
  51 C            momentum vector of one particle is randomly shifted within
  52 C            a specified range from its initial value.  The shifts are
  53 C            done for px, py and pz independently.
  54 C
  55 C        (2) New one-body and two-body histograms, as well as the two-body
  56 C            correlation function are calculated.
  57 C
  58 C        (3) If the random momentum shift results in an improved overall
  59 C            chi-square, obtained by comparison with a specified reference
  60 C            for the one-body distribution and the two-body correlation
  61 C            model, then the new momentum vector is retained.  If not,
  62 C            then the vector is restored to its starting value.
  63 C
  64 C        (4) Steps 1-3 are repeated for each accepted particle in the
  65 C            event.
  66 C
  67 C        (5) The entire process, steps 1-4, is repeated until either a
  68 C            satisfactory fit to the model distributions are obtained or
  69 C            the maximum number of iterations is reached.
  70 C
  71 C        (6) Once the iterative process is complete, the input event file
  72 C            is copied directly to an output event file where the adjusted
  73 C            momentum values for the accepted tracks replace that in the
  74 C            input file.  The event output file is in the GSTAR standard
  75 C            text format.  This event output file may be processed again
  76 C            by this code in order to generate correlations for other
  77 C            particle types or for different kinematic ranges.  The file
  78 C            is suitable for input into the STAR version of Geant-3, called
  79 C            GSTAR (STAR Note 235).
  80 C
  81 C     In order to reduce cpu demand the particle momenta are sorted into
  82 C     momentum space cells or sectors.  In forming particle pairs only those
  83 C     particles in the same, or adjacent cells are used.  For large events
  84 C     this vastly reduces the required cpu time.  The penalty is that the
  85 C     coding becomes more complicated.  Much of the present code is devoted
  86 C     to the necessary bookeeping chores that must be done in order to
  87 C     determine which cell the tracks are in and if they move to new cells
  88 C     during the track adjustment procedure.  Information about the
  89 C     momentum space cells are contained in the data structure /sec_trk_map/.
  90 C
  91 C     The sector size must therefore be scaled with the specified correlation
  92 C     range.  All particles will be paired with all possible partners out
  93 C     to Q's equal to the smallest dimension of the momentum space sectors.
  94 C     Particle pairs with Q greater than this sector dimension will suffer
  95 C     reduced acceptance, finally being completely cut-off for Q ~> 2 times
  96 C     the diagonal length thru a sector.
  97 C
  98 C          In order to generate momentum correlations for particle types
  99 C     having low multiplicity it is necessary for the user to supply this
 100 C     code with an artificially enhanced multiplicity along with a track-
 101 C     write-output fractional acceptance factor (see input variable
 102 C     'trk_accep').  For example, if the user wants to generate HBT
 103 C     correlations for K0-shorts but the assumed multiplicity is too
 104 C     low for the present algorithm to work, the user may increase the
 105 C     input K0-short multiplicity, for instance by a factor of 5, then
 106 C     run the code and set trk_accep = 1/5 = 0.2 in order to randomly
 107 C     reject about 80% of the K0-shorts.  The track rejection is done
 108 C     after the track adjustment procedure is completed.  This procedure
 109 C     should preserve the built-in correlations in the final output
 110 C     event file, although with reduced statistics.
 111 C          Another approach for handling low multiplicity events would
 112 C     be to combine particles from several events, carry out the track
 113 C     adjustment procedure, then separate the tracks into their original
 114 C     events.  This method must insure that no bias is included due to
 115 C     the order of processing the tracks from the first, second, etc.
 116 C     events.  This latter method, once proven, could be used for
 117 C     the low multiplicity particles from any event generator.  For
 118 C     the present version of the code the low multiplicity HBT studies
 119 C     must utilize a Monte Carlo multiplicity generator.
 120 C
 121 C          The code may also be used to read in a previously correlated
 122 C     set of events and either compute the reference histograms or read in
 123 C     the references, and then compute the correlations for each event and
 124 C     the inclusive correlations without doing the track momentum adjustment
 125 C     procedure.  This feature may be used, for example, to study the
 126 C     correlations that result in one set of coordinates for events fitted
 127 C     to correlations with respect to a different set of coordinates.  For
 128 C     example, fit the correlations to the Y-K-P form and then evaluate
 129 C     the side-out-long correlations, or vice-versa.
 130 C
 131 C     TWO-BODY REFERENCE HISTOGRAMS:
 132 C     =============================
 133 C
 134 C          In order to calculate the correlations, an uncorrelated two-body
 135 C     reference spectrum is needed.  The program will calculate this
 136 C     quantity by forming pairs of particles from different events in the
 137 C     input file.  For the particle ID type(s) and momentum acceptance
 138 C     the code forms all possible pairs (given the cell substructure) by
 139 C     mixing particles from event#1 with those in event#2, then particles
 140 C     from event#2 are mixed with particles from event#3, then events 3
 141 C     and 4 are mixed, and so on.  In this way ample statistics may be
 142 C     achieved for the reference distributions.  These reference distributions
 143 C     can be written out to file and re-used in subsequent runs.  Since
 144 C     all events in the input event file are used in generating the
 145 C     reference distribution, it is imperative that these events be physically
 146 C     similar.
 147 C
 148 C     ONE-BODY REFERENCE HISTOGRAMS:
 149 C     =============================
 150 C
 151 C          Inclusive sums of the accepted particles for all events in the
 152 C     input event file determine the one-body reference distributions.
 153 C     These are used to constrain the momentum vector shifts.  Although
 154 C     the one-body distributions from realistic event generators are fully
 155 C     three-dimensional, the present code is restricted to only work with
 156 C     the one-dimensional projections onto p_T, phi and eta.  In other words,
 157 C     the p_T distribution used in this code is formed by integrating
 158 C     the particle distributions over (phi,eta) over the momentum acceptance
 159 C     range.  No particle distribution models are built into the code.
 160 C     The one-body reference distributions are either read-in or determined
 161 C     from the events in the input event text file.
 162 C
 163 C     TWO-BODY CORRELATION MODELS:
 164 C     ===========================
 165 C
 166 C          The code permits both 1-dimensional and 3-dimensional two-body
 167 C     correlation models.  These may be fitted separately or simultaneously.
 168 C     The source may include a mixture of incoherent and coherent components;
 169 C     Coulomb corrections are also included.  The general form assumed
 170 C     [see Cramer and Kadija, Phys. Rev. C 53, 908 (1996)] is:
 171 C
 172 C       C2 = 1 + lambda*(b**2) + 2.0*sqrt(lambda)*[1 - sqrt(lambda)]*b
 173 C
 174 C     where lambda is the usual chaoticity parameter.  The third term in
 175 C     this equation may be turned on or off.  Values of lambda < 1.0 may
 176 C     be used without the third term being included.  For 1-dimensional
 177 C     functions b is given by:
 178 C
 179 C       b = exp(- Q**2 * R**2 / 2)
 180 C
 181 C     where Q is either the invariant 4-momentum difference, the total
 182 C     4-momentum difference (i.e. time-like + space-like) or the
 183 C     3-vector momentum difference.  The 3-dimensional functions may be
 184 C     of the Bertsch-Pratt ``side-out-longitudinal'' form given by:
 185 C
 186 C       b = exp[(- Qside**2 * Rside**2 - Qout**2 * Rout**2
 187 C                - Qlong**2 * Rlong**2)/2]
 188 C
 189 C     where the ``out-long'' cross term is omitted.  The 3D function may
 190 C     also be in the Yano-Koonin-Podgoretski (YKP) form given by (for
 191 C     pairs in the A+A c.m. frame):
 192 C
 193 C       b = exp[(- Qperp**2 * Rperp**2 - Qparallel**2 * Rparallel**2
 194 C                - Qtime**2 * Rtime**2)/2]
 195 C
 196 C     where
 197 C                Qperp = transverse momentum difference
 198 C                Qparallel = Qlong = p_{1z} - p_{2z}
 199 C                Qtime = E_1 - E_2
 200 C
 201 C     The Coulomb correction may be omitted, or included in one of 3 ways:
 202 C
 203 C          (1) Point source Gamow factor
 204 C          (2) Finite source NA35 model (see Eq.(5) in Z. Phys. C73, 443
 205 C              (1997)) where
 206 C
 207 C              Coulomb correction = 1 + [G(q) - 1]*exp(-q/Q0)
 208 C
 209 C              and G(q) is the Gamow factor and q is the 3-momentum
 210 C              vector difference.
 211 C          (3) Finite source, Pratt integrated Coulomb wave function
 212 C              integrals, interpolated for a specific source radius
 213 C              from John Cramer's tables for discrete source radii.
 214 C
 215 C     These Coulomb correction factors multiply the above correlation
 216 C     function to give the total correlation function to be fitted for
 217 C     charged, like pairs. For charged, unlike pairs only the Coulomb
 218 C     (attractive) correlation function is used.
 219 C
 220 C     BINNING:
 221 C     =======
 222 C
 223 C          Several types of binning are done in the code. The one-body
 224 C     distributions are binned in p_t, phi and eta.  The full momentum
 225 C     space is subdivided into cells or sectors.  The 1D and 3D two-body
 226 C     distributions are binned into fine and coarse bins, where the fine
 227 C     bins occur at the smaller momentum difference range and the coarse
 228 C     bins at the larger.  For the 3D distributions the (1,1,1) coarse
 229 C     bin must coincide with the 3D fine bins.
 230 C
 231 C     SUMMARY OF EXTERNAL FILES:
 232 C     =========================
 233 C
 234 C File Unit#    File Name                Description
 235 C ----------------------------------------------------------------------------
 236 C     1      hbt_parameters.in          Input switches and controls
 237 C     2      event_text.in              Event generator output in GSTAR text
 238 C     3      event_line.flags           Generated tmp file, input line flags
 239 C     4      event_tracks.select        Generated tmp file, accep. tracks flg.
 240 C     7      hbt_log.out                Generated log file - error reports
 241 C     8      hbt_simulation.out         Generated main output file
 242 C     9      hbt_pair_reference.hist    Generated pair ref. histograms
 243 C     10     event_hbt_text.out         Gen. correlated event text file
 244 C     11     hbt_singles_reference.hist Gen. one-body ref. histograms
 245 C     12     event_text_aux.in          Tmp copy of event_text.in per event
 246 C     14     event_tracks_aux.select    Tmp copy of event_tracks.select/event
 247 C     21-27  cpp_*.dat (*=06,08...18)   Like pair Pratt Coulomb corrections.
 248 C     31-37  cpm_*.dat (*=06,08...18)   Unlike pair Pratt Coulomb corrects.
 249 C ----------------------------------------------------------------------------
 250 C
 251 C     Source of Data for ALICE Application:
 252 C     ====================================
 253 C
 254 C File Unit#    File Name                For ALICE File or Struc?
 255 C ----------------------------------------------------------------------------
 256 C     1      hbt_parameters.in          Call AliHbtp_ function
 257 C     2      event_text.in              Call AliHbtp_ function
 258 C     3      event_line.flags           File not used
 259 C     4      event_tracks.select        File not used
 260 C     7      hbt_log.out                File used as is
 261 C     8      hbt_simulation.out         File used as is
 262 C     9      hbt_pair_reference.hist    File used as is
 263 C     10     event_hbt_text.out         Call AliHbtp_ function
 264 C     11     hbt_singles_reference.hist File used as is
 265 C     12     event_text_aux.in          File not used
 266 C     14     event_tracks_aux.select    File not used
 267 C     21-27  cpp_*.dat (*=06,08...18)   Files are used as is
 268 C     31-37  cpm_*.dat (*=06,08...18)   Files are used as is
 269 C ----------------------------------------------------------------------------
 270 C
 271 C     DESCRIPTION OF INPUT PARAMETERS AND SWITCHES (FILE: hbt_parameters.in):
 272 C     ======================================================================
 273 C
 274 C     Control Switches:
 275 C     ================
 276 C
 277 C        ref_control       = 1 to read reference histograms from input files
 278 C                          = 2 to compute reference histograms by track
 279 C                              mixing from event pairs in the event input file.
 280 C
 281 C        switch_1d         = 0 to not compute the 1D two-body correlations.
 282 C                          = 1 to compute this using Q-invariant
 283 C                          = 2 to compute this using Q-total
 284 C                          = 3 to compute this using Q-3-vector
 285 C
 286 C        switch_3d         = 0 to not compute the 3D two-body correlations.
 287 C                          = 1 to compute this using the side-out-long form
 288 C                          = 2 to compute this using the YKP form.
 289 C
 290 C        switch_type       = 1 to fit only the like pair correlations
 291 C                          = 2 to fit only the unlike pair correlations
 292 C                          = 3 to fit both the like and unlike pair correl.
 293 C
 294 C        switch_coherence  = 0 for purely incoherent source (but can have
 295 C                              lambda < 1.0)
 296 C                          = 1 for mixed incoherent and coherent source
 297 C
 298 C        switch_coulomb    = 0 no Coulomb correction
 299 C                          = 1 Point source Gamow correction only
 300 C                          = 2 NA35 finite source size correction
 301 C                          = 3 Pratt/Cramer finite source size correction;
 302 C                              interpolated from input tables.
 303 C
 304 C        switch_fermi_bose =  1 Boson pairs
 305 C                          = -1 Fermion pairs
 306 C
 307 C        trk_accep         = 1.0 all adjusted tracks are written out
 308 C                          < 1.0 only this fraction, on average, of the
 309 C                            adjusted tracks are written out.  Used for
 310 C                            low multiplicity events.
 311 C
 312 C        print_full        = 0 for standard, minimal output
 313 C                          = 1 for full, comprehensive (large) output for
 314 C                              each event.
 315 C
 316 C        print_sector_data = 0 std. sector occupancy data printed out
 317 C                          = 1 to print sector occupancy and overflow info.
 318 C
 319 C     Particle ID and Search Parameters:
 320 C     =================================
 321 C
 322 C        n_pid_types       = 1 or 2 only, # particle types to correlate
 323 C
 324 C        pid(1), pid(2)    = Geant-3 particle ID code numbers
 325 C
 326 C        deltap            = maximum range for random momentum shifts in
 327 C                            GeV/c; px,py,pz independent; Def = 0.1 GeV/c.
 328 C
 329 C        maxit             = maximum # allowed iterations thru all the
 330 C                            tracks for each event. Default = 50.
 331 C                            If maxit=0, then calculate the correlations
 332 C                            for the input set of events without doing the
 333 C                            track adjustment procedure.
 334 C
 335 C        delchi            = min % change in total chi-square for which
 336 C                            the track adjustment iterations may stop,
 337 C                            Default = 0.1%.
 338 C
 339 C        irand             = initial random # seed, default = 12345
 340 C
 341 C     Source Function Parameters:
 342 C     ==========================
 343 C
 344 C        lambda            = Chaoticity
 345 C
 346 C        R_1d              = Spherical source model radius (fm)
 347 C
 348 C        Rside,Rout,Rlong  = Non-spherical Bertsch-Pratt source model (fm)
 349 C
 350 C        Rperp,Rparallel,R0= Non-spherical Yano-Koonin-Podgoretski source
 351 C                            model (fm).
 352 C
 353 C        Q0                = NA35 Coulomb parameter for finite source size
 354 C                            in (GeV/c) - iff switch_coulomb = 2
 355 C                          = Spherical Coulomb source radius in (fm) iff
 356 C                            switch_coulomb = 3, used to interpolate the
 357 C                            input Pratt/Cramer discrete Coulomb source
 358 C                            radii tables.
 359 C
 360 C     One-body pT, phi, eta Acceptance Bins:
 361 C     =====================================
 362 C
 363 C        n_pt_bins, pt_min, pt_max  = # pt bins,  min/max pt accept. (GeV/c)
 364 C
 365 C        n_phi_bins,phi_min,phi_max = # phi bins, min/max phi accept. (deg.)
 366 C
 367 C        n_eta_bins,eta_min,eta_max = # eta bins, min/max eta accept.
 368 C
 369 C                                     [NOTE: For each the maximum # of bins
 370 C                                            must be .le. 100]
 371 C
 372 C     Two-body 1D and 3D Correlation Bins:
 373 C     ===================================
 374 C
 375 C        n_1d_fine,  binsize_1d_fine   = # and size (GeV/c), 1D - fine mesh
 376 C
 377 C        n_1d_coarse,binsize_1d_coarse = # and size (GeV/c), 1D - coarse mesh
 378 C
 379 C        n_3d_fine,  binsize_3d_fine   = # and size (GeV/c), 3D - fine mesh
 380 C
 381 C        n_3d_coarse,binsize_3d_coarse = # and size (GeV/c), 3D - coarse mesh
 382 C
 383 C                                      [NOTE: The maximum # of 1D bins (fine
 384 C                                             + coarse) must be .le. 100;
 385 C                                             The maximum # of 3D bins (either
 386 C                                             fine or coarse) must be .le.10).
 387 C                                             For both 1D and 3D there must be
 388 C                                             at least 1 fine bin and 1 coarse
 389 C                                             bin.]
 390 C        n_3d_fine_project             = # of 3D-fine bins to integrate over
 391 C                                        to form 1D projections.  This value
 392 C                                        must be .le. n_3d_fine.
 393 C
 394 C     Momentum Space Track-Sector Cells:
 395 C     =================================
 396 C
 397 C        n_px_bins,px_min,px_max = #, min,max px bins (GeV/c)
 398 C
 399 C        n_py_bins,py_min,py_max = #, min,max py bins (GeV/c)
 400 C
 401 C        n_pz_bins,pz_min,pz_max = #, min,max pz bins (GeV/c)
 402 C
 403 C                                  [NOTE: The maximum number of total sectors,
 404 C                                         equal to the product of the x-y-z
 405 C                                         number of cells must be .le.
 406 C                                         sec_maxlen which is defined in the
 407 C                                         /sec_trk_map/ data structure.]
 408 C
 409 C     Relative Chi-Square Weights:
 410 C     ===========================
 411 C
 412 C        chisq_wt_like_1d          = 1D, like pairs
 413 C        chisq_wt_unlike_1d        = 1D, unlike pairs
 414 C        chisq_wt_like_3d_fine     = 3D, like pairs, fine mesh
 415 C        chisq_wt_unlike_3d_fine   = 3D, unlike pairs, fine mesh
 416 C        chisq_wt_like_3d_coarse   = 3D, like pairs, coarse mesh
 417 C        chisq_wt_unlike_3d_coarse = 3D, unlike pairs, coarse mesh
 418 C        chisq_wt_hist1_1 = summed pt, phi, eta 1-body dist., PID#1
 419 C        chisq_wt_hist1_2 = summed pt, phi, eta 1-body dist., PID#2
 420 C
 421 C
 422 C     FORMAT for hbt_singles_reference.hist:
 423 C     =====================================
 424 C
 425 C     The output content for the one-body reference histograms is:
 426 C
 427 C     Line 1:  n_pid_types,pid(1),pid(2)
 428 C          2:  n_pt_bins,pt_min,pt_max
 429 C          3:  n_phi_bins,phi_min,phi_max
 430 C          4:  n_eta_bins,eta_min,eta_max
 431 C          5:  n_part_used_1_ref,n_part_used_2_ref
 432 C
 433 C     Then for PID #1:      (href1_pt_1(i),i=1,n_pt_bins)
 434 C     (One entry per line)  (href1_phi_1(i),i=1,n_phi_bins)
 435 C                           (href1_eta_1(i),i=1,n_eta_bins)
 436 C
 437 C     and for PID #2:       (href1_pt_2(i),i=1,n_pt_bins)
 438 C     (One entry per line)  (href1_phi_2(i),i=1,n_phi_bins)
 439 C                           (href1_eta_2(i),i=1,n_eta_bins)
 440 C
 441 C
 442 C     FORMAT for hbt_pair_reference.hist:
 443 C     ==================================
 444 C
 445 C     The output content for the two-body reference histograms is:
 446 C
 447 C     Line 1:  n_pid_types,pid(1),pid(2)
 448 C          2:  n_pt_bins,pt_min,pt_max
 449 C          3:  n_phi_bins,phi_min,phi_max
 450 C          4:  n_eta_bins,eta_min,eta_max
 451 C          5:  switch_1d,switch_3d,switch_type
 452 C          6:  n_1d_fine,n_1d_coarse,n_3d_fine,n_3d_coarse
 453 C          7:  binsize_1d_fine,binsize_1d_coarse,
 454 C              binsize_3d_fine,binsize_3d_coarse
 455 C          8:  num_pairs_like_ref,num_pairs_unlike_ref
 456 C
 457 C   The pair distributions (with one entry per line) are:
 458 C
 459 C   1D, like pairs:             (href_like_1d(i),i=1,n_1d_total)
 460 C
 461 C   1D, unlike pairs:           (href_unlike_1d(i),i=1,n_1d_total)
 462 C
 463 C   3D, like pairs, fine mesh:   href_like_3d_fine(i,j,k) ; (i,(j,(k,...)))
 464 C
 465 C   3D, like pairs, coarse mesh: href_like_3d_coarse(i,j,k) ; (i,(j,(k,...)))
 466 C
 467 C   3D, unlike, fine mesh:       href_unlike_3d_fine(i,j,k) ; (i,(j,(k,...)))
 468 C
 469 C   3D, unlike, coarse mesh:     href_unlike_3d_coarse(i,j,k) ; (i,(j,(k,...)))
 470 C
 471 C*************************************************************************
 472 C*************************************************************************
 473
 474       SUBROUTINE CTEST
 475       implicit none
 476
 477       Include 'common_parameters.inc'
 478       Include 'common_mesh.inc'
 479       Include 'common_histograms.inc'
 480       Include 'common_correlations.inc'
 481       Include 'common_coulomb.inc'
 482
 483       Include 'common_track.inc'
 484       Include 'common_track2.inc'
 485       Include 'common_sec_track.inc'
 486       Include 'common_sec_track2.inc'
 487       Include 'common_particle.inc'
 488
 489       write(*,*) ' '
 490       write(*,*) ' '
 491       write(*,*) ' '
 492
 493       write(*,*) 'Input data in Fort'
 494       write(*,*) ' '
 495       write(*,*) ' '
 496       write(*,*) ' '
 497       write(*,*) '      PARAMETERS'
 498       write(*,*) ' '
 499       write(*,*) 'ref_control',ref_control
 500       write(*,*) 'switch_1d',switch_1d
 501       write(*,*) 'switch_3d',switch_3d
 502       write(*,*) 'switch_type',switch_type
 503       write(*,*) 'switch_coherence',switch_coherence
 504       write(*,*) 'switch_coulomb',switch_coulomb
 505       write(*,*) 'switch_fermi_bose',switch_fermi_bose
 506       write(*,*) 'trk_accep',trk_accep
 507       write(*,*) 'print_full',print_full
 508       write(*,*) 'print_sector_data',print_sector_data
 509       write(*,*) 'n_pid_types',n_pid_types
 510       write(*,*) 'pid(1)', pid(1)
 511       write(*,*) 'pid(2)', pid(2)
 512       write(*,*) 'maxit',maxit
 513       write(*,*) 'irand',irand
 514       write(*,*) 'n_part_1_trk', n_part_1_trk
 515       write(*,*) 'n_part_2_trk ', n_part_2_trk
 516       write(*,*) 'n_part_tot_trk ', n_part_tot_trk
 517       write(*,*) 'n_part_used_1_trk ', n_part_used_1_trk
 518       write(*,*) 'n_part_used_2_trk',  n_part_used_2_trk
 519       write(*,*) 'n_part_1_trk2',    n_part_1_trk2
 520       write(*,*) 'n_part_2_trk2', n_part_2_trk2
 521       write(*,*) 'n_part_tot_trk2',   n_part_tot_trk2
 522       write(*,*) 'n_part_used_1_trk2',  n_part_used_1_trk2
 523       write(*,*) 'n_part_used_2_trk2',  n_part_used_2_trk2
 524       write(*,*) 'n_part_used_1_ref', n_part_used_1_ref
 525       write(*,*) 'n_part_used_2_ref ',  n_part_used_2_ref
 526       write(*,*) 'n_part_used_1_inc',  n_part_used_1_inc
 527       write(*,*) 'n_part_used_2_inc',     n_part_used_2_inc
 528       write(*,*) 'num_pairs_like',   num_pairs_like
 529       write(*,*) 'num_pairs_unlike',  num_pairs_unlike
 530       write(*,*) 'num_pairs_like_ref ', num_pairs_like_ref
 531       write(*,*) 'num_pairs_like_inc ',  num_pairs_like_inc
 532       write(*,*) 'num_pairs_unlike_inc', num_pairs_unlike_inc
 533       write(*,*) 'event_line_counter', event_line_counter
 534       write(*,*) 'file10_line_counter ',file10_line_counter
 535       write(*,*) 'lambda',lambda
 536       write(*,*) 'R_1d ',R_1d
 537       write(*,*) 'Rside',Rside
 538       write(*,*) 'Rout  ',  Rout
 539       write(*,*) 'Rlong  ', Rlong
 540       write(*,*) 'Rperp  ',  Rperp
 541       write(*,*) 'Rparallel  ', Rparallel
 542       write(*,*) 'R0 ',  R0
 543       write(*,*) 'Q0 ',  Q0
 544       write(*,*) 'deltap',deltap
 545       write(*,*) 'delchi',delchi
 546       write(*,*) 'pi ', pi
 547       write(*,*) 'rad ', rad
 548       write(*,*) 'hbc ', hbc
 549       write(*,*) 'chisq_wt_like_1d ', chisq_wt_like_1d
 550       write(*,*) 'chisq_wt_unlike_1d ',  chisq_wt_unlike_1d
 551       write(*,*) 'chisq_wt_like_3d_fine  ',chisq_wt_like_3d_fine
 552       write(*,*) 'chisq_wt_unlike_3d_fine ',  chisq_wt_unlike_3d_fine
 553       write(*,*) 'chisq_wt_like_3d_coarse ', chisq_wt_like_3d_coarse
 554       write(*,*) 'chisq_wt_unlike_3d_coarse',chisq_wt_unlike_3d_coarse
 555       write(*,*) 'chisq_wt_hist1_1 ', chisq_wt_hist1_1
 556       write(*,*) 'chisq_wt_hist1_2 ', chisq_wt_hist1_2
 557       write(*,*) ' '
 558       write(*,*) ' '
 559       write(*,*) ' '
 560       write(*,*) '         MESH       '
 561       write(*,*) ' '
 562       write(*,*) ' n_pt_bins ',  n_pt_bins
 563       write(*,*) ' pt_min ', pt_min
 564       write(*,*) ' pt_max  ', pt_max
 565       write(*,*) ' n_phi_bins ', n_phi_bins
 566       write(*,*) ' phi_min ', phi_min
 567       write(*,*) ' phi_max ', phi_max
 568       write(*,*) ' n_eta_bins ', n_eta_bins
 569       write(*,*) ' eta_min', eta_min
 570       write(*,*) ' eta_max', eta_max
 571       write(*,*) ' n_1d_fine ', n_1d_fine
 572       write(*,*) ' binsize_1d_fine ',binsize_1d_fine
 573       write(*,*) ' n_1d_coarse ',n_1d_coarse
 574       write(*,*) ' binsize_1d_coarse ', binsize_1d_coarse
 575       write(*,*) ' n_3d_fine  ',n_3d_fine
 576       write(*,*) ' binsize_3d_fine ',binsize_3d_fine
 577       write(*,*) ' n_3d_coarse ', n_3d_coarse
 578       write(*,*) ' binsize_3d_coarse ', binsize_3d_coarse
 579       write(*,*) ' n_3d_fine_project ',n_3d_fine_project
 580       write(*,*) ' n_px_bins ',n_px_bins
 581       write(*,*) ' px_min ',px_min
 582       write(*,*) ' px_max ', px_max
 583       write(*,*) ' n_py_bins ', n_py_bins
 584       write(*,*) ' py_min ',  py_min
 585       write(*,*) ' py_max',  py_max
 586       write(*,*) ' n_pz_bins ',n_pz_bins
 587       write(*,*) ' pz_min ', pz_min
 588       write(*,*) ' pz_max ', pz_max
 589       write(*,*) '  '
 590
 591       End
 592
 593
 594
 595       SUBROUTINE HBTPROCESSOR
 596       implicit none
 597
 598
 599       Include 'common_parameters.inc'
 600       Include 'common_mesh.inc'
 601       Include 'common_histograms.inc'
 602       Include 'common_correlations.inc'
 603       Include 'common_coulomb.inc'
 604
 605       Include 'common_track.inc'
 606       Include 'common_track2.inc'
 607       Include 'common_sec_track.inc'
 608       Include 'common_sec_track2.inc'
 609       Include 'common_particle.inc'
 610
 611 CCC   Set Data I/O control for ALICE or Standalone application
 612 C     ALICE = 1   ! This is for the ALICE AliRoot application
 613 CCC   ALICE = 0   ! This is for the standalone application
 614
 615 CCC   Initialize error code for ALICE application:
 616       errorcode = 0
 617
 618 CCC   Open Output Files:
 619
 620       open(unit=7,status='unknown',access='sequential',
 621      1     file='hbt_log.out')
 622       open(unit=8,status='unknown',access='sequential',
 623      1     file='hbt_simulation.out')
 624
 625 CCC   Initialize Arrays and Data Structures:
 626       If(ALICE .eq. 1) then
 627 C     In fact we not need to call initialization,
 628 C     because we can easily assume that is already done
 629          Call alihbtp_initialize
 630       Else If (ALICE .eq. 0) Then
 631          Call initialize
 632       End If
 633
 634       Write(6,100)
 635 CCC   Read Input Controls and Parameters:
 636       Call read_data(1)
 637       If(errorcode .eq. 1) Return
 638
 639 CCC   Setup values and check input parameter ranges and consistency:
 640       Call set_values
 641       If(errorcode .eq. 1) Return
 642
 643 CCC   Produce Basic Output File Header:
 644       Call write_data(1,0)
 645       If(errorcode .eq. 1) Return
 646
 647
 648       Write(6,101)
 649 CCC   Read Event Input file and fill flag files:
 650       Call read_data(2)
 651       If(errorcode .eq. 1) Return
 652
 653       Write(6,102)
 654 CCC   Get the Reference Histograms and write out if new calculation:
 655       Call getref_hist
 656       If(errorcode .eq. 1) Return
 657       Call write_data(3,0)
 658       If(errorcode .eq. 1) Return
 659       Write(6,103)
 660
 661       Write(6,104)
 662 CCC   Compute the correlation model and print out:
 663       Call correl_model
 664       Call write_data(4,0)
 665       If(errorcode .eq. 1) Return
 666
 667       Write(6,105)
 668 CCC   Carry out the Track Adjustment/Correlation Fitting Procedure:
 669       Call correlation_fit
 670       Write(6,106)
 671
 672 CCC   Final Output of Inclusive Quantities:
 673       Call write_data(6,0)
 674       If(errorcode .eq. 1) Return
 675
 676 CCC   Close Output Files:
 677       close(unit=7)
 678       close(unit=8)
 679
 680 CCC   Formats:
 681 100   Format(5x,'Read Input Controls, Setup values, check input:')
 682 101   Format(5x,'Read Event Input file and fill flag files:')
 683 102   Format(5x,'Get the Reference Histograms:')
 684 103   Format(5x,'Finished with Reference Histograms:')
 685 104   Format(5x,'Compute the correlation model:')
 686 105   Format(5x,'Start Track Adjustment/Correlation Fitting Procedure:')
 687 106   Format(5x,'Finished with Track Fitting Procedure:')
 688
 689       Return
 690       END
 691
 692 C-------------------------------------------------------------------
 693
 694
 695       subroutine initialize
 696       implicit none
 697
 698 CCC   This subroutine sets all arrays and structures to zero:
 699
 700       Include 'common_mesh.inc'
 701       Include 'common_histograms.inc'
 702       Include 'common_correlations.inc'
 703       Include 'common_coulomb.inc'
 704       Include 'common_event_summary.inc'
 705
 706       Include 'common_track.inc'
 707       Include 'common_track2.inc'
 708       Include 'common_sec_track.inc'
 709       Include 'common_sec_track2.inc'
 710       Include 'common_particle.inc'
 711
 712 CCC   Local Variable Type Declarations:
 713
 714       integer*4 i,j,k
 715
 716       do i = 1,trk_maxlen
 717          trk_id(i)            = 0
 718          trk_px_sec(i)        = 0
 719          trk_py_sec(i)        = 0
 720          trk_pz_sec(i)        = 0
 721          trk_sector(i)        = 0
 722          trk_flag(i)          = 0
 723          trk_out_flag(i)      = 0
 724          trk_merge_flag(i)    = 0
 725          trk_ge_pid(i)        = 0
 726          trk_start_vertex(i)  = 0
 727          trk_stop_vertex(i)   = 0
 728          trk_event_line(i)    = 0
 729          trk_px(i)            = 0.0
 730          trk_py(i)            = 0.0
 731          trk_pz(i)            = 0.0
 732          trk_E(i)             = 0.0
 733          trk_pt(i)            = 0.0
 734          trk_phi(i)           = 0.0
 735          trk_eta(i)           = 0.0
 736       end do
 737
 738       do i = 1,trk2_maxlen
 739          trk2_id(i)            = 0
 740          trk2_px_sec(i)        = 0
 741          trk2_py_sec(i)        = 0
 742          trk2_pz_sec(i)        = 0
 743          trk2_sector(i)        = 0
 744          trk2_flag(i)          = 0
 745          trk2_out_flag(i)      = 0
 746          trk2_merge_flag(i)    = 0
 747          trk2_ge_pid(i)        = 0
 748          trk2_start_vertex(i)  = 0
 749          trk2_stop_vertex(i)   = 0
 750          trk2_event_line(i)    = 0
 751          trk2_px(i)            = 0.0
 752          trk2_py(i)            = 0.0
 753          trk2_pz(i)            = 0.0
 754          trk2_E(i)             = 0.0
 755          trk2_pt(i)            = 0.0
 756          trk2_phi(i)           = 0.0
 757          trk2_eta(i)           = 0.0
 758       end do
 759
 760       do i = 1,sec_maxlen
 761          stm_sec_id(i)         = 0
 762          stm_n_trk_sec(i)      = 0
 763          stm_flag(i)           = 0
 764          do j = 1,max_trk_sec
 765             stm_track_id(j,i)  = 0
 766          end do
 767       end do
 768
 769       do i = 1,sec_maxlen2
 770          stm2_sec_id(i)         = 0
 771          stm2_n_trk_sec(i)      = 0
 772          stm2_flag(i)           = 0
 773          do j = 1,max_trk_sec2
 774             stm2_track_id(j,i)  = 0
 775          end do
 776       end do
 777
 778       do i = 1,part_maxlen
 779          part_id(i)       = 0
 780          part_charge(i)   = 0
 781          part_mass(i)     = 0.0
 782          part_lifetime(i) = 0.0
 783       end do
 784
 785       do i = 1,max_trk_save
 786          old_sec_trkid(i) = 0
 787          new_sec_trkid(i) = 0
 788       end do
 789
 790       do i = 1,max_h_1d
 791          hist_like_1d(i)   = 0
 792          hist_unlike_1d(i) = 0
 793          htmp_like_1d(i)   = 0
 794          htmp_unlike_1d(i) = 0
 795          href_like_1d(i)   = 0
 796          href_unlike_1d(i) = 0
 797          hinc_like_1d(i)   = 0
 798          hinc_unlike_1d(i) = 0
 799          hist1_pt_1(i)     = 0
 800          hist1_pt_2(i)     = 0
 801          hist1_phi_1(i)    = 0
 802          hist1_phi_2(i)    = 0
 803          hist1_eta_1(i)    = 0
 804          hist1_eta_2(i)    = 0
 805          htmp1_pt_1(i)     = 0
 806          htmp1_pt_2(i)     = 0
 807          htmp1_phi_1(i)    = 0
 808          htmp1_phi_2(i)    = 0
 809          htmp1_eta_1(i)    = 0
 810          htmp1_eta_2(i)    = 0
 811          href1_pt_1(i)     = 0
 812          href1_pt_2(i)     = 0
 813          href1_phi_1(i)    = 0
 814          href1_phi_2(i)    = 0
 815          href1_eta_1(i)    = 0
 816          href1_eta_2(i)    = 0
 817          hinc1_pt_1(i)     = 0
 818          hinc1_pt_2(i)     = 0
 819          hinc1_phi_1(i)    = 0
 820          hinc1_phi_2(i)    = 0
 821          hinc1_eta_1(i)    = 0
 822          hinc1_eta_2(i)    = 0
 823       end do
 824
 825       do i = 1,max_h_3d
 826       do j = 1,max_h_3d
 827       do k = 1,max_h_3d
 828          hist_like_3d_fine(i,j,k)     = 0
 829          hist_unlike_3d_fine(i,j,k)   = 0
 830          hist_like_3d_coarse(i,j,k)   = 0
 831          hist_unlike_3d_coarse(i,j,k) = 0
 832          htmp_like_3d_fine(i,j,k)     = 0
 833          htmp_unlike_3d_fine(i,j,k)   = 0
 834          htmp_like_3d_coarse(i,j,k)   = 0
 835          htmp_unlike_3d_coarse(i,j,k) = 0
 836          href_like_3d_fine(i,j,k)     = 0
 837          href_unlike_3d_fine(i,j,k)   = 0
 838          href_like_3d_coarse(i,j,k)   = 0
 839          href_unlike_3d_coarse(i,j,k) = 0
 840          hinc_like_3d_fine(i,j,k)     = 0
 841          hinc_unlike_3d_fine(i,j,k)   = 0
 842          hinc_like_3d_coarse(i,j,k)   = 0
 843          hinc_unlike_3d_coarse(i,j,k) = 0
 844       end do
 845       end do
 846       end do
 847
 848       do i = 1,max_c2_1d
 849          c2mod_like_1d(i)   = 0.0
 850          c2mod_unlike_1d(i) = 0.0
 851          c2fit_like_1d(i)   = 0.0
 852          c2fit_unlike_1d(i) = 0.0
 853          c2err_like_1d(i)   = 0.0
 854          c2err_unlike_1d(i) = 0.0
 855       end do
 856
 857       do i = 1,max_c2_3d
 858       do j = 1,max_c2_3d
 859       do k = 1,max_c2_3d
 860          c2mod_like_3d_fine(i,j,k)     = 0.0
 861          c2mod_unlike_3d_fine(i,j,k)   = 0.0
 862          c2mod_like_3d_coarse(i,j,k)   = 0.0
 863          c2mod_unlike_3d_coarse(i,j,k) = 0.0
 864          c2fit_like_3d_fine(i,j,k)     = 0.0
 865          c2fit_unlike_3d_fine(i,j,k)   = 0.0
 866          c2fit_like_3d_coarse(i,j,k)   = 0.0
 867          c2fit_unlike_3d_coarse(i,j,k) = 0.0
 868          c2err_like_3d_fine(i,j,k)     = 0.0
 869          c2err_unlike_3d_fine(i,j,k)   = 0.0
 870          c2err_like_3d_coarse(i,j,k)   = 0.0
 871          c2err_unlike_3d_coarse(i,j,k) = 0.0
 872       end do
 873       end do
 874       end do
 875
 876       do i = 1,max_c2_coul
 877          c2_coul_like(i)   = 0.0
 878          c2_coul_unlike(i) = 0.0
 879          q_coul(i)         = 0.0
 880       end do
 881
 882       do i = 1,max_events
 883          num_iter(i)                      = 0.0
 884          n_part_used_1_store(i)           = 0.0
 885          n_part_used_2_store(i)           = 0.0
 886          num_sec_flagged_store(i)         = 0.0
 887          frac_trks_out(i)                 = 0.0
 888          frac_trks_flag(i)                = 0.0
 889          chisq_like_1d_store(i)           = 0.0
 890          chisq_unlike_1d_store(i)         = 0.0
 891          chisq_like_3d_fine_store(i)      = 0.0
 892          chisq_unlike_3d_fine_store(i)    = 0.0
 893          chisq_like_3d_coarse_store(i)    = 0.0
 894          chisq_unlike_3d_coarse_store(i)  = 0.0
 895          chisq_hist1_1_store(i)           = 0.0
 896          chisq_hist1_2_store(i)           = 0.0
 897          chisq_total_store(i)             = 0.0
 898       end do
 899
 900       Return
 901       END
 902
 903 C---------------------------------------------------------------------
 904
 905
 906       subroutine set_values
 907       implicit none
 908
 909 CCC   This subroutine sets parameters based on the main input.
 910 CCC   The consistency of the input parameters and controls is
 911 CCC   checked.  Any problems are reported in the Log File,
 912 CCC   'hbt_log.out'.  Most inconsistencies or array size limit
 913 CCC   overflows will cause the code execution to STOP.
 914
 915       Include 'common_parameters.inc'
 916       Include 'common_mesh.inc'
 917       Include 'common_histograms.inc'
 918       Include 'common_correlations.inc'
 919       Include 'common_coulomb.inc'
 920
 921       Include 'common_track.inc'
 922       Include 'common_track2.inc'
 923       Include 'common_sec_track.inc'
 924       Include 'common_sec_track2.inc'
 925       Include 'common_particle.inc'
 926
 927 CCC   Local Variable Type Declarations:
 928
 929       integer*4 iphistep, ptmaxsteps, iptstep
 930
 931       real*4 px1,py1,pz1,E1, pt1,phi1
 932       real*4 px2,py2,pz2,E2
 933       real*4 pt_step,phi_step
 934       real*4 pxstepmin, pxstepmax, pystepmin, pystepmax
 935
 936 CCC  Check Input Controls:
 937
 938       if(ref_control .lt. 1 .or. ref_control .gt. 2) then
 939          write(7,101) ref_control
 940          errorcode = 1
 941          Return
 942       end if
 943
 944       if(switch_1d .lt. 0 .or. switch_1d .gt. 3) then
 945          write(7,102) switch_1d
 946          errorcode = 1
 947          Return
 948       end if
 949
 950       if(switch_3d .lt. 0 .or. switch_3d .gt. 2) then
 951          write(7,103) switch_3d
 952          errorcode = 1
 953          Return
 954       end if
 955
 956       if(switch_type .lt. 1 .or. switch_type .gt. 3) then
 957          write(7,104) switch_type
 958          errorcode = 1
 959          Return
 960       end if
 961
 962       if(switch_coherence .lt. 0 .or. switch_coherence .gt. 1) then
 963          write(7,105) switch_coherence
 964          errorcode = 1
 965          Return
 966       end if
 967
 968       if(switch_coulomb .lt. 0 .or. switch_coulomb .gt. 3) then
 969          write(7,106) switch_coulomb
 970          errorcode = 1
 971          Return
 972       end if
 973
 974       if(switch_fermi_bose.ne.-1 .and. switch_fermi_bose.ne.1) then
 975          write(7,107) switch_fermi_bose
 976          errorcode = 1
 977          Return
 978       end if
 979
 980       if(n_pid_types .lt. 1 .or. n_pid_types .gt. 2) then
 981          write(7,108) n_pid_types
 982          errorcode = 1
 983          Return
 984       end if
 985
 986       if(switch_type .ge. 2 .and. n_pid_types .eq. 1) then
 987          write(7,109) switch_type, n_pid_types
 988          errorcode = 1
 989          Return
 990       end if
 991
 992       if(n_pid_types .eq. 1) then
 993          if(pid(1).gt.0 .and. pid(2).gt.0) then
 994             write(7,1091) pid(1),pid(2)
 995             errorcode = 1
 996             Return
 997          end if
 998       end if
 999
1000       if(pid(1).eq.0 .and. pid(2).eq.0) then
1001          write(7,1092)
1002          errorcode = 1
1003          Return
1004       end if
1005
1006       if(n_pid_types .eq. 2) then
1007          if(pid(1).gt.0.and.pid(2).gt.0.and.pid(1).ne.pid(2))then
1008             continue
1009          else
1010             write(7,1093) pid(1), pid(2)
1011             errorcode = 1
1012             Return
1013          end if
1014       end if
1015
1016       if(pid(1).gt.0.and.pid(2).gt.0.and.pid(1).eq.pid(2))then
1017          write(7,1094) pid(1), pid(2)
1018          errorcode = 1
1019          Return
1020       end if
1021
1022       if(trk_accep .le. 0.0) then
1023          write(7,10941) trk_accep
1024          errorcode = 1
1025          Return
1026
1027       end if
1028
1029 CCC   Check Input Parameters:
1030
1031       if(deltap .le. 0.0) deltap = 0.1
1032       if(maxit  .lt. 0  ) maxit = 50
1033       if(delchi .lt. 0.0) delchi = 0.1
1034       if(irand  .le. 0  ) irand = 12345
1035
1036 CCC   Check Coulomb source radius in range for Pratt type Coulomb correction.
1037
1038       if(switch_coulomb .eq. 3 .and. (Q0 .lt. coulradmin .or.
1039      1   Q0 .gt. coulradmax)) then
1040          write(7,132) Q0
1041          errorcode = 1
1042          Return
1043       end if
1044
1045 CCC   Load the Pratt type Coulomb correction if this form is selected.
1046
1047       if(switch_coulomb .eq. 3 .and. (Q0 .ge. coulradmin .and.
1048      1   Q0 .le. coulradmax)) then
1049          Call read_data(6)
1050       end if
1051
1052 CCC   Check and determine the one-body distribution's binning:
1053
1054       if(n_pt_bins .lt. 1 .or. n_pt_bins .gt. max_h_1d) then
1055          write(7,110) n_pt_bins
1056          errorcode = 1
1057          Return
1058       end if
1059
1060       if(n_phi_bins .lt. 1 .or. n_phi_bins .gt. max_h_1d) then
1061          write(7,111) n_phi_bins
1062          errorcode = 1
1063          Return
1064       end if
1065
1066       if(n_eta_bins .lt. 1 .or. n_eta_bins .gt. max_h_1d) then
1067          write(7,112) n_eta_bins
1068          errorcode = 1
1069          Return
1070       end if
1071
1072       if(pt_min .gt. pt_max .or. pt_min .lt. 0.0) then
1073          write(7,113) pt_min, pt_max
1074          errorcode = 1
1075          Return
1076       end if
1077
1078       if(phi_min.gt.phi_max .or. phi_min.lt.0.0 .or.
1079      1   phi_max.gt.360.0) then
1080          write(7,114) phi_min, phi_max
1081          errorcode = 1
1082          Return
1083       end if
1084
1085       if(eta_min .gt. eta_max) then
1086          write(7,115) eta_min, eta_max
1087          errorcode = 1
1088          Return
1089       end if
1090
1091       pt_bin_size  = (pt_max  - pt_min )/float(n_pt_bins)
1092       phi_bin_size = (phi_max - phi_min)/float(n_phi_bins)
1093       eta_bin_size = (eta_max - eta_min)/float(n_eta_bins)
1094
1095 CCC   Check and determine the two-body distribution's binning:
1096
1097       n_1d_total = n_1d_fine + n_1d_coarse
1098       n_3d_total = n_3d_fine + n_3d_coarse - 1
1099
1100       if(switch_1d .gt. 0) then
1101       if(n_1d_fine .lt. 1) then
1102          write(7,116) n_1d_fine
1103          errorcode = 1
1104          Return
1105       end if
1106
1107       if(n_1d_coarse .lt. 1) then
1108          write(7,117) n_1d_coarse
1109          errorcode = 1
1110          Return
1111       end if
1112
1113       if(n_1d_total .gt. max_h_1d) then
1114          write(7,118) n_1d_total
1115          errorcode = 1
1116          Return
1117       end if
1118
1119       qmid_1d = binsize_1d_fine  *float(n_1d_fine)
1120       qmax_1d = binsize_1d_coarse*float(n_1d_coarse) + qmid_1d
1121       end if
1122
1123       if(switch_3d .gt. 0) then
1124       if(n_3d_fine .lt. 1 .or. n_3d_fine .gt. max_h_3d) then
1125          write(7,119) n_3d_fine
1126          errorcode = 1
1127          Return
1128       end if
1129
1130       if(n_3d_coarse .lt. 1 .or. n_3d_coarse .gt. max_h_3d) then
1131          write(7,120) n_3d_coarse
1132          errorcode = 1
1133          Return
1134       end if
1135
1136       qmid_3d = binsize_3d_fine  *float(n_3d_fine)
1137       qmax_3d = binsize_3d_coarse*float(n_3d_coarse)
1138
1139       if(abs(qmid_3d - binsize_3d_coarse) .gt. 0.00001) then
1140          write(7,121) qmid_3d, binsize_3d_coarse
1141          errorcode = 1
1142          Return
1143       end if
1144
1145       if(n_3d_fine_project .gt. n_3d_fine) then
1146          write(7,1211) n_3d_fine_project, n_3d_fine
1147          n_3d_fine_project = n_3d_fine
1148       end if
1149
1150       if(n_3d_fine_project .lt. 1) then
1151          write(7,1212) n_3d_fine_project
1152          n_3d_fine_project = 1
1153       end if
1154       end if
1155
1156 CCC   Check and determine Track-Sector Parameters:
1157
1158       if(n_px_bins .lt. 1) then
1159          write(7,122) n_px_bins
1160          errorcode = 1
1161          Return
1162       end if
1163
1164       if(n_py_bins .lt. 1) then
1165          write(7,123) n_py_bins
1166          errorcode = 1
1167          Return
1168       end if
1169
1170       if(n_pz_bins .lt. 1) then
1171          write(7,124) n_pz_bins
1172          errorcode = 1
1173          Return
1174       end if
1175
1176       n_sectors = n_px_bins * n_py_bins * n_pz_bins
1177       if(n_sectors .gt. sec_maxlen) then
1178          write(7,125) n_sectors
1179          errorcode = 1
1180          Return
1181       end if
1182
1183       if(n_sectors .gt. sec_maxlen2 .and. ref_control .eq. 2) then
1184          write(7,1251) n_sectors
1185          errorcode = 1
1186          Return
1187       end if
1188
1189       if(trk_maxlen .ne. trk2_maxlen .and. ref_control .eq. 2) then
1190          write(7,1252)
1191          errorcode = 1
1192          Return
1193       end if
1194
1195       if(max_trk_save .ne. max_trk_sec .or.
1196      1   max_trk_save .ne. max_trk_sec2 .or.
1197      2   max_trk_sec  .ne. max_trk_sec2) then
1198          write(7,12521) max_trk_save,max_trk_sec,max_trk_sec2
1199          errorcode = 1
1200          Return
1201       end if
1202
1203       delpx = (px_max - px_min)/float(n_px_bins)
1204       delpy = (py_max - py_min)/float(n_py_bins)
1205       delpz = (pz_max - pz_min)/float(n_pz_bins)
1206
1207 CCC   Check that the Track-Sector Grid includes the acceptance range:
1208 CCC   The Track-Sector Grid is a 3D {px,py,pz} box, while the acceptance
1209 CCC   is defined in cylindrical {pt,phi,eta} coordinates.
1210 CCC
1211 CCC   Check the z-momentum components:
1212
1213       if(eta_min .ge. 0.0) then
1214          Call Hbtp_kin(px1,py1,pz1,E1,pt_min,0.0,eta_min,0.14,2)
1215          Call Hbtp_kin(px2,py2,pz2,E2,pt_max,0.0,eta_max,0.14,2)
1216       else if(eta_max .le. 0.0) then
1217          Call Hbtp_kin(px1,py1,pz1,E1,pt_max,0.0,eta_min,0.14,2)
1218          Call Hbtp_kin(px2,py2,pz2,E2,pt_min,0.0,eta_max,0.14,2)
1219       else if(eta_min .le. 0.0 .and. eta_max .ge. 0.0) then
1220          Call Hbtp_kin(px1,py1,pz1,E1,pt_max,0.0,eta_min,0.14,2)
1221          Call Hbtp_kin(px2,py2,pz2,E2,pt_max,0.0,eta_max,0.14,2)
1222       end if
1223
1224       if(pz1 .lt. pz_min .or. pz2 .gt. pz_max) then
1225          write(7,126) pz1,pz_min,pz2,pz_max
1226          errorcode = 1
1227          Return
1228       end if
1229
1230 CCC   Check the x,y-momentum components by scanning over the perimeter
1231 CCC   of the (pt,phi) acceptance domain space with 100 trial grid points.
1232 CCC   The overall required px_min, px_max, py_min and py_max to cover the
1233 CCC   acceptance by the track-sectors is determined.  These values are
1234 CCC   then compared with the min/max px and py ranges for the track-sectors.
1235 CCC
1236 CCC   Divide the pt and phi acceptance ranges into 24 equal steps:
1237
1238       pt_step  = (pt_max  - pt_min)/24.0
1239       phi_step = (phi_max - phi_min)/24.0
1240       pxstepmax = -1000.
1241       pxstepmin =  1000.
1242       pystepmax = -1000.
1243       pystepmin =  1000.
1244       phi1 = phi_min - phi_step
1245       do iphistep = 1,25
1246          phi1 = phi1 + phi_step
1247          ptmaxsteps = 2
1248          if(iphistep.eq.1 .or. iphistep.eq.25) ptmaxsteps = 25
1249          pt1 = pt_min - pt_step
1250          do iptstep = 1,ptmaxsteps
1251             if(iphistep.eq.1 .or. iphistep.eq.25) then
1252                pt1 = pt1 + pt_step
1253             else if(iphistep.gt.1 .and. iphistep.lt.25) then
1254                if(iptstep.eq.1) pt1 = pt_min
1255                if(iptstep.eq.2) pt1 = pt_max
1256             end if
1257             Call Hbtp_kin(px1,py1,pz1,E1,pt1,phi1,0.0,0.14,2)
1258                if(px1.gt.pxstepmax) pxstepmax = px1
1259                if(px1.lt.pxstepmin) pxstepmin = px1
1260                if(py1.gt.pystepmax) pystepmax = py1
1261                if(py1.lt.pystepmin) pystepmin = py1
1262          end do
1263       end do
1264
1265       if(pxstepmin .lt. px_min .or. pxstepmax .gt. px_max) then
1266          write(7,127) pxstepmin,px_min,pxstepmax,px_max
1267          errorcode = 1
1268          Return
1269       end if
1270
1271       if(pystepmin .lt. py_min .or. pystepmax .gt. py_max) then
1272          write(7,128) pystepmin,py_min,pystepmax,py_max
1273          errorcode = 1
1274          Return
1275       end if
1276
1277 CCC   Load Geant Particle Data:
1278       Call Hbtp_particle_prop
1279
1280 CCC   Check Requested Particle ID Numbers:
1281
1282       if(n_pid_types.eq.1 .and. pid(1).le.0 .and. pid(2).le.0) then
1283          write(7,131) pid(1),pid(2)
1284          errorcode = 1
1285          Return
1286       end if
1287
1288 CCC   Initialize Masses to 0.0
1289
1290       mass1 = 0.0
1291       mass2 = 0.0
1292
1293       if(n_pid_types .eq. 1 .and. pid(1) .ne. 0) then
1294          if(pid(1) .lt. 1 .or. pid(1) .gt. part_maxlen) then
1295             write(7,129) pid(1)
1296             errorcode = 1
1297             Return
1298          else
1299             mass1 = part_mass(pid(1))
1300          end if
1301       else if(n_pid_types .eq. 1 .and. pid(2) .ne. 0) then
1302          if(pid(2) .lt. 1 .or. pid(2) .gt. part_maxlen) then
1303             write(7,130) pid(2)
1304             errorcode = 1
1305             Return
1306          else
1307             mass2 = part_mass(pid(2))
1308          end if
1309       else if(n_pid_types .eq. 2) then
1310          if(pid(1) .lt. 1 .or. pid(1) .gt. part_maxlen) then
1311             write(7,129) pid(1)
1312             errorcode = 1
1313             Return
1314          else
1315             mass1 = part_mass(pid(1))
1316          end if
1317          if(pid(2) .lt. 1 .or. pid(2) .gt. part_maxlen) then
1318             write(7,130) pid(2)
1319             errorcode = 1
1320             Return
1321          else
1322             mass2 = part_mass(pid(2))
1323          end if
1324       end if
1325
1326 CCC   Set Math Constants:
1327
1328       pi = 3.141592654
1329       hbc = 0.19732891
1330       rad = 180.0/pi
1331
1332 CCC   FORMATS:
1333
1334 101   Format(5x,'ref_control = ',I5,'Out of Range - STOP')
1335 102   Format(5x,'switch_1d   = ',I5,'Out of Range - STOP')
1336 103   Format(5x,'switch_3d   = ',I5,'Out of Range - STOP')
1337 104   Format(5x,'switch_type = ',I5,'Out of Range - STOP')
1338 105   Format(5x,'switch_coherence = ',I5,'Out of Range - STOP')
1339 106   Format(5x,'switch_coulomb = ',I5,'Out of Range - STOP')
1340 107   Format(5x,'switch_fermi_bose = ',I5,'Out of Range - STOP')
1341 108   Format(5x,'n_pid_types = ',I5,'Out of Range - STOP')
1342 109   Format(5x,'switch_type & n_pid_types = ',2I5,
1343      1       'Incompatible - STOP')
1344 1091  Format(5x,'For n_pid_types=1, cannot have both PID#1,2 = ',
1345      1       2I5,' .ne.0 - STOP')
1346 1092  Format(5x,'Both PID# 1 and 2 = 0, - STOP')
1347 1093  Format(5x,'For n_pid_types=2, PID#1,2 = ',2I5,
1348      1      ' are incorrect - STOP')
1349 1094  Format(5x,'Both PID# 1,2 = ',2I5,' are equal - STOP')
1350 10941 Format(5x,'Track acceptance output frac .le. 0.0 - STOP')
1351 132   Format(5x,'Coulomb source radius = ',E12.4,' - For Pratt ',
1352      1       'Correction, Out of Range - STOP')
1353 110   Format(5x,'# pt bins  = ',I5,'Out of Range - STOP')
1354 111   Format(5x,'# phi bins = ',I5,'Out of Range - STOP')
1355 112   Format(5x,'# eta bins = ',I5,'Out of Range - STOP')
1356 113   Format(5x,'pt min/max accept. range = ',2E12.4,' is wrong-STOP')
1357 114   Format(5x,'phi min/max accept. range = ',2E12.4,' is wrong-STOP')
1358 115   Format(5x,'eta min/max accept. range = ',2E12.4,' is wrong-STOP')
1359 116   Format(5x,'# 1d fine mesh for C2 = ',I5,' .lt.1 - STOP')
1360 117   Format(5x,'# 1d coarse mesh for C2 = ',I5,' .lt.1 - STOP')
1361 118   Format(5x,'Total # 1d mesh for C2 = ',I5,' .gt.max_h_1d - STOP')
1362 119   Format(5x,'# 3d fine mesh for C2 = ',I5,'Out of Range - STOP')
1363 120   Format(5x,'# 3d coarse mesh for C2 = ',I5,'Out of Range - STOP')
1364 121   Format(5x,'3D C2 fine range & coarse grid = ',2E12.4,
1365      1       'Not Equal - STOP')
1366 1211  Format(5x,'# 3D fine bins projected = ',I5,
1367      1       ' TOO BIG - reduce to n_3d_fine = ',I5)
1368 1212  Format(5x,'# 3D fine bins projected = ',I5,
1369      1       ' Set to 1')
1370 122   Format(5x,'#track-sector px bins = ',I5,' .lt.1 - STOP')
1371 123   Format(5x,'#track-sector py bins = ',I5,' .lt.1 - STOP')
1372 124   Format(5x,'#track-sector pz bins = ',I5,' .lt.1 - STOP')
1373 125   Format(5x,'Total # trk-sec = ',I5,' .gt.sec_maxlen - STOP')
1374 1251  Format(5x,'Total # trk-sec = ',I5,' .gt.sec_maxlen2 for ',
1375      1       'Reference calc. - STOP')
1376 1252  Format(5x,'trk_maxlen .ne. trk2_maxlen for Ref. Calc. - STOP')
1377 12521 Format(5x,'max_trk_save,max_trk_sec,max_trk_sec2 = ',
1378      1       3I5,' are not all equal - STOP')
1379 126   Format(5x,'pz accept. not covered by sectors-STOP:',4E12.4)
1380 127   Format(5x,'px accept. not covered by sectors-STOP:',4E12.4)
1381 128   Format(5x,'py accept. not covered by sectors-STOP:',4E12.4)
1382 131   Format(5x,'Particle ID values = ',2I5,' not valid - STOP')
1383 129   Format(5x,'Particle ID value #1 = ',I5,' not valid - STOP')
1384 130   Format(5x,'Particle ID value #2 = ',I5,' not valid - STOP')
1385
1386       Return
1387       END
1388
1389 C----------------------------------------------------------------------
1390
1391
1392       subroutine read_data(mode)
1393       implicit none
1394
1395 CCC   This subroutine does all the data input associated with all input
1396 C     files.  Some diagnostic output is printed here if errors occur
1397 C     during the file reading.  Two auxiliary output files, which tag
1398 C     the events input tracks are written out.
1399 C
1400 C     The type of input is controlled by the value of 'mode'
1401 C     where:
1402 C     (The following mostly applies to the standalone application
1403 C     that reads from files and writes temporary scratch files.
1404 C     This is the ALICE=0 mode.)
1405 C
1406 C        mode = 1, read the parameter and switches input file
1407 C
1408 C        mode = 2, scan the event text file and write out two
1409 C                  auxiliary output/tag files; select and mark
1410 C                  accepted tracks to use.
1411 C
1412 C        mode = 3, read the reference pair and one-body histograms
1413 C
1414 C        mode = 4, read the next event from the event text file,
1415 C                  'event_text.in,' and load the accepted tracks
1416 C                  into the 'trk' data structure.
1417 C
1418 C        mode = 5, same as mode=4, except the accepted tracks are
1419 C                  loaded into the 'trk2' data structure.
1420 C
1421 C        mode = 6, read the input Coulomb correction tables and
1422 C                  interpolate for the requested source radius, arrays
1423 C                  in common/coulomb/ are filled for like and unlike
1424 C                  charged pairs.
1425 C
1426 C        mode = 7, read the next event from the event text file,
1427 C                  'event_text.in,' and load the accepted tracks
1428 C                  into the 'trk' data structure. Then copy the event
1429 C                  data in 'event_text.in' to 'event_text_aux.in' and
1430 C                  from 'event_tracks.select' to 'event_tracks_aux.select'
1431 C
1432 C        mode = 8, read contents of 'event_text_aux.in' using flag values
1433 C                  in 'event_tracks_aux.select' and copy into
1434 C                  'event_hbt_text.out' (i.e. the main event output file)
1435 C                  where the momentum values for accepted tracks are
1436 C                  overwritten with the adjusted (correlated) parameters
1437 C                  in the 'trk' data structure.
1438 C
1439 C                  If trk_accep .lt. 1.0, then only write this fraction
1440 C                  of the final tracks, as determined by a random number
1441 C                  throw.
1442 C
1443 C     Summary of Files:
1444 C     ----------------
1445 C
1446 C File Unit #        Filename               Description
1447 C ---------------------------------------------------------------------------
1448 C     1       hbt_parameters.in          Input switches, parameters
1449 C     2       event_text.in              Event Gen output, GSTAR text format
1450 C     3       event_line.flags           Event file line flags
1451 C     4       event_tracks.select        Event file selected tracks
1452 C     7       hbt_log.out                Log and error messages
1453 C     8       hbt_simulation.out         Full Output
1454 C     9       hbt_pair_reference.hist    Reference pair histograms
1455 C    10       event_hbt_text.out         Updated/correlated event text file
1456 C    11       hbt_singles_reference.hist Reference one-body histograms
1457 C    12       event_text_aux.in          Tmp. copy of 'event_text.in'/event
1458 C    14       event_tracks_aux.select    Tmp. copy 'event_tracks.select'/event
1459 C   21-27     cpp_*.dat (*=06,08,...18)  Like pair Pratt Coul. Correct
1460 C   31-37     cpm_*.dat (*=06,08,...18)  Unlike pair Pratt Coul. Correct
1461 C ---------------------------------------------------------------------------
1462 C
1463
1464       Include 'common_parameters.inc'
1465       Include 'common_mesh.inc'
1466       Include 'common_histograms.inc'
1467       Include 'common_correlations.inc'
1468       Include 'common_coulomb.inc'
1469
1470       Include 'common_track.inc'
1471       Include 'common_track2.inc'
1472       Include 'common_particle.inc'
1473
1474       integer LNBLNK
1475
1476 CCC   Local Variable Type Declarations:
1477
1478       real*4 px,py,pz,E,pt,phi,eta,mass
1479       real*4 acheck(10), function(20)
1480       real*4 hbtpran
1481
1482       integer*4 i,j,k,mode,flag,flag4,flag0,ntracks
1483       integer*4 ge_pid,tid,start_v,stop_v,eg_pid
1484       integer*4 ref_check,pidok,accepok,check(13)
1485       integer*4 event_counter,track_counter
1486       integer*4 track_counter_1,track_counter_2
1487
1488       character*5 evg_label,event_line,vertex_line,track_line,dummy
1489       character*5 gener_line
1490       character*80 comment_event_label
1491       character*87 vertex_label
1492       character*93 gener_label
1493
1494       parameter (event_line  = 'EVENT')
1495       parameter (vertex_line = 'VERTE')
1496       parameter (track_line  = 'TRACK')
1497       parameter (gener_line  = 'GENER')
1498       parameter (flag4 = 4)
1499       parameter (flag0 = 0)
1500 C     ALICE USE ONLY
1501       CHARACTER*100 CHROOT
1502       CHARACTER*100 FILNAM
1503       INTEGER*4 LNROOT
1504       LOGICAL EXISTS
1505       CHROOT=' '
1506 C
1507
1508 CCC   Begin Data Input Options:
1509
1510 C------------------------
1511       IF (mode.eq.1) THEN              ! Read Input parameters from File#1
1512 C------------------------
1513
1514 CCC   For standalone version (ALICE = 0), read parameters from
1515 CCC   File Unit=1, 'hbt_parameters.in'
1516 CCC   For ALICE-ROOT version (ALICE=1) load parameters from Call to C++ funct
1517       If(ALICE .eq. 1) then
1518          Call AliHbtp_SetParameters
1519       Else If(ALICE .eq. 0) Then
1520
1521          open(unit=1,status='old',access='sequential',
1522      1        file='hbt_parameters.in')
1523
1524 CCC   Read Control Switches:  (See Main program listing for complete
1525 CCC                            description of input parameters)
1526
1527       read(1,*) ref_control
1528       read(1,*) switch_1d
1529       read(1,*) switch_3d
1530       read(1,*) switch_type
1531       read(1,*) switch_coherence
1532       read(1,*) switch_coulomb
1533       read(1,*) switch_fermi_bose
1534       read(1,*) trk_accep
1535       read(1,*) print_full
1536       read(1,*) print_sector_data
1537
1538 CCC   Read Parameters:
1539
1540       read(1,*) n_pid_types
1541       read(1,*) pid(1),pid(2)
1542       read(1,*) deltap
1543       read(1,*) maxit
1544       read(1,*) delchi
1545       read(1,*) irand
1546
1547 CCC   Read Source Parameters:
1548
1549       read(1,*) lambda
1550       read(1,*) R_1d
1551       read(1,*) Rside, Rout, Rlong
1552       read(1,*) Rperp, Rparallel, R0
1553       read(1,*) Q0
1554
1555 CCC   Read one-body {pt,phi,eta} bins:
1556
1557       read(1,*) n_pt_bins ,pt_min ,pt_max
1558       read(1,*) n_phi_bins,phi_min,phi_max
1559       read(1,*) n_eta_bins,eta_min,eta_max
1560
1561 CCC   Read two-body 1D and 3D bins:
1562
1563       read(1,*) n_1d_fine,   binsize_1d_fine
1564       read(1,*) n_1d_coarse, binsize_1d_coarse
1565       read(1,*) n_3d_fine,   binsize_3d_fine
1566       read(1,*) n_3d_coarse, binsize_3d_coarse
1567       read(1,*) n_3d_fine_project
1568
1569 CCC   Read momentum space track sector bins in {px,py,pz}:
1570
1571       read(1,*) n_px_bins,px_min,px_max
1572       read(1,*) n_py_bins,py_min,py_max
1573       read(1,*) n_pz_bins,pz_min,pz_max
1574
1575 CCC   Relative Chi-Square weights for track adjustment fitting:
1576
1577       read(1,*) chisq_wt_like_1d
1578       read(1,*) chisq_wt_unlike_1d
1579       read(1,*) chisq_wt_like_3d_fine
1580       read(1,*) chisq_wt_unlike_3d_fine
1581       read(1,*) chisq_wt_like_3d_coarse
1582       read(1,*) chisq_wt_unlike_3d_coarse
1583       read(1,*) chisq_wt_hist1_1
1584       read(1,*) chisq_wt_hist1_2
1585
1586       Close(unit=1)
1587       End If  !  ALICE Data I/O Option
1588
1589 C-----------------------------
1590       ELSE IF (mode.eq.2) THEN
1591 C-----------------------------
1592
1593 C     Open event generator text file, 'event_text.in,' and read it,
1594 C     noting each type of line input.  Write out a file called
1595 C     'event_line.flags' which identifies the type of information on
1596 C     each line where:
1597 C
1598 C        'EVENT:'  lines are assigned flag = 1
1599 C        'VERTEX:' lines are assigned flag = 2
1600 C        'TRACK:'  lines are assigned flag = 3
1601 C        'GENER:'  lines are assigned flag = 5
1602 C        All other lines are assigned flag = 0
1603
1604       If(ALICE .eq. 0) Then
1605       open(unit=2,status='old',access='sequential',
1606      1     file='event_text.in')
1607       open(unit=3,status='unknown',access='sequential',
1608      1     file='event_line.flags')
1609
1610 CCC   Set Event Counter:
1611
1612       event_counter = 0
1613 30    read(2,10,err=20,end=25) evg_label
1614 10    Format(A)
1615       if(evg_label .eq. event_line) then
1616          event_counter = event_counter + 1
1617          flag = 1
1618       else if(evg_label .eq. vertex_line) then
1619          flag = 2
1620       else if(evg_label .eq. track_line) then
1621          flag = 3
1622       else if(evg_label .eq. gener_line) then
1623          flag = 5
1624       else
1625          flag = 0
1626       end if
1627
1628       write(3,11) flag
1629 11    Format(1x,I1)
1630       go to 30         ! Return to S.N. 30 and read next line in file
1631 20    write(7,12) event_counter
1632 12    Format(5x,'Read error in event_text.in at event# ',I5,' - STOP')
1633       Stop
1634 25    Continue
1635       Close(unit=2)
1636       Close(unit=3)
1637       End If  !  ALICE Data I/O Option
1638
1639 C     Next, re-open the 'event_text.in' and 'event_line.flags' files
1640 C     again and read thru the entire files.  For each track, check its'
1641 C     particle ID and kinematics (pt,phi,eta) with respect to the
1642 C     selected particle ID type(s) for the run and the acceptances.
1643 C     Fill another file called, 'event_tracks.select,' which is the same
1644 C     as 'event_line.flags' except that the accepted tracks are marked
1645 C     with flag = 4.
1646 C
1647 C     NOTE:  Assume all vertices in 'event_text.in' are at microscopic
1648 C            distances (fermis) such that all particles in the event
1649 C            file are considered as primaries.  Also for each event
1650 C            the code will only accept tracks up to the limit imposed
1651 C            by trk_maxlen in the 'trk' table.
1652
1653       If(ALICE .eq. 1) Then
1654 CCC   For ALICE application do the following:
1655 CCC      Store number of events in 'n_events'
1656 CCC      Count number accepted tracks in each event, check wrt trk_maxlen
1657 CCC      Mark accepted tracks in all events
1658
1659          Call AliHbtp_GetNumberEvents(n_events)
1660          do i = 1,n_events
1661             Call AliHbtp_SetActiveEventNumber(i)
1662             track_counter = 0
1663             Call AliHbtp_GetNumberTracks(ntracks)
1664             do j = 1,ntracks
1665                Call AliHbtp_GetTrack(j,flag,px,py,pz,ge_pid)
1666                eg_pid = ge_pid
1667 CCC   Check if this track's particle ID is one to be used
1668
1669          pidok = 0
1670          accepok = 0
1671          if(pid(1).gt.0 .and. eg_pid.eq.pid(1)) pidok = 1
1672          if(pid(2).gt.0 .and. eg_pid.eq.pid(2)) pidok = 1
1673          if(pidok.eq.1 .and. eg_pid.le.part_maxlen) then
1674             mass = part_mass(eg_pid)
1675             Call Hbtp_kin(px,py,pz,E,pt,phi,eta,mass,1)
1676             if(pt.ge.pt_min .and. pt.le.pt_max .and.
1677      1         phi.ge.phi_min .and. phi.le.phi_max .and.
1678      2         eta.ge.eta_min .and. eta.le.eta_max) then
1679                if(track_counter .lt. trk_maxlen) then
1680                   accepok = 1
1681                else
1682                   write(7,62) trk_maxlen, event_counter
1683 62                Format(5x,'#tracks exceeds trk_maxlen = ',
1684      1                  I6,' for event#',I4)
1685                end if
1686             end if
1687          end if
1688
1689          if(pidok.eq.1 .and. accepok.eq.1) then
1690             track_counter = track_counter + 1
1691 C           write(*,*) '  FFF: 1 calling PutTrack j = ',j
1692             Call AliHbtp_PutTrack(j,flag4,px,py,pz,ge_pid)
1693          else
1694 C           write(*,*) '  FFF: 2 calling PutTrack j = ',j
1695             Call AliHbtp_PutTrack(j,flag0,px,py,pz,ge_pid)
1696          end if
1697          end do
1698          end do
1699
1700       Else If(ALICE .eq. 0) Then
1701
1702       open(unit=2,status='old',access='sequential',
1703      1     file='event_text.in')
1704       open(unit=3,status='old',access='sequential',
1705      1     file='event_line.flags')
1706       open(unit=4,status='unknown',access='sequential',
1707      1     file='event_tracks.select')
1708
1709 CCC   Set Event Counter:
1710
1711       event_counter = 0
1712 40    read(3,11,err=45,end=50) flag
1713       if(flag.eq.1) then
1714          event_counter = event_counter + 1
1715          track_counter = 0
1716       end if
1717
1718       if(flag.ne.3) then
1719          read(2,10) dummy
1720          write(4,11) flag
1721       else if(flag.eq.3) then
1722          read(2,41,err=46,end=50) ge_pid,px,py,pz,tid,start_v,
1723      1                            stop_v,eg_pid
1724 41    Format(7x,I6,3(1x,G12.5),4(1x,I6))
1725
1726 CCC   Check if the 'event_text.in' file includes non-zero PID
1727 CCC   values for the variable 'eg_pid'.  If this is zero, then
1728 CCC   use the ge_pid value.
1729          if(eg_pid.eq.0 .and. ge_pid.ne.0) eg_pid = ge_pid
1730
1731 CCC   Check if this track's particle ID is one to be used
1732
1733          pidok = 0
1734          accepok = 0
1735          if(pid(1).gt.0 .and. eg_pid.eq.pid(1)) pidok = 1
1736          if(pid(2).gt.0 .and. eg_pid.eq.pid(2)) pidok = 1
1737          if(pidok.eq.1 .and. eg_pid.le.part_maxlen) then
1738             mass = part_mass(eg_pid)
1739             Call Hbtp_kin(px,py,pz,E,pt,phi,eta,mass,1)
1740             if(pt.ge.pt_min .and. pt.le.pt_max .and.
1741      1         phi.ge.phi_min .and. phi.le.phi_max .and.
1742      2         eta.ge.eta_min .and. eta.le.eta_max) then
1743                if(track_counter .lt. trk_maxlen) then
1744                   accepok = 1
1745                else
1746                   write(7,621) trk_maxlen, event_counter
1747 621                Format(5x,'#tracks exceeds trk_maxlen = ',
1748      1                  I6,' for event#',I4)
1749                end if
1750             end if
1751          end if
1752
1753          if(pidok.eq.1 .and. accepok.eq.1) then
1754             track_counter = track_counter + 1
1755             write(4,11) flag4
1756          else
1757             write(4,11) flag
1758          end if
1759
1760       end if    ! End Flag=3 options
1761
1762       go to 40  ! Return to S.N. 40 and read next record
1763 45    write(7,60) event_counter
1764 60    Format(5x,'Read error in event_line.flags at event#',I5,
1765      1       ' - STOP')
1766       Stop
1767 46    write(7,61) event_counter
1768 61    Format(5x,'Read error in event_text.in (2nd pass) at event#',I5,
1769      1       ' - STOP')
1770       Stop
1771 50    Continue
1772
1773       n_events = event_counter - 1  !  Set # events in event_text.in file
1774 C                                   !  This is one less than the counter
1775 C                                   !  value since the last 'EVENT:' line is
1776 C                                   !  used to mark the End-of-File.
1777
1778       Close(unit=2)
1779       Close(unit=3)
1780       Close(unit=4)
1781
1782       End If    !  ALICE Data I/O Option
1783
1784 C-----------------------------
1785       ELSE IF(mode.eq.3) THEN
1786 C-----------------------------
1787
1788 C     Read the reference histograms for pairs, then for singles for one
1789 C     or two particle ID types.  Check switches, bins and mesh information
1790 C     to be sure the input reference histograms are compatible with the
1791 C     present run conditions.
1792
1793       open(unit=9,status='old',access='sequential',
1794      1     file='hbt_pair_reference.hist')
1795
1796       read(9,*) (check(i),i=1,3)
1797       read(9,*)  check(4),acheck(1),acheck(2)
1798       read(9,*)  check(5),acheck(3),acheck(4)
1799       read(9,*)  check(6),acheck(5),acheck(6)
1800       read(9,*) (check(i),i=7,9)
1801       read(9,*) (check(i),i=10,13)
1802       read(9,*) (acheck(i),i=7,10)
1803       read(9,*) num_pairs_like_ref, num_pairs_unlike_ref
1804
1805 CCC   Determine if the Input Reference pair histograms are compatible
1806 CCC   with the present run parameters:
1807
1808       ref_check = 1
1809       if(check(1)  .ne. n_pid_types ) ref_check = 0
1810       if(check(2)  .ne. pid(1)      ) ref_check = 0
1811       if(check(3)  .ne. pid(2)      ) ref_check = 0
1812       if(check(4)  .ne. n_pt_bins   ) ref_check = 0
1813       if(check(5)  .ne. n_phi_bins  ) ref_check = 0
1814       if(check(6)  .ne. n_eta_bins  ) ref_check = 0
1815       if(check(7)  .ne. switch_1d   ) ref_check = 0
1816       if(check(8)  .ne. switch_3d   ) ref_check = 0
1817       if(check(9)  .ne. switch_type ) ref_check = 0
1818       if(check(10) .ne. n_1d_fine   ) ref_check = 0
1819       if(check(11) .ne. n_1d_coarse ) ref_check = 0
1820       if(check(12) .ne. n_3d_fine   ) ref_check = 0
1821       if(check(13) .ne. n_3d_coarse ) ref_check = 0
1822
1823       if(abs(acheck( 1) - pt_min )         .gt. 0.000001) ref_check = 0
1824       if(abs(acheck( 2) - pt_max )         .gt. 0.000001) ref_check = 0
1825       if(abs(acheck( 3) - phi_min )        .gt. 0.000001) ref_check = 0
1826       if(abs(acheck( 4) - phi_max )        .gt. 0.000001) ref_check = 0
1827       if(abs(acheck( 5) - eta_min )        .gt. 0.000001) ref_check = 0
1828       if(abs(acheck( 6) - eta_max )        .gt. 0.000001) ref_check = 0
1829       if(abs(acheck( 7) - binsize_1d_fine) .gt. 0.000001) ref_check = 0
1830       if(abs(acheck( 8) - binsize_1d_coarse).gt.0.000001) ref_check = 0
1831       if(abs(acheck( 9) - binsize_3d_fine) .gt. 0.000001) ref_check = 0
1832       if(abs(acheck(10) - binsize_3d_coarse).gt.0.000001) ref_check = 0
1833
1834       if(ref_check .eq. 0) then
1835          write(7,70)
1836 70    Format(5x,'Reference Pair Histogram Parameters not consistent',
1837      1       ' with present run conditions - STOP')
1838          errorcode = 1
1839          Return
1840       else if(ref_check .eq. 1) then
1841
1842          if(switch_1d.gt.0 .and. n_1d_total.gt.0) then
1843             if(switch_type.eq.1 .or. switch_type.eq.3) then
1844                read(9,*) (href_like_1d(i),i=1,n_1d_total)
1845             end if
1846             if(switch_type.eq.2 .or. switch_type.eq.3) then
1847                read(9,*) (href_unlike_1d(i),i=1,n_1d_total)
1848             end if
1849          end if   ! End 1D input option
1850
1851          if(switch_3d.gt.0) then
1852             if(switch_type.eq.1 .or. switch_type.eq.3) then
1853
1854                if(n_3d_fine.gt.0) then
1855                   do i = 1,n_3d_fine
1856                   do j = 1,n_3d_fine
1857                   do k = 1,n_3d_fine
1858                      read(9,*) href_like_3d_fine(i,j,k)
1859                   end do
1860                   end do
1861                   end do
1862                end if
1863
1864                if(n_3d_coarse.gt.0) then
1865                   do i = 1,n_3d_coarse
1866                   do j = 1,n_3d_coarse
1867                   do k = 1,n_3d_coarse
1868                      read(9,*) href_like_3d_coarse(i,j,k)
1869                   end do
1870                   end do
1871                   end do
1872                end if
1873
1874             end if
1875
1876             if(switch_type.eq.2 .or. switch_type.eq.3) then
1877
1878                if(n_3d_fine.gt.0) then
1879                   do i = 1,n_3d_fine
1880                   do j = 1,n_3d_fine
1881                   do k = 1,n_3d_fine
1882                      read(9,*) href_unlike_3d_fine(i,j,k)
1883                   end do
1884                   end do
1885                   end do
1886                end if
1887
1888                if(n_3d_coarse.gt.0) then
1889                   do i = 1,n_3d_coarse
1890                   do j = 1,n_3d_coarse
1891                   do k = 1,n_3d_coarse
1892                      read(9,*) href_unlike_3d_coarse(i,j,k)
1893                   end do
1894                   end do
1895                   end do
1896                end if
1897
1898             end if
1899
1900          end if     ! End 3D input option
1901       end if        ! End Reference Check OK/Not OK Option
1902
1903       Close(unit=9)
1904
1905 CCC   Next read the one-body histograms for 1 or 2 particle ID types:
1906
1907       open(unit=11,status='old',access='sequential',
1908      1     file='hbt_singles_reference.hist')
1909
1910       read(11,*) (check(i),i=1,3)
1911       read(11,*)  check(4),acheck(1),acheck(2)
1912       read(11,*)  check(5),acheck(3),acheck(4)
1913       read(11,*)  check(6),acheck(5),acheck(6)
1914       read(11,*) n_part_used_1_ref, n_part_used_2_ref
1915
1916 CCC   Determine if Reference one-body histograms are compatible with
1917 CCC   the present run conditions.
1918
1919       ref_check = 1
1920       if(check(1) .ne. n_pid_types)   ref_check = 0
1921       if(check(2) .ne. pid(1)     )   ref_check = 0
1922       if(check(3) .ne. pid(2)     )   ref_check = 0
1923       if(check(4) .ne. n_pt_bins  )   ref_check = 0
1924       if(check(5) .ne. n_phi_bins )   ref_check = 0
1925       if(check(6) .ne. n_eta_bins )   ref_check = 0
1926
1927       if(abs(acheck(1) - pt_min  ).gt.0.000001) ref_check = 0
1928       if(abs(acheck(2) - pt_max  ).gt.0.000001) ref_check = 0
1929       if(abs(acheck(3) - phi_min ).gt.0.000001) ref_check = 0
1930       if(abs(acheck(4) - phi_max ).gt.0.000001) ref_check = 0
1931       if(abs(acheck(5) - eta_min ).gt.0.000001) ref_check = 0
1932       if(abs(acheck(6) - eta_max ).gt.0.000001) ref_check = 0
1933
1934       if(ref_check .eq. 0) then
1935          write(7,71)
1936 71       Format(5x,'Reference One-Body Histogram parameters not ',
1937      1          'consistent with current run - STOP')
1938          errorcode = 1
1939          Return
1940       else if(ref_check .eq. 1) then
1941
1942          if(pid(1).gt.0) then
1943             read(11,*) (href1_pt_1(i) ,i=1,n_pt_bins)
1944             read(11,*) (href1_phi_1(i),i=1,n_phi_bins)
1945             read(11,*) (href1_eta_1(i),i=1,n_eta_bins)
1946          end if
1947
1948          if(pid(2).gt.0) then
1949             read(11,*) (href1_pt_2(i) ,i=1,n_pt_bins)
1950             read(11,*) (href1_phi_2(i),i=1,n_phi_bins)
1951             read(11,*) (href1_eta_2(i),i=1,n_eta_bins)
1952          end if
1953
1954       end if    ! End one-body reference histogram input
1955
1956       Close(unit=11)
1957
1958 C-----------------------------
1959       ELSE IF(mode.eq.4) THEN
1960 C-----------------------------
1961
1962 CCC   Read the next event from 'event_text.in' and load accepted tracks
1963 C     into the 'trk' data structure using the flag information about each
1964 C     line type in the file 'event_tracks.select'.
1965 C
1966 C     For this mode to run successfully the calling program must:
1967 C       (1) initially set the event_line_counter = 0
1968 C       (2) open the 'event_text.in' and 'event_tracks.select' files
1969 C           as units 2 and 4, respectively.
1970 C       (3) Close units 2 and 4 when finished.
1971
1972 CCC   Initialize accepted track counters for this new event:
1973
1974       track_counter   = 0     ! Counts all accepted tracks
1975       track_counter_1 = 0     ! Counts all accepted tracks of type pid(1)
1976       track_counter_2 = 0     ! Counts all accepted tracks of type pid(2)
1977
1978       If(ALICE .eq. 1) Then
1979          Call AliHbtp_GetNumberTracks(ntracks)
1980          do i = 1,ntracks
1981             Call AliHbtp_GetTrack(i,flag,px,py,pz,ge_pid)
1982             eg_pid = ge_pid
1983             if(flag.eq.flag4) then
1984          track_counter = track_counter + 1
1985
1986          if(eg_pid.eq.pid(1) .and. pid(1).gt.0) then
1987             track_counter_1 = track_counter_1 + 1
1988          end if
1989
1990          if(eg_pid.eq.pid(2) .and. pid(2).gt.0) then
1991             track_counter_2 = track_counter_2 + 1
1992          end if
1993
1994          mass = part_mass(eg_pid)
1995          Call Hbtp_kin(px,py,pz,E,pt,phi,eta,mass,1)
1996          trk_ge_pid(track_counter)        = eg_pid
1997          trk_px(track_counter)            = px
1998          trk_py(track_counter)            = py
1999          trk_pz(track_counter)            = pz
2000          trk_id(track_counter)            = track_counter
2001          trk_start_vertex(track_counter)  = 0
2002          trk_stop_vertex(track_counter)   = 0
2003          trk_event_line(track_counter)    = 0
2004          trk_flag(track_counter)          = 0
2005          trk_px_sec(track_counter)        = 0
2006          trk_py_sec(track_counter)        = 0
2007          trk_pz_sec(track_counter)        = 0
2008          trk_sector(track_counter)        = 0
2009          trk_out_flag(track_counter)      = 0
2010          trk_merge_flag(track_counter)    = 0
2011          trk_E(track_counter)             = E
2012          trk_pt(track_counter)            = pt
2013          trk_phi(track_counter)           = phi
2014          trk_eta(track_counter)           = eta
2015         end if
2016        end do
2017          n_part_1_trk   = track_counter_1
2018          n_part_2_trk   = track_counter_2
2019          n_part_tot_trk = track_counter
2020
2021       Else If(ALICE .eq. 0) Then
2022
2023 80    read(4,11,err=81,end=82) flag
2024       event_line_counter = event_line_counter + 1
2025
2026       if(flag .ne. 4) then
2027          read(2,10,err=83,end=82) dummy
2028       else if(flag .eq. 4) then
2029          read(2,41) ge_pid,px,py,pz,tid,start_v,stop_v,eg_pid
2030
2031 CCC   Check if the 'event_text.in' file includes non-zero PID
2032 CCC   values for the variable 'eg_pid'.  If this is zero, then
2033 CCC   use the ge_pid value.
2034          if(eg_pid.eq.0 .and. ge_pid.ne.0) eg_pid = ge_pid
2035
2036          track_counter = track_counter + 1
2037
2038          if(eg_pid.eq.pid(1) .and. pid(1).gt.0) then
2039             track_counter_1 = track_counter_1 + 1
2040          end if
2041
2042          if(eg_pid.eq.pid(2) .and. pid(2).gt.0) then
2043             track_counter_2 = track_counter_2 + 1
2044          end if
2045
2046          mass = part_mass(eg_pid)
2047          Call Hbtp_kin(px,py,pz,E,pt,phi,eta,mass,1)
2048          trk_ge_pid(track_counter)        = eg_pid
2049          trk_px(track_counter)            = px
2050          trk_py(track_counter)            = py
2051          trk_pz(track_counter)            = pz
2052          trk_id(track_counter)            = track_counter
2053          trk_start_vertex(track_counter)  = start_v
2054          trk_stop_vertex(track_counter)   = stop_v
2055          trk_event_line(track_counter)    = event_line_counter
2056          trk_flag(track_counter)          = 0
2057          trk_px_sec(track_counter)        = 0
2058          trk_py_sec(track_counter)        = 0
2059          trk_pz_sec(track_counter)        = 0
2060          trk_sector(track_counter)        = 0
2061          trk_out_flag(track_counter)      = 0
2062          trk_merge_flag(track_counter)    = 0
2063          trk_E(track_counter)             = E
2064          trk_pt(track_counter)            = pt
2065          trk_phi(track_counter)           = phi
2066          trk_eta(track_counter)           = eta
2067       end if
2068
2069       if(flag.ne.1) then
2070          go to 80   ! Return to S.N. 80 and read next record in file
2071       else if(flag.eq.1) then
2072          n_part_1_trk   = track_counter_1
2073          n_part_2_trk   = track_counter_2
2074          n_part_tot_trk = track_counter
2075       end if
2076
2077 82    Return
2078 81    write(7,84)
2079 84    Format(5x,'Read error from file event_tracks.select for mode=4',
2080      1       ' - STOP')
2081       Stop
2082 83    write(7,85)
2083 85    Format(5x,'Read error from file event_text.in for mode=4',
2084      1       ' - STOP')
2085       Stop
2086       End If  !  ALICE Data I/O Option
2087
2088 C-----------------------------
2089       ELSE IF(mode.eq.5) THEN
2090 C-----------------------------
2091
2092 CCC   Read the next event from 'event_text.in' and load accepted tracks
2093 C     into the 'trk2' data structure using the flag information about each
2094 C     line type in the file 'event_tracks.select'.
2095 C
2096 C     For this mode to run successfully the calling program must:
2097 C       (1) initially set the event_line_counter = 0
2098 C       (2) open the 'event_text.in' and 'event_tracks.select' files
2099 C           as units 2 and 4, respectively.
2100 C       (3) Close units 2 and 4 when finished.
2101
2102 CCC   Initialize accepted track counters for this new event:
2103
2104       track_counter   = 0     ! Counts all accepted tracks
2105       track_counter_1 = 0     ! Counts all accepted tracks of type pid(1)
2106       track_counter_2 = 0     ! Counts all accepted tracks of type pid(2)
2107
2108       If(ALICE .eq. 1) Then
2109          Call AliHbtp_GetNumberTracks(ntracks)
2110          do i = 1,ntracks
2111             Call AliHbtp_GetTrack(i,flag,px,py,pz,ge_pid)
2112             eg_pid = ge_pid
2113             if(flag.eq.flag4) then
2114          track_counter = track_counter + 1
2115
2116          if(eg_pid.eq.pid(1) .and. pid(1).gt.0) then
2117             track_counter_1 = track_counter_1 + 1
2118          end if
2119
2120          if(eg_pid.eq.pid(2) .and. pid(2).gt.0) then
2121             track_counter_2 = track_counter_2 + 1
2122          end if
2123
2124          mass = part_mass(eg_pid)
2125          Call Hbtp_kin(px,py,pz,E,pt,phi,eta,mass,1)
2126          trk2_ge_pid(track_counter)        = eg_pid
2127          trk2_px(track_counter)            = px
2128          trk2_py(track_counter)            = py
2129          trk2_pz(track_counter)            = pz
2130          trk2_id(track_counter)            = track_counter
2131          trk2_start_vertex(track_counter)  = 0
2132          trk2_stop_vertex(track_counter)   = 0
2133          trk2_event_line(track_counter)    = 0
2134          trk2_flag(track_counter)          = 0
2135          trk2_px_sec(track_counter)        = 0
2136          trk2_py_sec(track_counter)        = 0
2137          trk2_pz_sec(track_counter)        = 0
2138          trk2_sector(track_counter)        = 0
2139          trk2_out_flag(track_counter)      = 0
2140          trk2_merge_flag(track_counter)    = 0
2141          trk2_E(track_counter)             = E
2142          trk2_pt(track_counter)            = pt
2143          trk2_phi(track_counter)           = phi
2144          trk2_eta(track_counter)           = eta
2145         end if
2146        end do
2147          n_part_1_trk2   = track_counter_1
2148          n_part_2_trk2   = track_counter_2
2149          n_part_tot_trk2 = track_counter
2150
2151       Else If(ALICE.eq.0) Then
2152
2153 90    read(4,11,err=91,end=92) flag
2154       event_line_counter = event_line_counter + 1
2155
2156       if(flag .ne. 4) then
2157          read(2,10,err=93,end=92) dummy
2158       else if(flag .eq. 4) then
2159          read(2,41) ge_pid,px,py,pz,tid,start_v,stop_v,eg_pid
2160
2161 CCC   Check if the 'event_text.in' file includes non-zero PID
2162 CCC   values for the variable 'eg_pid'.  If this is zero, then
2163 CCC   use the ge_pid value.
2164          if(eg_pid.eq.0 .and. ge_pid.ne.0) eg_pid = ge_pid
2165
2166          track_counter = track_counter + 1
2167
2168          if(eg_pid.eq.pid(1) .and. pid(1).gt.0) then
2169             track_counter_1 = track_counter_1 + 1
2170          end if
2171
2172          if(eg_pid.eq.pid(2) .and. pid(2).gt.0) then
2173             track_counter_2 = track_counter_2 + 1
2174          end if
2175
2176          mass = part_mass(eg_pid)
2177          Call Hbtp_kin(px,py,pz,E,pt,phi,eta,mass,1)
2178          trk2_ge_pid(track_counter)        = eg_pid
2179          trk2_px(track_counter)            = px
2180          trk2_py(track_counter)            = py
2181          trk2_pz(track_counter)            = pz
2182          trk2_id(track_counter)            = track_counter
2183          trk2_start_vertex(track_counter)  = start_v
2184          trk2_stop_vertex(track_counter)   = stop_v
2185          trk2_event_line(track_counter)    = event_line_counter
2186          trk2_flag(track_counter)          = 0
2187          trk2_px_sec(track_counter)        = 0
2188          trk2_py_sec(track_counter)        = 0
2189          trk2_pz_sec(track_counter)        = 0
2190          trk2_sector(track_counter)        = 0
2191          trk2_out_flag(track_counter)      = 0
2192          trk2_merge_flag(track_counter)    = 0
2193          trk2_E(track_counter)             = E
2194          trk2_pt(track_counter)            = pt
2195          trk2_phi(track_counter)           = phi
2196          trk2_eta(track_counter)           = eta
2197       end if
2198
2199       if(flag.ne.1) then
2200          go to 90   ! Return to S.N. 90 and read next record in file
2201       else if(flag.eq.1) then
2202          n_part_1_trk2   = track_counter_1
2203          n_part_2_trk2   = track_counter_2
2204          n_part_tot_trk2 = track_counter
2205       end if
2206
2207 92    Return
2208 91    write(7,94)
2209 94    Format(5x,'Read error from file event_tracks.select for mode=5',
2210      1       ' - STOP')
2211       Stop
2212 93    write(7,95)
2213 95    Format(5x,'Read error from file event_text.in for mode=5',
2214      1       ' - STOP')
2215       Stop
2216
2217       End If   !  ALICE Data I/O Option
2218
2219 C-----------------------------
2220       ELSE IF(mode.eq.6) THEN
2221 C-----------------------------
2222
2223 CCC   Read finite source size Coulomb pair correlation corrections and
2224 CCC   interpolate to requested source radius and save the results for q,
2225 CCC   like and unlike pairs in common/coulomb/.
2226
2227       if(switch_coulomb.eq.3 .and. Q0.ge.coulradmin .and.
2228      1   Q0.le.coulradmax) then
2229
2230 CCC   Initially, read and interpolate like pair Coulomb corrections:
2231 C     ALICE
2232
2233       If(ALICE .eq. 1) then
2234
2235         CALL GETENVF('ALICE_ROOT',CHROOT)
2236         LNROOT = LNBLNK(CHROOT)
2237
2238         IF(LNROOT.LE.0) THEN
2239          PRINT*,'**********************************'
2240          PRINT*,'*        HBT PROCESSOR           *'
2241          PRINT*,'*        -----------             *'
2242          PRINT*,'*   DATA File  not found         *'
2243          PRINT*,'*         Program STOP           *'
2244          PRINT*,'*   Check ALICE_ROOT environment *'
2245          PRINT*,'*           variable             *'
2246          PRINT*,'**********************************'
2247          errorcode = 1
2248          return
2249         ENDIF
2250
2251         FILNAM=CHROOT(1:LNROOT)//'/data/cpp_06.dat'
2252         open(unit=21,status='old',access='sequential',
2253      1       file=FILNAM)
2254
2255         FILNAM=CHROOT(1:LNROOT)//'/data/cpp_08.dat'
2256         open(unit=22,status='old',access='sequential',
2257      1       file=FILNAM)
2258
2259         FILNAM=CHROOT(1:LNROOT)//'/data/cpp_10.dat'
2260         open(unit=23,status='old',access='sequential',
2261      1       file=FILNAM)
2262
2263         FILNAM=CHROOT(1:LNROOT)//'/data/cpp_12.dat'
2264         open(unit=24,status='old',access='sequential',
2265      1       file=FILNAM)
2266
2267         FILNAM=CHROOT(1:LNROOT)//'/data/cpp_14.dat'
2268         open(unit=25,status='old',access='sequential',
2269      1       file=FILNAM)
2270
2271         FILNAM=CHROOT(1:LNROOT)//'/data/cpp_16.dat'
2272         open(unit=26,status='old',access='sequential',
2273      1       file=FILNAM)
2274
2275         FILNAM=CHROOT(1:LNROOT)//'/data/cpp_18.dat'
2276         open(unit=27,status='old',access='sequential',
2277      1       file=FILNAM)
2278
2279       ELSE
2280         open(unit=21,status='old',access='sequential',
2281      1       file='cpp_06.dat')
2282         open(unit=22,status='old',access='sequential',
2283      1       file='cpp_08.dat')
2284         open(unit=23,status='old',access='sequential',
2285      1       file='cpp_10.dat')
2286         open(unit=24,status='old',access='sequential',
2287      1       file='cpp_12.dat')
2288         open(unit=25,status='old',access='sequential',
2289      1       file='cpp_14.dat')
2290         open(unit=26,status='old',access='sequential',
2291      1       file='cpp_16.dat')
2292         open(unit=27,status='old',access='sequential',
2293      1       file='cpp_18.dat')
2294       ENDIF
2295
2296
2297       do i = 1,max_c2_coul
2298          do j = 1,ncoulradsteps
2299             read(20+j,*) q_coul(i), function(j)
2300          end do
2301          Call AliHbtp_interp(coulradmin,coulradmax,coulradstep,
2302      1        ncoulradsteps,function,20,Q0,c2_coul_like(i))
2303       end do
2304
2305       close(unit=21)
2306       close(unit=22)
2307       close(unit=23)
2308       close(unit=24)
2309       close(unit=25)
2310       close(unit=26)
2311       close(unit=27)
2312
2313 CCC   Next read and interpolate the unlike pair Coulomb corrections:
2314
2315       If(ALICE .eq. 1) then
2316         FILNAM=CHROOT(1:LNROOT)//'/data/cpm_06.dat'
2317         open(unit=31,status='old',access='sequential',
2318      1       file=FILNAM)
2319
2320         FILNAM=CHROOT(1:LNROOT)//'/data/cpm_08.dat'
2321         open(unit=32,status='old',access='sequential',
2322      1       file=FILNAM)
2323
2324         FILNAM=CHROOT(1:LNROOT)//'/data/cpm_10.dat'
2325         open(unit=33,status='old',access='sequential',
2326      1       file=FILNAM)
2327
2328         FILNAM=CHROOT(1:LNROOT)//'/data/cpm_12.dat'
2329         open(unit=34,status='old',access='sequential',
2330      1       file=FILNAM)
2331
2332         FILNAM=CHROOT(1:LNROOT)//'/data/cpm_14.dat'
2333         open(unit=35,status='old',access='sequential',
2334      1       file=FILNAM)
2335
2336         FILNAM=CHROOT(1:LNROOT)//'/data/cpm_16.dat'
2337         open(unit=36,status='old',access='sequential',
2338      1       file=FILNAM)
2339
2340         FILNAM=CHROOT(1:LNROOT)//'/data/cpm_18.dat'
2341         open(unit=37,status='old',access='sequential',
2342      1       file=FILNAM)
2343
2344       else
2345         open(unit=31,status='old',access='sequential',
2346      1       file='cpm_06.dat')
2347         open(unit=32,status='old',access='sequential',
2348      1       file='cpm_08.dat')
2349         open(unit=33,status='old',access='sequential',
2350      1       file='cpm_10.dat')
2351         open(unit=34,status='old',access='sequential',
2352      1       file='cpm_12.dat')
2353         open(unit=35,status='old',access='sequential',
2354      1       file='cpm_14.dat')
2355         open(unit=36,status='old',access='sequential',
2356      1       file='cpm_16.dat')
2357         open(unit=37,status='old',access='sequential',
2358      1       file='cpm_18.dat')
2359       EndIf
2360
2361       do i = 1,max_c2_coul
2362          do j = 1,ncoulradsteps
2363             read(30+j,*) q_coul(i), function(j)
2364          end do
2365          Call AliHbtp_interp(coulradmin,coulradmax,coulradstep,
2366      1        ncoulradsteps,function,20,Q0,c2_coul_unlike(i))
2367       end do
2368
2369       close(unit=31)
2370       close(unit=32)
2371       close(unit=33)
2372       close(unit=34)
2373       close(unit=35)
2374       close(unit=36)
2375       close(unit=37)
2376
2377 CCC   Convert the input q values which are in MeV/c, to GeV/c:
2378
2379       do i = 1,max_c2_coul
2380          q_coul(i) = 0.001*q_coul(i)
2381       end do
2382
2383       end if
2384
2385
2386 C----------------------------
2387       ELSE IF(mode.eq.7) THEN
2388 C----------------------------
2389
2390 CCC   Read next event from 'event_text.in', load accepted tracks into 'trk'
2391 CCC   data structure using the flag information in the file
2392 CCC   'event_tracks.select', copy contents of 'event_text.in' and
2393 CCC   'event_tracks.select', for this one event only, into temporary files
2394 CCC   'event_text_aux.in' and 'event_tracks_aux.select', respectively.
2395 C
2396 C     For this mode to run successfully the calling program must:
2397 C       (1) initially set the event_line_counter = 0
2398 C       (2) open the 'event_text.in' and 'event_tracks.select' files
2399 C           as units 2 and 4, respectively.
2400 C       (3) Close units 2 and 4 when finished.
2401
2402 CCC   Initialize accepted track counters for this new event:
2403
2404       track_counter   = 0     ! Counts all accepted tracks
2405       track_counter_1 = 0     ! Counts all accepted tracks of type pid(1)
2406       track_counter_2 = 0     ! Counts all accepted tracks of type pid(2)
2407
2408       If(ALICE .eq. 1) Then
2409          Call AliHbtp_GetNumberTracks(ntracks)
2410          do i = 1,ntracks
2411             Call AliHbtp_GetTrack(i,flag,px,py,pz,ge_pid)
2412             eg_pid = ge_pid
2413             if(flag.eq.flag4) then
2414          track_counter = track_counter + 1
2415
2416          if(eg_pid.eq.pid(1) .and. pid(1).gt.0) then
2417             track_counter_1 = track_counter_1 + 1
2418          end if
2419
2420          if(eg_pid.eq.pid(2) .and. pid(2).gt.0) then
2421             track_counter_2 = track_counter_2 + 1
2422          end if
2423
2424          mass = part_mass(eg_pid)
2425          Call Hbtp_kin(px,py,pz,E,pt,phi,eta,mass,1)
2426          trk_ge_pid(track_counter)        = eg_pid
2427          trk_px(track_counter)            = px
2428          trk_py(track_counter)            = py
2429          trk_pz(track_counter)            = pz
2430          trk_id(track_counter)            = track_counter
2431          trk_start_vertex(track_counter)  = 0
2432          trk_stop_vertex(track_counter)   = 0
2433          trk_event_line(track_counter)    = 0
2434          trk_flag(track_counter)          = 0
2435          trk_px_sec(track_counter)        = 0
2436          trk_py_sec(track_counter)        = 0
2437          trk_pz_sec(track_counter)        = 0
2438          trk_sector(track_counter)        = 0
2439          trk_out_flag(track_counter)      = 0
2440          trk_merge_flag(track_counter)    = 0
2441          trk_E(track_counter)             = E
2442          trk_pt(track_counter)            = pt
2443          trk_phi(track_counter)           = phi
2444          trk_eta(track_counter)           = eta
2445         end if
2446        end do
2447          n_part_1_trk   = track_counter_1
2448          n_part_2_trk   = track_counter_2
2449          n_part_tot_trk = track_counter
2450
2451       Else If(ALICE .eq. 0) Then
2452
2453 CCC   Open temporary files:
2454
2455       open(unit=12,status='unknown',access='sequential',
2456      1     file='event_text_aux.in')
2457       open(unit=14,status='unknown',access='sequential',
2458      1     file='event_tracks_aux.select')
2459
2460 100   read(4,11,err=101,end=102) flag
2461       event_line_counter = event_line_counter + 1
2462       write(14,11) flag
2463       if(flag.eq.1) then
2464          read(2,10,err=103,end=102) comment_event_label
2465          write(12,10) comment_event_label
2466       else if(flag .eq. 2) then
2467          read(2,10,err=103,end=102) vertex_label
2468          write(12,10) vertex_label
2469       else if(flag .eq. 3) then
2470          read(2,10,err=103,end=102) comment_event_label
2471          write(12,10) comment_event_label
2472       else if(flag .eq. 5) then
2473          read(2,10,err=103,end=102) gener_label
2474          write(12,10) gener_label
2475       else if(flag .eq. 4) then
2476          read(2,41) ge_pid,px,py,pz,tid,start_v,stop_v,eg_pid
2477          write(12,41) ge_pid,px,py,pz,tid,start_v,stop_v,eg_pid
2478
2479 CCC   Check if the 'event_text.in' file includes non-zero PID
2480 CCC   values for the variable 'eg_pid'.  If this is zero, then
2481 CCC   use the ge_pid value.
2482          if(eg_pid.eq.0 .and. ge_pid.ne.0) eg_pid = ge_pid
2483
2484          track_counter = track_counter + 1
2485
2486          if(eg_pid.eq.pid(1) .and. pid(1).gt.0) then
2487             track_counter_1 = track_counter_1 + 1
2488          end if
2489
2490          if(eg_pid.eq.pid(2) .and. pid(2).gt.0) then
2491             track_counter_2 = track_counter_2 + 1
2492          end if
2493
2494          mass = part_mass(eg_pid)
2495          Call Hbtp_kin(px,py,pz,E,pt,phi,eta,mass,1)
2496          trk_ge_pid(track_counter)        = eg_pid
2497          trk_px(track_counter)            = px
2498          trk_py(track_counter)            = py
2499          trk_pz(track_counter)            = pz
2500          trk_id(track_counter)            = track_counter
2501          trk_start_vertex(track_counter)  = start_v
2502          trk_stop_vertex(track_counter)   = stop_v
2503          trk_event_line(track_counter)    = event_line_counter
2504          trk_flag(track_counter)          = 0
2505          trk_px_sec(track_counter)        = 0
2506          trk_py_sec(track_counter)        = 0
2507          trk_pz_sec(track_counter)        = 0
2508          trk_sector(track_counter)        = 0
2509          trk_out_flag(track_counter)      = 0
2510          trk_merge_flag(track_counter)    = 0
2511          trk_E(track_counter)             = E
2512          trk_pt(track_counter)            = pt
2513          trk_phi(track_counter)           = phi
2514          trk_eta(track_counter)           = eta
2515       else
2516          read(2,10,err=103,end=102) comment_event_label
2517          write(12,10) comment_event_label
2518       end if
2519
2520       if(flag.ne.1) then
2521          go to 100   ! Return to S.N. 100 and read next record in file
2522       else if(flag.eq.1) then
2523          n_part_1_trk   = track_counter_1
2524          n_part_2_trk   = track_counter_2
2525          n_part_tot_trk = track_counter
2526       end if
2527
2528 102   Close(unit=12)
2529       Close(unit=14)
2530       Return
2531 101   write(7,104)
2532 104   Format(5x,'Read error from file event_tracks.select for mode=7',
2533      1       ' - STOP')
2534       Stop
2535 103   write(7,105)
2536 105   Format(5x,'Read error from file event_text.in for mode=7',
2537      1       ' - STOP')
2538       Stop
2539
2540       End If  !  ALICE Data I/O Option
2541
2542 C----------------------------
2543       ELSE IF(mode.eq.8) THEN
2544 C----------------------------
2545
2546 CCC   Read contents of 'event_text_aux.in' using the flag values in
2547 CCC   tmp. file 'event_tracks_aux.select' and copy this into the final
2548 CCC   output event file, 'event_hbt_text.out', where the momentum values
2549 CCC   of the accepted tracks in the initial input event file are replaced
2550 CCC   with the adjusted/correlated values obtained from the 'trk' table.
2551 C
2552 C     For this to work successfully the calling program must:
2553 C      (1) initially set the event_line_counter = 0
2554 C      (2) open the 'event_hbt_text.out' file as unit = 10
2555 C      (3) Close unit 10 when finished
2556
2557 CCC   Initialize accepted track counters:
2558
2559       track_counter = 0
2560
2561       If(ALICE .eq. 1) Then
2562          Call AliHbtp_GetNumberTracks(ntracks)
2563          do i = 1,ntracks
2564             Call AliHbtp_GetTrack(i,flag,px,py,pz,ge_pid)
2565             if(flag.eq.flag4) then
2566               track_counter = track_counter + 1
2567               if(trk_accep .ge. 1.000  .or. (trk_accep .lt. 1.00
2568      1           .and. hbtpran(irand) .le. trk_accep)) then
2569 C                 write(*,*) '  FFF: 3 calling PutTrack i = ',i
2570                  Call AliHbtp_PutTrack(i,flag,
2571      1                trk_px(track_counter),
2572      2                trk_py(track_counter),
2573      3                trk_pz(track_counter),
2574      4                ge_pid)
2575               end if
2576             end if
2577          end do
2578
2579       Else If(ALICE .eq. 0) Then
2580
2581 CCC   Open temporary, auxiliary files:
2582
2583       open(unit=12,status='old',access='sequential',
2584      1     file='event_text_aux.in')
2585       open(unit=14,status='old',access='sequential',
2586      1     file='event_tracks_aux.select')
2587
2588 120   read(14,11,err=121,end=122) flag
2589       file10_line_counter = file10_line_counter + 1
2590       if(flag.eq.1) then
2591          read(12,10,err=123,end=122) comment_event_label
2592          write(10,10) comment_event_label
2593       else if(flag .eq. 2) then
2594          read(12,10,err=123,end=122) vertex_label
2595          write(10,10) vertex_label
2596       else if(flag .eq. 3) then
2597          read(12,10,err=123,end=122) comment_event_label
2598          write(10,10) comment_event_label
2599       else if(flag .eq. 5) then
2600          read(12,10,err=123,end=122) gener_label
2601          write(10,10) gener_label
2602       else if(flag .eq. 4) then
2603          read(12,41,err=123,end=122)
2604      1      ge_pid,px,py,pz,tid,start_v,stop_v,eg_pid
2605          track_counter = track_counter + 1
2606          if(tid.eq.0) tid = trk_id(track_counter)
2607          if(trk_event_line(track_counter).eq.file10_line_counter)then
2608             if(trk_accep .ge. 1.000  .or. (trk_accep .lt. 1.00
2609      1         .and. hbtpran(irand) .le. trk_accep)) then
2610             write(10,841)ge_pid                   ,
2611      1                   trk_px(track_counter)    ,
2612      2                   trk_py(track_counter)    ,
2613      3                   trk_pz(track_counter)    ,
2614      4                   tid                      ,
2615      5                   start_v                  ,
2616      6                   stop_v                   ,
2617      7                   trk_ge_pid(track_counter)
2618 841         Format('TRACK:',1x,I6,3(1x,G12.5),4(1x,I6))
2619             end if
2620          else
2621             write(7,127)
2622             write(7,126) track_counter, trk_event_line(track_counter),
2623      1                file10_line_counter
2624 127         Format(5x,'Track table rows and Event file line count ',
2625      1          'out-of-synch. - STOP')
2626 126         Format(5x,'track_counter, trk().event_line,',
2627      1          'file10_line_counter = ',3I10)
2628             Stop
2629          end if
2630       else
2631          read(12,10,err=123,end=122) comment_event_label
2632          write(10,10) comment_event_label
2633       end if
2634
2635       if(flag .ne. 1) go to 120  !  Return to S.N. 120 and read next record
2636
2637 122   Close(unit=12,status='delete')
2638       Close(unit=14,status='delete')
2639       Return
2640 121   write(7,124)
2641 124   Format(5x,'Read error from file event_tracks_aux.select',
2642      1       ' for mode = 8 - STOP')
2643       Stop
2644 123   write(7,125)
2645 125   Format(5x,'Read error from file event_text_aux.in',
2646      1       ' for mode = 8 - STOP')
2647       Stop
2648
2649       End If  !  ALICE Data I/O Option
2650
2651 C-----------------
2652       END IF     ! End of read_data mode selection options
2653 C-----------------
2654
2655       Return
2656       END
2657
2658 C-----------------------------------------------------------------------
2659
2660
2661       subroutine getref_hist
2662       implicit none
2663
2664 CCC   This subroutine controls the reading or calculation and output
2665 CCC   of the several reference histograms.  These include:
2666 CCC      (a) the one-body {pt,phi,eta} 1D distributions for 1 or 2
2667 CCC          particle ID types.
2668 CCC      (b) the two-body pair-wise histograms for like and unlike
2669 CCC          pairs; for 1D and/or 3D fine mesh and 3D coarse mesh
2670 CCC          distributions.
2671
2672       Include 'common_parameters.inc'
2673       Include 'common_mesh.inc'
2674       Include 'common_histograms.inc'
2675
2676       Include 'common_track.inc'
2677       Include 'common_track2.inc'
2678       Include 'common_sec_track.inc'
2679       Include 'common_sec_track2.inc'
2680       Include 'common_particle.inc'
2681
2682 CCC   Local Variable Type Declarations:
2683
2684       integer*4 i,ipt,iphi,ieta,sign_toggle
2685
2686       if(ref_control .eq. 1) then
2687
2688 CCC   read pair and one-body reference histograms:
2689          Call read_data(3)
2690       else if(ref_control .eq. 2) then
2691
2692 CCC   calculate the pair and one-body histograms:
2693 CCC   Open event and flag files:
2694
2695       If(ALICE .eq. 0) Then
2696          open(unit=2,status='old',access='sequential',
2697      1        file='event_text.in')
2698          open(unit=4,status='old',access='sequential',
2699      1        file='event_tracks.select')
2700       End If
2701
2702 CCC   Initialize counters:
2703
2704          n_part_used_1_ref    = 0
2705          n_part_used_2_ref    = 0
2706          num_pairs_like_ref   = 0
2707          num_pairs_unlike_ref = 0
2708          event_line_counter   = 0
2709
2710 CCC   Read event header lines (no tracks are in this part):
2711       If(ALICE .eq. 0) Then
2712          Call read_data(4)
2713       End If
2714
2715 CCC   Set toggle switch to alternate between loading event tracks into
2716 CCC   table 'trk' and table 'trk2':
2717          sign_toggle = 1
2718
2719 CCC   Start Event Loop:
2720 C         write(*,*) 'REF HISTO N Ev = ', n_events
2721          do i = 1,n_events
2722            If(ALICE .eq. 1) Then
2723               Call AliHbtp_SetActiveEventNumber(i)
2724            End If
2725            if(sign_toggle .eq. 1) then   ! Put tracks into 'trk'
2726              Call read_data(4)
2727              Call tindex(1,0)
2728              Call stm_build(1,0,0)
2729              if(pid(1) .gt. 0) then
2730                Call histog1(1,0,1,pid(1),0.0,0.0,0.0)
2731                n_part_used_1_ref = n_part_used_1_ref + n_part_used_1_trk
2732
2733                do ipt = 1,n_pt_bins
2734                href1_pt_1(ipt) = href1_pt_1(ipt) + hist1_pt_1(ipt)
2735                if (href1_pt_1(ipt) .lt. 0 ) then
2736                  write(*,*) 'href1_pt_1 bin ',ipt,'is less then 0'
2737                endif
2738                end do
2739
2740                do iphi = 1,n_phi_bins
2741                href1_phi_1(iphi) = href1_phi_1(iphi) + hist1_phi_1(iphi)
2742                if (href1_phi_1(iphi) .lt. 0 ) then
2743                  write(*,*) 'href1_phi_1 bin ',iphi,'is less then 0'
2744                endif
2745                end do
2746
2747                do ieta = 1,n_eta_bins
2748                href1_eta_1(ieta) = href1_eta_1(ieta) + hist1_eta_1(ieta)
2749                if (href1_eta_1(ieta) .lt. 0 ) then
2750                  write(*,*) 'href1_eta_1 bin ',ieta,'is less then 0'
2751                endif
2752                end do
2753              end if
2754
2755              if(pid(2) .gt. 0) then
2756                Call histog1(1,0,2,pid(2),0.0,0.0,0.0)
2757                n_part_used_2_ref = n_part_used_2_ref + n_part_used_2_trk
2758
2759                do ipt = 1,n_pt_bins
2760                href1_pt_2(ipt) = href1_pt_2(ipt) + hist1_pt_2(ipt)
2761                end do
2762
2763                do iphi = 1,n_phi_bins
2764                href1_phi_2(iphi) = href1_phi_2(iphi) + hist1_phi_2(iphi)
2765                end do
2766
2767                do ieta = 1,n_eta_bins
2768                href1_eta_2(ieta) = href1_eta_2(ieta) + hist1_eta_2(ieta)
2769                end do
2770              end if
2771
2772            else if(sign_toggle .eq. (-1)) then  ! Put tracks into 'trk2'
2773              Call read_data(5)
2774              Call tindex(2,0)
2775              Call stm_build(2,0,0)
2776              if(pid(1) .gt. 0) then
2777                Call histog1(4,0,1,pid(1),0.0,0.0,0.0)
2778                n_part_used_1_ref = n_part_used_1_ref +n_part_used_1_trk2
2779
2780                do ipt = 1,n_pt_bins
2781                href1_pt_1(ipt) = href1_pt_1(ipt) + hist1_pt_1(ipt)
2782                end do
2783
2784                do iphi = 1,n_phi_bins
2785                href1_phi_1(iphi) = href1_phi_1(iphi) + hist1_phi_1(iphi)
2786                end do
2787
2788                do ieta = 1,n_eta_bins
2789                href1_eta_1(ieta) = href1_eta_1(ieta) + hist1_eta_1(ieta)
2790                end do
2791              end if
2792
2793              if(pid(2) .gt. 0) then
2794                Call histog1(4,0,2,pid(2),0.0,0.0,0.0)
2795                n_part_used_2_ref = n_part_used_2_ref +n_part_used_2_trk2
2796
2797                do ipt = 1,n_pt_bins
2798                href1_pt_2(ipt) = href1_pt_2(ipt) + hist1_pt_2(ipt)
2799                end do
2800
2801                do iphi = 1,n_phi_bins
2802                href1_phi_2(iphi) = href1_phi_2(iphi) + hist1_phi_2(iphi)
2803                end do
2804
2805                do ieta = 1,n_eta_bins
2806                href1_eta_2(ieta) = href1_eta_2(ieta) + hist1_eta_2(ieta)
2807                end do
2808              end if
2809
2810            end if   !  End read and load to trk or trk2 option
2811
2812            sign_toggle = -sign_toggle
2813
2814            if(i .gt. 1) then    !  Compute 2-body reference histograms
2815               Call histog2(4,0,0,0,0,0.0,0.0,0.0,0.0)
2816               num_pairs_like_ref = num_pairs_like_ref
2817      1           + n_part_used_1_trk * n_part_used_1_trk2
2818      2           + n_part_used_2_trk * n_part_used_2_trk2
2819               num_pairs_unlike_ref = num_pairs_unlike_ref
2820      1           + n_part_used_1_trk * n_part_used_2_trk2
2821      2           + n_part_used_2_trk * n_part_used_1_trk2
2822 C              write(*,*) 'num_pairs_like_ref',num_pairs_like_ref
2823 C              write(*,*) 'num_pairs_unlike_ref',num_pairs_unlike_ref
2824            end if
2825
2826         end do   !  End of Event Loop
2827
2828 CCC   Write out the pair and one-body reference Histograms:
2829       Call write_data(2,0)
2830
2831       If(ALICE .eq. 0) Then
2832       Close(unit=2)
2833       Close(unit=4)
2834       End If
2835
2836       end if  !  End Reference Histogram read/calculate option
2837
2838       Return
2839       END
2840
2841 C----------------------------------------------------------------------
2842
2843
2844       subroutine AliHbtp_interp(rmin,rmax,rstep,nrsteps,function,
2845      1                          ndim,r,answer)
2846       implicit none
2847
2848 CCC   This routine interpolates the function values and puts the result
2849 CCC   into 'answer'.  It uses 2,3 or 4 mesh points which must be equally
2850 CCC   spaced.  The method uses the Lagrange interpolation formulas given
2851 CCC   in Abramowitz and Stegun, ``Handbook of Mathematical Functions,''
2852 CCC   (Dover Publications, New York, 1970); pages 878-879.
2853
2854 CCC   Definition of Variables in the Argument List:
2855
2856 CCC   rmin     = lower limit of independent variable for input function
2857 CCC   rmax     = upper limit of independent variable for input function
2858 CCC   rstep    = step size of independent variable
2859 CCC   nrsteps  = (redundant) # of input steps
2860 CCC   function(ndim) = Array of function values to be interpolated
2861 CCC   ndim     = array dimension size in calling program
2862 CCC   r        = coordinate value of independent variable where interpolation
2863 CCC              is needed.
2864 CCC   answer   = interpolated value
2865
2866 CCC   The algorithm will use the maximum number of points in the
2867 CCC   interpolation, up to a maximum of 4
2868
2869 CCC   If the requested coordinate value, r, is out-of-range, then
2870 CCC   'answer' is returned with a 0.0 value.
2871
2872 CCC   Local Variable Type Declarations:
2873
2874       integer*4 ndim, nrsteps, ik
2875
2876       real*4 rmin,rmax,rstep,r,answer,rshift,p
2877       real*4 function(ndim),w1,w2,w3,w4
2878
2879 CCC   Check Mesh:
2880
2881       if(abs(((rmax-rmin)/float(nrsteps-1))-rstep).gt.0.00001) then
2882          write(7,10) rmin,rmax,rstep,nrsteps
2883 10       Format(5x,'Interp mesh inconsistent:',3E12.5,I5,
2884      1          ' - STOP')
2885       Return
2886       end if
2887
2888 CCC   Check range:
2889
2890       if(r .lt. rmin .or. r .gt. rmax) then
2891          write(7,11) rmin,rmax,r
2892 11       Format(5x,'Interp called with r out-of-range =',3E12.5)
2893          answer = 0.0
2894          Return
2895       end if
2896
2897 CCC   Begin interpolation:
2898
2899       if(nrsteps .eq. 2) then
2900          p = (r - rmin)/rstep
2901          answer = (1.0 - p)*function(1) + p*function(2)
2902       else if(nrsteps .eq. 3) then
2903          p = (r - (rmin + rstep))/rstep
2904          answer = 0.5*p*(p-1.0)*function(1) + (1.0 - p*p)
2905      1            *function(2) + 0.5*p*(p+1.0)*function(3)
2906       else if(nrsteps .ge. 4) then
2907          rshift = r - rmin
2908
2909          if(rshift .le. rstep) then
2910             ik = 2
2911             p = (rshift - rstep)/rstep
2912          else if(rshift .ge. (rmax - rstep - rmin)) then
2913             ik = nrsteps - 2
2914             p = (rshift - (rmax - rmin - 2.0*rstep))/rstep
2915          else
2916             ik = int(rshift/rstep + 1.000001)
2917             if(ik .le. 1) ik = 2
2918             if(ik .ge. (nrsteps-1)) ik = nrsteps - 2
2919             p = (rshift - float(ik-1)*rstep)/rstep
2920          end if
2921
2922          w1 = -p*(p-1.0)*(p-2.0)/6.0
2923          w2 = (p*p-1.0)*(p-2.0)/2.0
2924          w3 = -p*(p+1.0)*(p-2.0)/2.0
2925          w4 = p*(p*p-1.0)/6.0
2926
2927          answer = w1*function(ik-1) + w2*function(ik)
2928      1          + w3*function(ik+1) + w4*function(ik+2)
2929       end if  !  End # interplation points option
2930
2931       Return
2932       END
2933
2934 C--------------------------------------------------------------------
2935
2936
2937       subroutine Hbtp_particle_prop
2938       implicit none
2939
2940 CCC   Fill particle properties table /particle/ with Geant 3 particle ID
2941 CCC   numbers, charge (in units of |e|), mass in GeV/c**2 and lifetime
2942 CCC   in seconds.  See the Geant 3.15 Manual User's Guide, pages: CONS
2943 CCC   300-1 and -2.
2944
2945       Include 'common_particle.inc'
2946
2947 CCC   Local Variable Type Declarations:
2948
2949       integer*4 i
2950
2951       do i = 1,part_maxlen
2952       part_id(i) = i
2953       end do
2954
2955 CCC   Set Particle Masses:
2956
2957       part_mass( 1) = 0.0                   ! Gamma
2958       part_mass( 2) = 0.00051099906         ! Positron
2959       part_mass( 3) = 0.00051099906         ! Electron
2960       part_mass( 4) = 0.0                   ! Neutrino
2961       part_mass( 5) = 0.105658389           ! Muon+
2962       part_mass( 6) = 0.105658389           ! Muon-
2963       part_mass( 7) = 0.1349743             ! Pion0
2964       part_mass( 8) = 0.1395679             ! Pion+
2965       part_mass( 9) = 0.1395679             ! Pion-
2966       part_mass(10) = 0.497671              ! Kaon 0 long
2967       part_mass(11) = 0.493646              ! Kaon+
2968       part_mass(12) = 0.493646              ! Kaon-
2969       part_mass(13) = 0.93956563            ! Neutron
2970       part_mass(14) = 0.93827231            ! Proton
2971       part_mass(15) = 0.93827231            ! Antiproton
2972       part_mass(16) = 0.497671              ! Kaon 0 short
2973       part_mass(17) = 0.54745               ! Eta
2974       part_mass(18) = 1.11563               ! Lambda
2975       part_mass(19) = 1.18937               ! Sigma+
2976       part_mass(20) = 1.19255               ! Sigma0
2977       part_mass(21) = 1.197465              ! Sigma-
2978       part_mass(22) = 1.31485               ! Xi 0
2979       part_mass(23) = 1.32133               ! Xi -
2980       part_mass(24) = 1.67243               ! Omega
2981       part_mass(25) = 0.93956563            ! Antineutron
2982       part_mass(26) = 1.11563               ! Antilambda
2983       part_mass(27) = 1.18937               ! Anti-Sigma -
2984       part_mass(28) = 1.19255               ! Anti-Sigma 0
2985       part_mass(29) = 1.197465              ! Anti-Sigma +
2986       part_mass(30) = 1.31485               ! AntiXi 0
2987       part_mass(31) = 1.32133               ! AntiXi +
2988       part_mass(32) = 1.67243               ! Anti-Omega +
2989       part_mass(33) = 0.0
2990       part_mass(34) = 0.0
2991       part_mass(35) = 0.0
2992       part_mass(36) = 0.0
2993       part_mass(37) = 0.0
2994       part_mass(38) = 0.0
2995       part_mass(39) = 0.0
2996       part_mass(40) = 0.0
2997       part_mass(41) = 0.0
2998       part_mass(42) = 0.0
2999       part_mass(43) = 0.0
3000       part_mass(44) = 0.0
3001       part_mass(45) = 1.875613              ! Deuteron
3002       part_mass(46) = 2.80925               ! Triton
3003       part_mass(47) = 3.727417              ! Alpha
3004       part_mass(48) = 0.0                   ! Geantino (Fake particle)
3005       part_mass(49) = 2.80923               ! He3
3006       part_mass(50) = 0.0                   ! Cerenkov (Fake particle)
3007
3008 CCC   Set Particle Charge:
3009
3010       part_charge( 1) =  0      ! Gamma
3011       part_charge( 2) =  1      ! Positron
3012       part_charge( 3) = -1      ! Electron
3013       part_charge( 4) =  0      ! Neutrino
3014       part_charge( 5) =  1      ! Muon+
3015       part_charge( 6) = -1      ! Muon-
3016       part_charge( 7) =  0      ! Pion0
3017       part_charge( 8) =  1      ! Pion+
3018       part_charge( 9) = -1      ! Pion-
3019       part_charge(10) =  0      ! Kaon 0 long
3020       part_charge(11) =  1      ! Kaon+
3021       part_charge(12) = -1      ! Kaon-
3022       part_charge(13) =  0      ! Neutron
3023       part_charge(14) =  1      ! Proton
3024       part_charge(15) = -1      ! Antiproton
3025       part_charge(16) =  0      ! Kaon 0 short
3026       part_charge(17) =  0      ! Eta
3027       part_charge(18) =  0      ! Lambda
3028       part_charge(19) =  1      ! Sigma+
3029       part_charge(20) =  0      ! Sigma0
3030       part_charge(21) = -1      ! Sigma-
3031       part_charge(22) =  0      ! Xi 0
3032       part_charge(23) = -1      ! Xi -
3033       part_charge(24) = -1      ! Omega
3034       part_charge(25) =  0      ! Antineutron
3035       part_charge(26) =  0      ! Antilambda
3036       part_charge(27) = -1      ! Anti-Sigma -
3037       part_charge(28) =  0      ! Anti-Sigma 0
3038       part_charge(29) =  1      ! Anti-Sigma +
3039       part_charge(30) =  0      ! AntiXi 0
3040       part_charge(31) =  1      ! AntiXi +
3041       part_charge(32) =  1      ! Anti-Omega +
3042       part_charge(33) =  0
3043       part_charge(34) =  0
3044       part_charge(35) =  0
3045       part_charge(36) =  0
3046       part_charge(37) =  0
3047       part_charge(38) =  0
3048       part_charge(39) =  0
3049       part_charge(40) =  0
3050       part_charge(41) =  0
3051       part_charge(42) =  0
3052       part_charge(43) =  0
3053       part_charge(44) =  0
3054       part_charge(45) =  1      ! Deuteron
3055       part_charge(46) =  1      ! Triton
3056       part_charge(47) =  2      ! Alpha
3057       part_charge(48) =  0      ! Geantino (Fake particle)
3058       part_charge(49) =  2      ! He3
3059       part_charge(50) =  0      ! Cerenkov (Fake particle)
3060
3061 CCC   Set Particle Lifetimes:
3062
3063       part_lifetime( 1) = 1.0E+30       ! Gamma
3064       part_lifetime( 2) = 1.0E+30       ! Positron
3065       part_lifetime( 3) = 1.0E+30       ! Electron
3066       part_lifetime( 4) = 1.0E+30       ! Neutrino
3067       part_lifetime( 5) = 2.19703E-06   ! Muon+
3068       part_lifetime( 6) = 2.19703E-06   ! Muon-
3069       part_lifetime( 7) = 8.4E-17       ! Pion0
3070       part_lifetime( 8) = 2.603E-08     ! Pion+
3071       part_lifetime( 9) = 2.603E-08     ! Pion-
3072       part_lifetime(10) = 5.16E-08      ! Kaon 0 long
3073       part_lifetime(11) = 1.237E-08     ! Kaon+
3074       part_lifetime(12) = 1.237E-08     ! Kaon-
3075       part_lifetime(13) = 889.1         ! Neutron
3076       part_lifetime(14) = 1.0E+30       ! Proton
3077       part_lifetime(15) = 1.0E+30       ! Antiproton
3078       part_lifetime(16) = 8.922E-11     ! Kaon 0 short
3079       part_lifetime(17) = 5.53085E-19   ! Eta
3080       part_lifetime(18) = 2.632E-10     ! Lambda
3081       part_lifetime(19) = 7.99E-11      ! Sigma+
3082       part_lifetime(20) = 7.40E-20      ! Sigma0
3083       part_lifetime(21) = 1.479E-10     ! Sigma-
3084       part_lifetime(22) = 2.90E-10      ! Xi 0
3085       part_lifetime(23) = 1.639E-10     ! Xi -
3086       part_lifetime(24) = 8.22E-11      ! Omega
3087       part_lifetime(25) = 889.1         ! Antineutron
3088       part_lifetime(26) = 2.632E-10     ! Antilambda
3089       part_lifetime(27) = 7.99E-11      ! Anti-Sigma -
3090       part_lifetime(28) = 7.40E-20      ! Anti-Sigma 0
3091       part_lifetime(29) = 1.479E-10     ! Anti-Sigma +
3092       part_lifetime(30) = 2.90E-10      ! AntiXi 0
3093       part_lifetime(31) = 1.639E-10     ! AntiXi +
3094       part_lifetime(32) = 8.22E-11      ! Anti-Omega +
3095       part_lifetime(33) = 0.0
3096       part_lifetime(34) = 0.0
3097       part_lifetime(35) = 0.0
3098       part_lifetime(36) = 0.0
3099       part_lifetime(37) = 0.0
3100       part_lifetime(38) = 0.0
3101       part_lifetime(39) = 0.0
3102       part_lifetime(40) = 0.0
3103       part_lifetime(41) = 0.0
3104       part_lifetime(42) = 0.0
3105       part_lifetime(43) = 0.0
3106       part_lifetime(44) = 0.0
3107       part_lifetime(45) = 1.0E+30       ! Deuteron
3108       part_lifetime(46) = 1.0E+30       ! Triton
3109       part_lifetime(47) = 1.0E+30       ! Alpha
3110       part_lifetime(48) = 1.0E+30       ! Geantino (Fake particle)
3111       part_lifetime(49) = 1.0E+30       ! He3
3112       part_lifetime(50) = 1.0E+30       ! Cerenkov (Fake particle)
3113
3114       Return
3115       END
3116
3117 C----------------------------------------------------------------
3118
3119
3120       subroutine correl_model
3121       implicit none
3122
3123 CCC   This subroutine computes the requested 2-body model correlation
3124 CCC   function which is to be fitted by the track adjustment procedure.
3125 CCC   The model values are calculated on the requested fine and coarse
3126 CCC   mesh grid in momentum space.  The model values are computed at the
3127 CCC   mid point of each 1D bin or at the center of each 3D cell.  This
3128 CCC   could be refined at a later date to correspond to the integral of
3129 CCC   the model function over the bin width (cell volume) divided by the
3130 CCC   the bin width (cell volume).
3131
3132 C     The model includes the following options which are selected by the
3133 C     'switch*' parameters in common/parameters/:
3134 C
3135 C        switch_1d:          1D model as function of either Qinvar, Qtotal
3136 C                            or Q-vector
3137 C        switch_3d:          3D model as function of either the Bertsch-Pratt
3138 C                            side-out-long kinematics (but no cross term) or
3139 C                            the Yano-Koonin-Podgoretski perp-parallel-time
3140 C                            kinematics.
3141 C        switch_type:        Like and/or Unlike particles
3142 C        switch_coherence:   Purely incoherent source or a mixed incoherent-
3143 C                            coherent source.
3144 C        switch_coulomb:     Either (a) no Coulomb correction, (b) Gamow
3145 C                            factor, (c) NA35 parametrization, or (d) Pratt
3146 C                            Coulomb wave function integration for finite
3147 C                            size, spherical source.
3148 C        switch_fermi_bose:  Fermion or boson identical pairs.
3149
3150       Include 'common_parameters.inc'
3151       Include 'common_mesh.inc'
3152       Include 'common_correlations.inc'
3153
3154 CCC   Local Variable Type Declarations:
3155
3156       integer*4 i,j,k
3157
3158       real*4 R_1dsq, Rsidesq, Routsq, Rlongsq
3159       real*4 Rperpsq, Rparallelsq, R0sq
3160       real*4 sqrtlambda,fermi_bose_sign,coulomb_factor,coherence_fac
3161       real*4 q,q1,q2,q3
3162       real*4 b,b1,b2,b3
3163       real*4 massavg
3164
3165 CCC   Set Constants:
3166
3167       sqrtlambda  = sqrt(abs(lambda))
3168       R_1dsq      = ((R_1d     /hbc)**2)/2.0
3169       Rsidesq     = ((Rside    /hbc)**2)/2.0
3170       Routsq      = ((Rout     /hbc)**2)/2.0
3171       Rlongsq     = ((Rlong    /hbc)**2)/2.0
3172       Rperpsq     = ((Rperp    /hbc)**2)/2.0
3173       Rparallelsq = ((Rparallel/hbc)**2)/2.0
3174       R0sq        = ((R0       /hbc)**2)/2.0
3175
3176       fermi_bose_sign = float(switch_fermi_bose)
3177       coherence_fac   = switch_coherence*2.0*sqrtlambda*
3178      1                  (1.0 - sqrtlambda)
3179
3180 CCC   Determine average particle pair mass for Coulomb correction:
3181
3182       massavg = 0.14
3183       if(mass1.eq.0.0 .and. mass2.gt.0.0) massavg = mass2
3184       if(mass1.gt.0.0 .and. mass2.eq.0.0) massavg = mass1
3185       if(mass1.gt.0.0 .and. mass2.gt.0.0) massavg = 0.5*(mass1+mass2)
3186
3187 CCC   Compute 1D correlation model arrays:
3188
3189       If(switch_1d .ge. 1) then
3190         If(n_1d_fine .gt. 0) then        ! Fill the 1D fine mesh bins
3191           q = -0.5*binsize_1d_fine
3192           do i = 1,n_1d_fine
3193             q = q + binsize_1d_fine
3194             b = exp(-q*q*R_1dsq)
3195
3196             if(switch_type.eq.1 .or. switch_type.eq.3) then
3197               c2mod_like_1d(i) = 1.0 + fermi_bose_sign*(lambda
3198      1                         *b*b + coherence_fac*b)
3199               if(switch_coulomb.eq.0) then
3200                 coulomb_factor = 1.0
3201               else if(switch_coulomb.gt.0) then
3202                 Call coulomb(switch_coulomb,q,1,massavg,Q0,
3203      1                       coulomb_factor)
3204               end if
3205               c2mod_like_1d(i) = coulomb_factor*c2mod_like_1d(i)
3206             end if
3207
3208             if(switch_type.eq.2 .or. switch_type.eq.3) then
3209              c2mod_unlike_1d(i) = 1.0
3210              if(switch_coulomb.eq.0) then
3211                coulomb_factor = 1.0
3212              else if(switch_coulomb.gt.0) then
3213                Call coulomb(switch_coulomb,q,-1,massavg,Q0,
3214      1                      coulomb_factor)
3215              end if
3216              c2mod_unlike_1d(i) = coulomb_factor*c2mod_unlike_1d(i)
3217             end if
3218
3219           end do    ! End of 1D fine mesh filling do-loop
3220         end if      ! End of 1D fine mesh option
3221
3222         If(n_1d_coarse .gt. 0) then      ! Fill the 1D coarse mesh bins
3223           q = qmid_1d -0.5*binsize_1d_coarse
3224           do i = n_1d_fine + 1, n_1d_total
3225             q = q + binsize_1d_coarse
3226             b = exp(-q*q*R_1dsq)
3227
3228             if(switch_type.eq.1 .or. switch_type.eq.3) then
3229               c2mod_like_1d(i) = 1.0 + fermi_bose_sign*(lambda
3230      1                         *b*b + coherence_fac*b)
3231               if(switch_coulomb.eq.0) then
3232                 coulomb_factor = 1.0
3233               else if(switch_coulomb.gt.0) then
3234                 Call coulomb(switch_coulomb,q,1,massavg,Q0,
3235      1                       coulomb_factor)
3236               end if
3237               c2mod_like_1d(i) = coulomb_factor*c2mod_like_1d(i)
3238             end if
3239
3240             if(switch_type.eq.2 .or. switch_type.eq.3) then
3241              c2mod_unlike_1d(i) = 1.0
3242              if(switch_coulomb.eq.0) then
3243                coulomb_factor = 1.0
3244              else if(switch_coulomb.gt.0) then
3245                Call coulomb(switch_coulomb,q,-1,massavg,Q0,
3246      1                      coulomb_factor)
3247              end if
3248              c2mod_unlike_1d(i) = coulomb_factor*c2mod_unlike_1d(i)
3249             end if
3250
3251           end do    ! End of 1D coarse mesh filling do-loop
3252         end if      ! End of 1D coarse mesh option
3253       end if        ! End of 1D option
3254
3255 CCC   Compute 3D correlation model arrays:
3256
3257       If(switch_3d .ge. 1) Then
3258        If(n_3d_fine .gt. 0) then     !  Fill the 3D fine mesh bins
3259         q1 = -0.5*binsize_3d_fine
3260         do i = 1,n_3d_fine
3261          q1 = q1 + binsize_3d_fine
3262          if(switch_3d.eq.1) b1=exp(-q1*q1*Rsidesq)
3263          if(switch_3d.eq.2) b1=exp(-q1*q1*Rperpsq)
3264
3265           q2 = -0.5*binsize_3d_fine
3266           do j = 1,n_3d_fine
3267            q2 = q2 + binsize_3d_fine
3268            if(switch_3d.eq.1) b2=exp(-q2*q2*Routsq)
3269            if(switch_3d.eq.2) b2=exp(-q2*q2*Rparallelsq)
3270
3271             q3 = -0.5*binsize_3d_fine
3272             do k = 1,n_3d_fine
3273              q3 = q3 + binsize_3d_fine
3274              if(switch_3d.eq.1) b3=exp(-q3*q3*Rlongsq)
3275              if(switch_3d.eq.2) b3=exp(-q3*q3*R0sq)
3276
3277              b = b1*b2*b3
3278              if(switch_3d.eq.1) q = sqrt(q1*q1+q2*q2+q3*q3)
3279              if(switch_3d.eq.2) q = sqrt(q1*q1+q2*q2)
3280
3281              if(switch_type.eq.1 .or. switch_type.eq.3) then
3282               c2mod_like_3d_fine(i,j,k) = 1.0 + fermi_bose_sign*(lambda
3283      1                         *b*b + coherence_fac*b)
3284               if(switch_coulomb.eq.0) then
3285                 coulomb_factor = 1.0
3286               else if(switch_coulomb.gt.0) then
3287                 Call coulomb(switch_coulomb,q,1,massavg,Q0,
3288      1                       coulomb_factor)
3289               end if
3290               c2mod_like_3d_fine(i,j,k) =
3291      1           coulomb_factor*c2mod_like_3d_fine(i,j,k)
3292              end if
3293
3294              if(switch_type.eq.2 .or. switch_type.eq.3) then
3295               c2mod_unlike_3d_fine(i,j,k) = 1.0
3296               if(switch_coulomb.eq.0) then
3297                 coulomb_factor = 1.0
3298               else if(switch_coulomb.gt.0) then
3299                 Call coulomb(switch_coulomb,q,-1,massavg,Q0,
3300      1                       coulomb_factor)
3301               end if
3302               c2mod_unlike_3d_fine(i,j,k) =
3303      1           coulomb_factor*c2mod_unlike_3d_fine(i,j,k)
3304              end if
3305
3306             end do
3307            end do
3308           end do     ! End of 3D Fine Mesh Filling do-loops
3309          end if      ! End 3D fine mesh option
3310
3311        If(n_3d_coarse .gt. 0) then     !  Fill the 3D coarse mesh bins
3312         q1 = -0.5*binsize_3d_coarse
3313         do i = 1,n_3d_coarse
3314          q1 = q1 + binsize_3d_coarse
3315          if(switch_3d.eq.1) b1=exp(-q1*q1*Rsidesq)
3316          if(switch_3d.eq.2) b1=exp(-q1*q1*Rperpsq)
3317
3318           q2 = -0.5*binsize_3d_coarse
3319           do j = 1,n_3d_coarse
3320            q2 = q2 + binsize_3d_coarse
3321            if(switch_3d.eq.1) b2=exp(-q2*q2*Routsq)
3322            if(switch_3d.eq.2) b2=exp(-q2*q2*Rparallelsq)
3323
3324             q3 = -0.5*binsize_3d_coarse
3325             do k = 1,n_3d_coarse
3326              q3 = q3 + binsize_3d_coarse
3327              if(switch_3d.eq.1) b3=exp(-q3*q3*Rlongsq)
3328              if(switch_3d.eq.2) b3=exp(-q3*q3*R0sq)
3329
3330              b = b1*b2*b3
3331              if(switch_3d.eq.1) q = sqrt(q1*q1+q2*q2+q3*q3)
3332              if(switch_3d.eq.2) q = sqrt(q1*q1+q2*q2)
3333
3334              if(switch_type.eq.1 .or. switch_type.eq.3) then
3335               c2mod_like_3d_coarse(i,j,k) = 1.0+fermi_bose_sign*(lambda
3336      1                         *b*b + coherence_fac*b)
3337               if(switch_coulomb.eq.0) then
3338                 coulomb_factor = 1.0
3339               else if(switch_coulomb.gt.0) then
3340                 Call coulomb(switch_coulomb,q,1,massavg,Q0,
3341      1                       coulomb_factor)
3342               end if
3343               c2mod_like_3d_coarse(i,j,k) =
3344      1           coulomb_factor*c2mod_like_3d_coarse(i,j,k)
3345              end if
3346
3347              if(switch_type.eq.2 .or. switch_type.eq.3) then
3348               c2mod_unlike_3d_coarse(i,j,k) = 1.0
3349               if(switch_coulomb.eq.0) then
3350                 coulomb_factor = 1.0
3351               else if(switch_coulomb.gt.0) then
3352                 Call coulomb(switch_coulomb,q,-1,massavg,Q0,
3353      1                       coulomb_factor)
3354               end if
3355               c2mod_unlike_3d_coarse(i,j,k) =
3356      1           coulomb_factor*c2mod_unlike_3d_coarse(i,j,k)
3357              end if
3358
3359             end do
3360            end do
3361           end do     ! End of 3D Coarse Mesh Filling do-loops
3362           c2mod_like_3d_coarse(1,1,1) = 0.0
3363           c2mod_unlike_3d_coarse(1,1,1) = 0.0
3364         end if       ! End of 3D Coarse Mesh Option
3365
3366       End If         ! End of 3D Option
3367
3368       Return
3369       END
3370
3371 C----------------------------------------------------------------------
3372
3373
3374       subroutine coulomb(control,q,sign,mass,Q0,factor)
3375       implicit none
3376
3377 CCC   Compute Coulomb correction to the two-body correlation functions
3378 C     for like and unlike charges for particles of the same mass.
3379 C     Three methods are allowed:
3380 C
3381 C     If control = 1, Then use the gamow factor for point sources
3382 C     If control = 2, Then use the NA35 finite source size empirical
3383 C                     correction factor from eq.(5) in Z. Phys. C73,
3384 C                     443 (1997).
3385 C     If control = 3, Then use the Pratt finite source size, numerically
3386 C                     integrated Coulomb correction factor with inter-
3387 C                     polated tables.
3388 C
3389 C     Other parameters in the argument list are:
3390 C
3391 C        q     = 3-vector momentum difference for track pair, in GeV/c.
3392 C        sign  = algebraic sign of the charge product for the track pair.
3393 C        mass  = particle mass in GeV, it is assumed that both particles
3394 C                have the same mass, e.g. pi+ and pi-, but not K+ and pi-.
3395 C        Q0    = NA35 parameter in GeV/c if control = 2
3396 C              = Source radius in fm if control = 3
3397 C       factor = Multiplicative Coulomb correction result which is
3398 C                calculated here and returned to the calling program.
3399 C
3400
3401       Include 'common_coulomb.inc'
3402
3403 CCC   Local Variable Type Declarations:
3404
3405       integer*4 control, sign
3406
3407       real*4 pi,q,mass,Q0,factor,alpha,eta,eta2pi
3408       real*4 gamow
3409       parameter (pi = 3.141592654)
3410       parameter (alpha = 0.00729735)
3411
3412 CCC   Compute Gamow factor for control options 1 and 2:
3413
3414       if(control.eq.1 .or. control.eq.2) then
3415          if(q .le. 0.001) then
3416             if(sign .gt. 0) gamow = 0.0
3417             if(sign .lt. 0) gamow = 86.0
3418          else
3419             eta = sign*mass*alpha/q
3420             eta2pi = 2.0*pi*eta
3421             gamow = eta2pi/(exp(eta2pi) - 1.0)
3422          end if
3423       end if
3424
3425 CCC   Compute Coulomb Correction factor for options 1, 2 and 3:
3426
3427       if(control .eq. 1) then
3428          factor = gamow
3429       else if(control .eq. 2) then
3430          factor = 1.0 + (gamow - 1.0)*exp(-q/Q0)
3431       else if(control .eq. 3) then
3432
3433          if(q .le. q_coul(1)) then
3434             if(sign .gt. 0) factor = c2_coul_like(1)
3435             if(sign .lt. 0) factor = c2_coul_unlike(1)
3436          else if(q .ge. q_coul(max_c2_coul - 1)) then
3437             if(sign .gt. 0) factor = c2_coul_like(max_c2_coul - 1)
3438             if(sign .lt. 0) factor = c2_coul_unlike(max_c2_coul - 1)
3439          else
3440             if(sign .gt. 0) then
3441                Call LAGRNG1(q,q_coul,factor,c2_coul_like,
3442      1                     max_c2_coul,1,5,max_c2_coul,1)
3443             else if(sign .lt. 0) then
3444                Call LAGRNG1(q,q_coul,factor,c2_coul_unlike,
3445      1                     max_c2_coul,1,5,max_c2_coul,1)
3446             end if
3447          end if
3448       end if  ! END Coulomb correction evaluation, control selection opt.
3449
3450       Return
3451       END
3452
3453 C---------------------------------------------------------------------
3454
3455
3456       SUBROUTINE LAGRNG1 (X,ARG,Y,VAL,NDIM,NFS,NPTS,MAXARG,MAXFS)
3457         IMPLICIT REAL*4(A-H,O-Z)
3458 C
3459 C     LAGRANGE INTERPOLATION,UNEQUALLY SPACED POINTS
3460 C     ROUTINE OBTAINED FROM R. LANDAU, UNIV. OF OREGON.
3461 C     ARG=VECTOR OF INDEPENDENT VARIABLE CONTAINING MAXARG VALUES.
3462 C     VAL=MATRIX OF FUNCTION VALUES CORRESPONDING TO ARG. (MAXFS
3463 C         FUNCTIONS AT MAXARG VALUES.)
3464 C     X  =VALUE OF INDEP. VARIABLE FOR WHICH INTERPOLATION IS DESIRED.
3465 C     Y  =VECTOR OF MAXFS FUNCTION VALUES RESULTING FROM SIMUL. INTERP.
3466 C     NDIM=NUMBER OF ARG VALUES TO BE USED. (NDIM.LE.MAXARG)
3467 C     NFS=NUMBER OF FUNCTIONS SIMUL. INTERP (NFS.LE.MAXFS)
3468 C     NPTS=NUMBER OF POINTS USED IN INTERPOLATION. (NPTS=2,3,4,5,6)
3469 C
3470       DIMENSION ARG(MAXARG), VAL(MAXFS,MAXARG), Y(MAXFS)
3471 C
3472 C     -----FIND X0, THE CLOSEST POINT TO X.
3473 C
3474       NI=1
3475       NF=NDIM
3476    10 IF ((X.LE.ARG(NI)).OR.(X.GE.ARG(NF))) GO TO 30
3477       IF ((NF-NI+1).EQ.2) GO TO 70
3478       NMID=(NF+NI)/2
3479       IF (X.GT.ARG(NMID)) GO TO 20
3480       NF=NMID
3481       GO TO 10
3482    20 NI=NMID
3483       GO TO 10
3484 C
3485 C     ------ X IS ONE OF THE TABLULATED VALUES.
3486 C
3487    30 IF (X.LE.ARG(NI)) GO TO 60
3488       NN=NF
3489    40 NUSED=0
3490       DO 50 N=1,NFS
3491    50 Y(N)=VAL(N,NN)
3492       RETURN
3493    60 NN=NI
3494       GO TO 40
3495 C
3496 C     ------- 2 PTS LEFT, CHOOSE SMALLER ONE.
3497 C
3498    70 N0=NI
3499       NN=NPTS-2
3500       GO TO (110,100,90,80), NN
3501    80 CONTINUE
3502       IF (((N0+3).GT.NDIM).OR.((N0-2).LT.1)) GO TO 90
3503       NUSED=6
3504       GO TO 130
3505    90 CONTINUE
3506       IF ((N0+2).GT.NDIM) GO TO 110
3507       IF ((N0-2).LT.1) GO TO 100
3508       NUSED=5
3509       GO TO 130
3510   100 CONTINUE
3511       IF (((N0+2).GT.NDIM).OR.((N0-1).LT.1)) GO TO 110
3512       NUSED=4
3513       GO TO 130
3514   110 IF ((N0+1).LT.NDIM) GO TO 120
3515 C
3516 C     ------N0=NDIM, SPECIAL CASE.
3517 C
3518       NN=NDIM
3519       GO TO 40
3520   120 NUSED=3
3521       IF ((N0-1).LT.1) NUSED=2
3522   130 CONTINUE
3523 C
3524 C     ------AT LEAST 2 PTS LEFT.
3525 C
3526       Y0=X-ARG(N0)
3527       Y1=X-ARG(N0+1)
3528       Y01=Y1-Y0
3529       C0=Y1/Y01
3530       C1=-Y0/Y01
3531       IF (NUSED.EQ.2) GO TO 140
3532 C
3533 C     ------AT LEAST 3 PTS.
3534 C
3535       YM1=X-ARG(N0-1)
3536       Y0M1=YM1-Y0
3537       YM11=Y1-YM1
3538       CM1=-Y0*Y1/Y0M1/YM11
3539       C0=C0*YM1/Y0M1
3540       C1=-C1*YM1/YM11
3541       IF (NUSED.EQ.3) GO TO 160
3542 C
3543 C     ------AT LEAST 4 PTS
3544 C
3545       Y2=X-ARG(N0+2)
3546       YM12=Y2-YM1
3547       Y02=Y2-Y0
3548       Y12=Y2-Y1
3549       CM1=CM1*Y2/YM12
3550       C0=C0*Y2/Y02
3551       C1=C1*Y2/Y12
3552       C2=-YM1*Y0*Y1/YM12/Y02/Y12
3553       IF (NUSED.EQ.4) GO TO 180
3554 C
3555 C     ------AT LEAST 5 PTS.
3556 C
3557       YM2=X-ARG(N0-2)
3558       YM2M1=YM1-YM2
3559       YM20=Y0-YM2
3560       YM21=Y1-YM2
3561       YM22=Y2-YM2
3562       CM2=YM1*Y0*Y1*Y2/YM2M1/YM20/YM21/YM22
3563       CM1=-CM1*YM2/YM2M1
3564       C0=-C0*YM2/YM20
3565       C1=-C1*YM2/YM21
3566       C2=-C2*YM2/YM22
3567       IF (NUSED.EQ.5) GO TO 200
3568 C
3569 C     ------AT LEAST 6 PTS.
3570 C
3571       Y3=X-ARG(N0+3)
3572       YM23=Y3-YM2
3573       YM13=Y3-YM1
3574       Y03=Y3-Y0
3575       Y13=Y3-Y1
3576       Y23=Y3-Y2
3577       CM2=CM2*Y3/YM23
3578       CM1=CM1*Y3/YM13
3579       C0=C0*Y3/Y03
3580       C1=C1*Y3/Y13
3581       C2=C2*Y3/Y23
3582       C3=YM2*YM1*Y0*Y1*Y2/YM23/YM13/Y03/Y13/Y23
3583       GO TO 220
3584   140 CONTINUE
3585       DO 150 N=1,NFS
3586   150 Y(N)=C0*VAL(N,N0)+C1*VAL(N,N0+1)
3587       GO TO 240
3588   160 CONTINUE
3589       DO 170 N=1,NFS
3590   170 Y(N)=CM1*VAL(N,N0-1)+C0*VAL(N,N0)+C1*VAL(N,N0+1)
3591       GO TO 240
3592   180 CONTINUE
3593       DO 190 N=1,NFS
3594   190 Y(N)=CM1*VAL(N,N0-1)+C0*VAL(N,N0)+C1*VAL(N,N0+1)+C2*VAL(N,N0+2)
3595       GO TO 240
3596   200 CONTINUE
3597       DO 210 N=1,NFS
3598   210 Y(N)=CM2*VAL(N,N0-2)+CM1*VAL(N,N0-1)+C0*VAL(N,N0)+C1*VAL(N,N0+1)+C
3599      12*VAL(N,N0+2)
3600       GO TO 240
3601   220 CONTINUE
3602       DO 230 N=1,NFS
3603   230 Y(N)=CM2*VAL(N,N0-2)+CM1*VAL(N,N0-1)+C0*VAL(N,N0)+C1*VAL(N,N0+1)+C
3604      12*VAL(N,N0+2)+C3*VAL(N,N0+3)
3605   240 RETURN
3606 C
3607       END
3608
3609 C-------------------------------------------------------------------
3610
3611
3612       subroutine Hbtp_kin(px,py,pz,E,pt,phi,eta,mass,control)
3613       implicit none
3614
3615 CCC   Four-momentum kinematics conversion:
3616 C
3617 C        If control = 1, use input {px,py,pz,mass} to calculate
3618 C                        {E,pt,phi,eta}
3619 C        If control = 2, use input {pt,phi,eta,mass} to calculate
3620 C                        {px,py,pz,E}
3621 C
3622 C        Units:  Momentum are in GeV/c
3623 C                Energy and mass are in GeV
3624 C                Angles are in degrees
3625
3626 CCC   Local Variable Type Declarations:
3627
3628       integer*4 control
3629
3630       real*4 px,py,pz,E,pt,phi,eta,mass
3631       real*4 theta,pi,rad,pcut,x,y
3632       parameter (pi = 3.141592654)
3633       parameter (pcut = 0.000001)
3634
3635       rad = 180.0/pi
3636
3637       If(control .eq. 1) Then   !   Use {px,py,pz,mass} --> {E,pt,phi,eta}
3638          pt = sqrt(px*px + py*py)
3639          E  = sqrt(pt*pt + pz*pz + mass*mass)
3640
3641 CCC   Compute azimuthal angle phi; treat pt = 0.0 and py = 0.0 cases
3642 CCC   separate.
3643
3644          if(pt .le. pcut) then
3645             phi = 0.0
3646          else if(pt.gt.pcut.and.abs(py).le.pcut.and.px.lt.0.0) then
3647             phi = pi
3648          else
3649             phi = atan2(py,px)
3650          end if
3651          if(phi .lt. 0.0) phi = phi + 2.0*pi
3652          phi = phi*rad
3653
3654 CCC   Compute pseudorapidity:
3655
3656          if(pt.le.pcut .and. abs(pz).le.pcut) then
3657             eta = 0.0
3658          else if(pt.le.pcut .and. abs(pz).gt.pcut) then
3659             eta = 0.5*log((E+pz)/(E-pz))   !  Use beam rapidity
3660          else
3661             theta = atan2(pt,pz)
3662             eta   = -log(tan(theta/2.0))
3663          end if
3664
3665       Else If(control .eq. 2) Then  ! Use {pt,phi,eta,mass} --> {E,px,py,pz}
3666
3667          px = pt*cos(phi/rad)
3668          py = pt*sin(phi/rad)
3669          if(abs(eta) .le. pcut) then
3670             pz = 0.0
3671          else
3672             x = exp(-eta)
3673             y = atan(x)
3674             theta = 2.0*y
3675 C            theta = 2.0*atan(exp(-eta))
3676             pz = pt/tan(theta)
3677          end if
3678
3679          E = sqrt(pt*pt + pz*pz + mass*mass)
3680
3681       End If   !  End control options
3682
3683       Return
3684       END
3685
3686 C----------------------------------------------------------------------
3687
3688
3689       subroutine qdiff(px1,py1,pz1,E1,px2,py2,pz2,E2,qinvar2,qtotal2,
3690      1           qvector2,qside2,qout2,qlong2,qperp2,qtime2)
3691       implicit none
3692
3693 CCC   This subroutine computes the various relative momenta for given
3694 CCC   input 4-momentum for particles 1 and 2.  The subr: returns the
3695 CCC   square of the momentum. All energy and momenta are in GeV.
3696 C
3697 C     Input 4-momentum for particle 1: {px1,py1,pz1,E1}
3698 C     Input 4-momentum for particle 2: {px2,py2,pz2,E2}
3699 C
3700 CCC   Computed Momentum Differences are the following:
3701 C
3702 C        qinvar2   = Q-invariant**2
3703 C        qtotal2   = Q-Total**2      (space**2 + time**2)
3704 C        qvector2  = 3-momentum vector difference squared
3705 C        qside2    = q-side**2 of Bertsch-Pratt 3D source models
3706 C        qout2     = q-out**2  of Bertsch-Pratt 3D source models
3707 C        qlong2    = q-long**2 of Bertsch-Pratt 3D source models
3708 C        qperp2    = q-perpendicular**2 of YKP 3D source models
3709 C        qparallel2= q-parallel**2 of YKP 3D source models
3710 C                  = qlong2 (not assigned a separate variable name)
3711 C        qtime2    = q-time-like**2 of YKP 3D source models
3712
3713 CCC   Local Variable Type Declarations:
3714
3715       real*4 px1,py1,pz1,E1,px2,py2,pz2,E2
3716       real*4 qinvar2,qtotal2,qvector2
3717       real*4 qside2,qout2,qlong2
3718       real*4 qperp2,qtime2
3719       real*4 px12sq,py12sq,pz12sq,E12sq
3720
3721       px12sq = (px1 - px2)**2
3722       py12sq = (py1 - py2)**2
3723       pz12sq = (pz1 - pz2)**2
3724       E12sq  = (E1  -  E2)**2
3725
3726       qvector2   = px12sq + py12sq + pz12sq
3727       qinvar2    = qvector2 - E12sq
3728       qtotal2    = qvector2 + E12sq
3729
3730       qlong2     = pz12sq
3731       qout2      = (px1*px1 - px2*px2 + py1*py1 - py2*py2)
3732       qout2      = qout2*qout2/((px1+px2)**2 + (py1+py2)**2)
3733       qperp2     = px12sq + py12sq
3734       qside2     = qperp2 - qout2
3735       qtime2     = E12sq
3736       if (qside2 .lt. 0) then
3737 C        write(*,*) 'qside2 is less then 0', qside2
3738 C       write(*,*) ' qperp2, qout2', qperp2, qout2
3739 C       write(*,*) ' px1,py1,pz1,E1 ',px1,py1,pz1,E1
3740 C       write(*,*) ' px2,py2,pz2,E2 ',px2,py2,pz2,E2
3741         qside2 = 0.0
3742       end if
3743       Return
3744       END
3745
3746 C-----------------------------------------------------------------------
3747
3748
3749       subroutine mean_rms(a,ndim,npts,mean,rms)
3750       implicit none
3751
3752 CCC   Calculate the mean and standard deviation (rms) for input
3753 C     distribution a() for npts number of values.
3754 C     ndim = dimension of array a() in calling program.
3755
3756 CCC   Local Variable Type Declarations:
3757
3758       integer*4 ndim, npts, i
3759       real*4 a(ndim), mean, rms, sum_mean, sum_rms
3760
3761       if(npts .le. 0) then
3762          mean = 0.0
3763          rms  = 0.0
3764          return
3765       else if(npts .eq. 1) then
3766          mean = a(1)
3767          rms  = 0.0
3768          return
3769       else
3770          sum_mean = 0.0
3771          sum_rms  = 0.0
3772          do i = 1,npts
3773          sum_mean = sum_mean + a(i)
3774          end do
3775          mean = sum_mean/float(npts)
3776
3777          do i = 1,npts
3778          sum_rms  = sum_rms + (a(i) - mean)**2
3779          end do
3780          rms = sqrt((sum_rms)/float(npts - 1))
3781          return
3782       end if
3783
3784       END
3785
3786 C-----------------------------------------------------------------------
3787
3788
3789       subroutine tindex(mode,track_id)
3790       implicit none
3791
3792 CCC   This subroutine locates tracks in {px,py,pz} sectors
3793 C     and sets the sector index numbers
3794 C     in track table 'trk' and/or 'trk2', depending on the value of 'mode'.
3795 C     If a track's momentum is out of the sector ranges, then the track
3796 C     will be assigned to, and counted in the nearest sector cell on the
3797 C     edge or corner.
3798 C
3799 C     If mode = 1, apply to tracks in table 'trk'
3800 C     If mode = 2, apply to tracks in table 'trk2'
3801 C
3802 C     If track_id = 0, then do this for all tracks
3803 C     If track_id = i (where i.gt.0) then do this for track row i only
3804
3805       Include 'common_parameters.inc'
3806       Include 'common_mesh.inc'
3807
3808       Include 'common_track.inc'
3809       Include 'common_track2.inc'
3810
3811 CCC   Local Variable Type Declarations:
3812
3813       integer*4 i,track_id,mode
3814
3815 C-----------------------
3816       If(mode.eq.1) Then
3817 C-----------------------
3818
3819        If(track_id .eq. 0) Then
3820          do i = 1,n_part_tot_trk
3821          trk_px_sec(i) = int(((trk_px(i) - px_min)/delpx)+1.00001)
3822             if(trk_px_sec(i) .lt.1) trk_px_sec(i) = 1
3823             if(trk_px_sec(i) .gt. n_px_bins) trk_px_sec(i) = n_px_bins
3824          trk_py_sec(i) = int(((trk_py(i) - py_min)/delpy)+1.00001)
3825             if(trk_py_sec(i) .lt.1) trk_py_sec(i) = 1
3826             if(trk_py_sec(i) .gt. n_py_bins) trk_py_sec(i) = n_py_bins
3827          trk_pz_sec(i) = int(((trk_pz(i) - pz_min)/delpz)+1.00001)
3828             if(trk_pz_sec(i) .lt.1) trk_pz_sec(i) = 1
3829             if(trk_pz_sec(i) .gt. n_pz_bins) trk_pz_sec(i) = n_pz_bins
3830          trk_sector(i) = trk_px_sec(i) + (trk_py_sec(i) - 1)*
3831      1      n_px_bins + (trk_pz_sec(i) - 1)*n_px_bins*n_py_bins
3832          end do
3833
3834        Else If(track_id .gt. 0) Then
3835          i = track_id
3836          trk_px_sec(i) = int(((trk_px(i) - px_min)/delpx)+1.00001)
3837             if(trk_px_sec(i) .lt.1) trk_px_sec(i) = 1
3838             if(trk_px_sec(i) .gt. n_px_bins) trk_px_sec(i) = n_px_bins
3839          trk_py_sec(i) = int(((trk_py(i) - py_min)/delpy)+1.00001)
3840             if(trk_py_sec(i) .lt.1) trk_py_sec(i) = 1
3841             if(trk_py_sec(i) .gt. n_py_bins) trk_py_sec(i) = n_py_bins
3842          trk_pz_sec(i) = int(((trk_pz(i) - pz_min)/delpz)+1.00001)
3843             if(trk_pz_sec(i) .lt.1) trk_pz_sec(i) = 1
3844             if(trk_pz_sec(i) .gt. n_pz_bins) trk_pz_sec(i) = n_pz_bins
3845          trk_sector(i) = trk_px_sec(i) + (trk_py_sec(i) - 1)*
3846      1      n_px_bins + (trk_pz_sec(i) - 1)*n_px_bins*n_py_bins
3847        End If
3848
3849 C-----------------------------
3850       Else If (mode.eq.2) Then
3851 C-----------------------------
3852
3853        If(track_id .eq. 0) Then
3854          do i = 1,n_part_tot_trk2
3855          trk2_px_sec(i) = int(((trk2_px(i) - px_min)/delpx)+1.00001)
3856             if(trk2_px_sec(i) .lt.1) trk2_px_sec(i) = 1
3857             if(trk2_px_sec(i) .gt. n_px_bins) trk2_px_sec(i) = n_px_bins
3858          trk2_py_sec(i) = int(((trk2_py(i) - py_min)/delpy)+1.00001)
3859             if(trk2_py_sec(i) .lt.1) trk2_py_sec(i) = 1
3860             if(trk2_py_sec(i) .gt. n_py_bins) trk2_py_sec(i) = n_py_bins
3861          trk2_pz_sec(i) = int(((trk2_pz(i) - pz_min)/delpz)+1.00001)
3862             if(trk2_pz_sec(i) .lt.1) trk2_pz_sec(i) = 1
3863             if(trk2_pz_sec(i) .gt. n_pz_bins) trk2_pz_sec(i) = n_pz_bins
3864          trk2_sector(i) = trk2_px_sec(i) + (trk2_py_sec(i) - 1)*
3865      1      n_px_bins + (trk2_pz_sec(i) - 1)*n_px_bins*n_py_bins
3866          end do
3867
3868        Else If(track_id .gt. 0) Then
3869          i = track_id
3870          trk2_px_sec(i) = int(((trk2_px(i) - px_min)/delpx)+1.00001)
3871             if(trk2_px_sec(i) .lt.1) trk2_px_sec(i) = 1
3872             if(trk2_px_sec(i) .gt. n_px_bins) trk2_px_sec(i) = n_px_bins
3873          trk2_py_sec(i) = int(((trk2_py(i) - py_min)/delpy)+1.00001)
3874             if(trk2_py_sec(i) .lt.1) trk2_py_sec(i) = 1
3875             if(trk2_py_sec(i) .gt. n_py_bins) trk2_py_sec(i) = n_py_bins
3876          trk2_pz_sec(i) = int(((trk2_pz(i) - pz_min)/delpz)+1.00001)
3877             if(trk2_pz_sec(i) .lt.1) trk2_pz_sec(i) = 1
3878             if(trk2_pz_sec(i) .gt. n_pz_bins) trk2_pz_sec(i) = n_pz_bins
3879          trk2_sector(i) = trk2_px_sec(i) + (trk2_py_sec(i) - 1)*
3880      1      n_px_bins + (trk2_pz_sec(i) - 1)*n_px_bins*n_py_bins
3881        End If
3882
3883 C------------
3884       End If
3885 C------------
3886
3887       Return
3888       END
3889
3890 C------------------------------------------------------------------------
3891
3892
3893       subroutine stm_build(mode,track_index,old_sector)
3894       implicit none
3895
3896 CCC   This subroutine fills or updates the track-sector information
3897 C     table sec_trk_map or, for the reference calculations, it fills
3898 C     sec_trk_map2.  These track-sector tables contain the information
3899 C     about the track occupancy, status, etc. for all of the {px,py,pz}
3900 C     sectors.
3901 C
3902 C     For Mode = 1:
3903 C
3904 C        If track_index = 0, then fill information for all tracks in 'trk',
3905 C                            into table 'stm'
3906 C        If track_index = i (where i.gt.0) then fill only the track-sector
3907 C                           information for track i in 'trk', into table 'stm'
3908 C                           Also for this case, if old_sector .ne. 0, then
3909 C                           remove the track # and ID information for this
3910 C                           old sector # from table stm
3911 C
3912 C     For Mode = 2: Fill information for all tracks in 'trk2' into table 'stm2'
3913
3914       Include 'common_parameters.inc'
3915       Include 'common_mesh.inc'
3916
3917       Include 'common_track.inc'
3918       Include 'common_track2.inc'
3919       Include 'common_sec_track.inc'
3920       Include 'common_sec_track2.inc'
3921
3922 CCC   Local Variable Type Declarations:
3923
3924       integer*4 i,j,mode,track_index,old_sector,row
3925       integer*4 temp(max_trk_sec)
3926
3927 C------------------------
3928       IF (mode.eq.1) Then
3929 C------------------------
3930
3931        If (track_index .eq. 0) Then
3932          do i = 1,sec_maxlen
3933             stm_sec_id(i) = 0
3934             stm_n_trk_sec(i) = 0
3935             do j = 1,max_trk_sec
3936                stm_track_id(j,i) = 0
3937             end do
3938             stm_flag(i) = 0
3939          end do
3940          do i = 1,n_sectors
3941          stm_sec_id(i) = i
3942          end do
3943          do i = 1,n_part_tot_trk
3944          if(trk_flag(i) .eq. 0) then
3945          row = trk_sector(i)
3946          stm_n_trk_sec(row) = stm_n_trk_sec(row) + 1
3947          if(stm_n_trk_sec(row) .le. max_trk_sec) then
3948             stm_track_id(stm_n_trk_sec(row),row) = trk_id(i)
3949             stm_flag(row) = 0
3950             trk_flag(i)   = 0
3951          else
3952             stm_n_trk_sec(row) = stm_n_trk_sec(row) - 1
3953             stm_flag(row) = 1
3954             trk_flag(i)   = 1
3955             trk_sector(i) = 0
3956          end if
3957          end if
3958          end do
3959
3960        Else If (track_index .gt. 0) Then
3961
3962          if(old_sector .ne. 0) then
3963 CCC   Remove track from old sector:
3964             j = 0
3965             do i = 1,stm_n_trk_sec(old_sector)
3966                if(stm_track_id(i,old_sector) .ne. track_index) then
3967                   j = j + 1
3968                   temp(j) = stm_track_id(i,old_sector)
3969                end if
3970             end do
3971             stm_n_trk_sec(old_sector) = j
3972             do i = 1,max_trk_sec
3973                stm_track_id(i,old_sector) = 0
3974             end do
3975             do i = 1,stm_n_trk_sec(old_sector)
3976                stm_track_id(i,old_sector) = temp(i)
3977             end do
3978          end if
3979 CCC   Update with new sector location of track:
3980          i = track_index
3981          if(trk_flag(i) .eq. 0) then
3982          row = trk_sector(i)
3983          stm_n_trk_sec(row) = stm_n_trk_sec(row) + 1
3984          if(stm_n_trk_sec(row) .le. max_trk_sec) then
3985             stm_track_id(stm_n_trk_sec(row),row) = trk_id(i)
3986             stm_flag(row) = 0
3987             trk_flag(i)   = 0
3988          else
3989             stm_n_trk_sec(row) = stm_n_trk_sec(row) - 1
3990             stm_flag(row) = 1
3991             trk_flag(i)   = 1
3992             trk_sector(i) = 0
3993          end if
3994          end if
3995        End If
3996
3997 C-----------------------------
3998       Else If (mode.eq.2) Then
3999 C-----------------------------
4000
4001        If (track_index .eq. 0) Then
4002          do i = 1,sec_maxlen2
4003             stm2_sec_id(i) = 0
4004             stm2_n_trk_sec(i) = 0
4005             do j = 1,max_trk_sec2
4006                stm2_track_id(j,i) = 0
4007             end do
4008             stm2_flag(i) = 0
4009          end do
4010          do i = 1,n_sectors
4011          stm2_sec_id(i) = i
4012          end do
4013          do i = 1,n_part_tot_trk2
4014          if(trk2_flag(i) .eq. 0) then
4015          row = trk2_sector(i)
4016          stm2_n_trk_sec(row) = stm2_n_trk_sec(row) + 1
4017          if(stm2_n_trk_sec(row) .le. max_trk_sec2) then
4018             stm2_track_id(stm2_n_trk_sec(row),row) = trk2_id(i)
4019             stm2_flag(row) = 0
4020             trk2_flag(i)   = 0
4021          else
4022             stm2_n_trk_sec(row) = stm2_n_trk_sec(row) - 1
4023             stm2_flag(row) = 1
4024             trk2_flag(i)   = 1
4025             trk2_sector(i) = 0
4026          end if
4027          end if
4028          end do
4029        end if
4030
4031 C------------
4032       End If   !  End mode = 1,2 selection options
4033 C------------
4034
4035       Return
4036       END
4037
4038 C-----------------------------------------------------------------------
4039
4040
4041       subroutine sec_index(index,nbins,index_min,index_max)
4042       implicit none
4043
4044 CCC   Calculate track-sector neighboring bins and min->max range:
4045
4046 CCC   Local Variable Type Declarations:
4047
4048       integer*4 index,nbins,index_min,index_max
4049
4050       index_min = index - 1
4051       if(index_min .lt. 1) index_min = 1
4052       index_max = index + 1
4053       if(index_max .gt. nbins) index_max = nbins
4054
4055       Return
4056       END
4057
4058 C-----------------------------------------------------------------------
4059
4060
4061       subroutine dist_range(mode,ntracks_out,ntracks_flagged)
4062       implicit none
4063
4064 CCC   Determine if tracks are out of acceptance range in pt, phi and eta,
4065 C     and, if so, then set the 'out_flag' variable in the track table 'trk'
4066
4067 CCC   For Mode = 1, use track table 'trk'
4068 CCC   For Mode = 2, use track table 'trk2'
4069
4070 CCC   Count the number of flagged tracks, i.e. trk(i).flag = 1, and "out
4071 C     of acceptance range" tracks, i.e. trk(i).out_flag = 1, for both
4072 C     particle ID types.  Determine the number of tracks to use in the
4073 C     correlation fit for each particle ID type.
4074
4075       Include 'common_parameters.inc'
4076       Include 'common_mesh.inc'
4077
4078       Include 'common_track.inc'
4079       Include 'common_track2.inc'
4080
4081 CCC   Local Variable Type Declarations:
4082
4083       integer*4 i,mode,ntracks_out,ntracks_flagged
4084
4085 C------------------------
4086       If (mode.eq.1) Then
4087 C------------------------
4088
4089       do i = 1,trk_maxlen
4090       trk_out_flag(i) = 0
4091       end do
4092
4093       ntracks_flagged = 0
4094
4095       do i = 1,n_part_tot_trk
4096       if(trk_flag(i) .eq. 0) then
4097       if(trk_pt(i) .lt. pt_min .or. trk_pt(i) .gt. pt_max)
4098      1   trk_out_flag(i)=1
4099       if(trk_phi(i).lt.phi_min .or. trk_phi(i).gt.phi_max)
4100      1   trk_out_flag(i)=1
4101       if(trk_eta(i).lt.eta_min .or. trk_eta(i).gt.eta_max)
4102      1   trk_out_flag(i)=1
4103       else if(trk_flag(i) .eq. 1) then
4104       ntracks_flagged = ntracks_flagged + 1
4105       end if
4106       end do
4107
4108       ntracks_out = 0
4109       do i = 1,n_part_tot_trk
4110       if(trk_out_flag(i) .eq. 1) ntracks_out = ntracks_out + 1
4111       end do
4112
4113       n_part_used_1_trk = 0
4114       n_part_used_2_trk = 0
4115       do i = 1,n_part_tot_trk
4116          if(trk_flag(i) .eq. 0) then
4117             if(trk_ge_pid(i) .eq. pid(1)) then
4118                n_part_used_1_trk = n_part_used_1_trk + 1
4119             else if(trk_ge_pid(i) .eq. pid(2)) then
4120                n_part_used_2_trk = n_part_used_2_trk + 1
4121             end if
4122          end if
4123       end do
4124
4125 C-----------------------------
4126       Else If (mode.eq.2) Then
4127 C-----------------------------
4128
4129       do i = 1,trk2_maxlen
4130       trk2_out_flag(i) = 0
4131       end do
4132
4133       ntracks_flagged = 0
4134
4135       do i = 1,n_part_tot_trk2
4136       if(trk2_flag(i) .eq. 0) then
4137       if(trk2_pt(i) .lt. pt_min .or. trk2_pt(i) .gt. pt_max)
4138      1   trk2_out_flag(i)=1
4139       if(trk2_phi(i).lt.phi_min .or. trk2_phi(i).gt.phi_max)
4140      1   trk2_out_flag(i)=1
4141       if(trk2_eta(i).lt.eta_min .or. trk2_eta(i).gt.eta_max)
4142      1   trk2_out_flag(i)=1
4143       else if(trk2_flag(i) .eq. 1) then
4144       ntracks_flagged = ntracks_flagged + 1
4145       end if
4146       end do
4147
4148       ntracks_out = 0
4149       do i = 1,n_part_tot_trk2
4150       if(trk2_out_flag(i) .eq. 1) ntracks_out = ntracks_out + 1
4151       end do
4152
4153       n_part_used_1_trk2 = 0
4154       n_part_used_2_trk2 = 0
4155       do i = 1,n_part_tot_trk2
4156          if(trk2_flag(i) .eq. 0) then
4157             if(trk2_ge_pid(i) .eq. pid(1)) then
4158                n_part_used_1_trk2 = n_part_used_1_trk2 + 1
4159             else if(trk2_ge_pid(i) .eq. pid(2)) then
4160                n_part_used_2_trk2 = n_part_used_2_trk2 + 1
4161             end if
4162          end if
4163       end do
4164
4165 C------------
4166       End If  !  End mode = 1,2 selection option
4167 C------------
4168
4169       Return
4170       END
4171
4172 C--------------------------------------------------------------------
4173
4174
4175       subroutine histog1(mode,itrack,pid_index,pidnum,pt_save,
4176      1                   phi_save,eta_save)
4177       implicit none
4178
4179 CCC   This subroutine computes and/or updates the one-body histograms
4180 C     according to the selected 'mode' and for the requested particle
4181 C     ID type.
4182
4183 C     Note:  If the track momentum is out-of-range in {pt,phi,eta},
4184 C            then it is ignored.  The {pt,phi,eta} dependences for
4185 C            the 1-dimensional histogramming are treated independently.
4186 C            It is therefore possible for the sum of the number of
4187 C            particles in the pt, phi and eta one-body, 1D histograms
4188 C            to be unequal.
4189
4190 CCC   Mode = 1,  Fill the one-body histograms (hist1*) for selected
4191 C                particle ID type, for the initial input distribution,
4192 C                using the momenta in 'trk'
4193 C
4194 C     Mode = 2,  Remove particle 'itrack' from temporary one-body hist-
4195 C                ogram (htmp1*) for selected particle ID type, using
4196 C                momentum values given by pt_save, phi_save, eta_save.
4197 C
4198 C     Mode = 3,  Add particle 'itrack' to the temporary one-body hist-
4199 C                ogram (htmp1*) for selected particle ID type, using
4200 C                momentum values in track table 'trk'.
4201 C
4202 C     Mode = 4,  Fill the one-body histograms (hist1*) for selected
4203 C                particle ID type, for the initial input distribution,
4204 C                using the momenta in 'trk2'
4205 C
4206 C     itrack =   track index # for the removed or added track for mode =
4207 C                2 or 3, respectively.
4208 C
4209 C     pid_index = 1 or 2 for the first or second particle ID type, and
4210 C                 for filling/update either hist1*1 or hist1*2, and
4211 C                 similarly for htmp1*1 or htmp1*2
4212 C
4213 C     pidnum    =   Geant particle ID # for the track(s) to be filled or
4214 C                updated.
4215 C
4216 C     pt_save  = Removed track's pt value.
4217 C
4218 C     phi_save = Removed track's phi value.
4219 C
4220 C     eta_save = Removed track's eta value.
4221
4222       Include 'common_parameters.inc'
4223       Include 'common_mesh.inc'
4224       Include 'common_histograms.inc'
4225
4226       Include 'common_track.inc'
4227       Include 'common_track2.inc'
4228
4229 CCC   Local Variable Type Declarations:
4230
4231       integer*4 mode,itrack,i,pid_index,pidnum,index
4232       integer*4 trk_counter,trk2_counter
4233
4234       real*4    pt_save,phi_save,eta_save
4235       real*4    delpt,delphi,deleta
4236
4237 C-------------------------
4238       If (mode.eq.1) Then
4239 C-------------------------
4240
4241 CCC   Fill one-body histograms for requested particle ID from table 'trk'
4242 CCC   Initialize necessary arrays to zero:
4243
4244          if(pid_index .eq. 1) then
4245             do i = 1,max_h_1d
4246                hist1_pt_1(i)  = 0
4247                hist1_phi_1(i) = 0
4248                hist1_eta_1(i) = 0
4249             end do
4250          else if(pid_index .eq. 2) then
4251             do i = 1,max_h_1d
4252                hist1_pt_2(i)  = 0
4253                hist1_phi_2(i) = 0
4254                hist1_eta_2(i) = 0
4255             end do
4256          end if
4257
4258          trk_counter = 0
4259
4260          do i = 1,n_part_tot_trk
4261             if(trk_ge_pid(i).eq.pidnum .and. trk_flag(i).eq.0) then
4262                trk_counter = trk_counter + 1
4263                delpt  = trk_pt(i)   - pt_min
4264                delphi = trk_phi(i)  - phi_min
4265                deleta = trk_eta(i)  - eta_min
4266
4267                index = int((delpt/pt_bin_size) + 0.99999)
4268                if(index.ge.1 .and. index.le.max_h_1d) then
4269                   if(pid_index.eq.1) hist1_pt_1(index) =
4270      1                               hist1_pt_1(index) + 1
4271                   if(pid_index.eq.2) hist1_pt_2(index) =
4272      1                               hist1_pt_2(index) + 1
4273                end if
4274
4275                index = int((delphi/phi_bin_size) + 0.99999)
4276                if(index.ge.1 .and. index.le.max_h_1d) then
4277                   if(pid_index.eq.1) hist1_phi_1(index) =
4278      1                               hist1_phi_1(index) + 1
4279                   if(pid_index.eq.2) hist1_phi_2(index) =
4280      1                               hist1_phi_2(index) + 1
4281                end if
4282
4283                index = int((deleta/eta_bin_size) + 0.99999)
4284                if(index.ge.1 .and. index.le.max_h_1d) then
4285                   if(pid_index.eq.1) hist1_eta_1(index) =
4286      1                               hist1_eta_1(index) + 1
4287                   if(pid_index.eq.2) hist1_eta_2(index) =
4288      1                               hist1_eta_2(index) + 1
4289                end if
4290
4291             end if
4292          end do
4293
4294          if(pid_index .eq. 1) n_part_used_1_trk = trk_counter
4295          if(pid_index .eq. 2) n_part_used_2_trk = trk_counter
4296
4297 C--------------------------------
4298       Else If (mode .eq. 2) Then
4299 C--------------------------------
4300
4301 CCC   Remove track # 'itrack' from fitting histograms in htmp1*,
4302 CCC   use pt_save, phi_save, eta_save for the old momentum values
4303 CCC   in order to determine which bins to decrement.
4304
4305          if(trk_ge_pid(itrack).eq.pidnum.and.trk_flag(itrack).eq.0)then
4306                delpt  = pt_save  - pt_min
4307                delphi = phi_save - phi_min
4308                deleta = eta_save - eta_min
4309
4310                index = int((delpt/pt_bin_size) + 0.99999)
4311                if(index.ge.1 .and. index.le.max_h_1d) then
4312                   if(pid_index.eq.1) htmp1_pt_1(index) =
4313      1                               htmp1_pt_1(index) - 1
4314                   if(pid_index.eq.2) htmp1_pt_2(index) =
4315      1                               htmp1_pt_2(index) - 1
4316                end if
4317
4318                index = int((delphi/phi_bin_size) + 0.99999)
4319                if(index.ge.1 .and. index.le.max_h_1d) then
4320                   if(pid_index.eq.1) htmp1_phi_1(index) =
4321      1                               htmp1_phi_1(index) - 1
4322                   if(pid_index.eq.2) htmp1_phi_2(index) =
4323      1                               htmp1_phi_2(index) - 1
4324                end if
4325
4326                index = int((deleta/eta_bin_size) + 0.99999)
4327                if(index.ge.1 .and. index.le.max_h_1d) then
4328                   if(pid_index.eq.1) htmp1_eta_1(index) =
4329      1                               htmp1_eta_1(index) - 1
4330                   if(pid_index.eq.2) htmp1_eta_2(index) =
4331      1                               htmp1_eta_2(index) - 1
4332                end if
4333
4334          end if
4335
4336 C--------------------------------
4337       Else If (mode .eq. 3) Then
4338 C--------------------------------
4339
4340 CCC   Add track # 'itrack' to fitting histograms in htmp1*,
4341 CCC   use pt, phi and eta values in track table 'trk(itrack)'
4342 CCC   for the new/added track position.
4343
4344          if(trk_ge_pid(itrack).eq.pidnum.and.trk_flag(itrack).eq.0)then
4345                delpt  = trk_pt(itrack)  - pt_min
4346                delphi = trk_phi(itrack) - phi_min
4347                deleta = trk_eta(itrack) - eta_min
4348
4349                index = int((delpt/pt_bin_size) + 0.99999)
4350                if(index.ge.1 .and. index.le.max_h_1d) then
4351                   if(pid_index.eq.1) htmp1_pt_1(index) =
4352      1                               htmp1_pt_1(index) + 1
4353                   if(pid_index.eq.2) htmp1_pt_2(index) =
4354      1                               htmp1_pt_2(index) + 1
4355                end if
4356
4357                index = int((delphi/phi_bin_size) + 0.99999)
4358                if(index.ge.1 .and. index.le.max_h_1d) then
4359                   if(pid_index.eq.1) htmp1_phi_1(index) =
4360      1                               htmp1_phi_1(index) + 1
4361                   if(pid_index.eq.2) htmp1_phi_2(index) =
4362      1                               htmp1_phi_2(index) + 1
4363                end if
4364
4365                index = int((deleta/eta_bin_size) + 0.99999)
4366                if(index.ge.1 .and. index.le.max_h_1d) then
4367                   if(pid_index.eq.1) htmp1_eta_1(index) =
4368      1                               htmp1_eta_1(index) + 1
4369                   if(pid_index.eq.2) htmp1_eta_2(index) =
4370      1                               htmp1_eta_2(index) + 1
4371                end if
4372
4373          end if
4374
4375 C------------------------------
4376       Else If (mode.eq.4) Then
4377 C------------------------------
4378
4379 CCC   Fill one-body histograms for requested particle ID from table 'trk2'
4380 CCC   Initialize necessary arrays to zero:
4381
4382          if(pid_index .eq. 1) then
4383             do i = 1,max_h_1d
4384                hist1_pt_1(i)  = 0
4385                hist1_phi_1(i) = 0
4386                hist1_eta_1(i) = 0
4387             end do
4388          else if(pid_index .eq. 2) then
4389             do i = 1,max_h_1d
4390                hist1_pt_2(i)  = 0
4391                hist1_phi_2(i) = 0
4392                hist1_eta_2(i) = 0
4393             end do
4394          end if
4395
4396          trk2_counter = 0
4397
4398          do i = 1,n_part_tot_trk2
4399             if(trk2_ge_pid(i).eq.pidnum .and. trk2_flag(i).eq.0) then
4400                trk2_counter = trk2_counter + 1
4401                delpt  = trk2_pt(i)   - pt_min
4402                delphi = trk2_phi(i)  - phi_min
4403                deleta = trk2_eta(i)  - eta_min
4404
4405                index = int((delpt/pt_bin_size) + 0.99999)
4406                if(index.ge.1 .and. index.le.max_h_1d) then
4407                   if(pid_index.eq.1) hist1_pt_1(index) =
4408      1                               hist1_pt_1(index) + 1
4409                   if(pid_index.eq.2) hist1_pt_2(index) =
4410      1                               hist1_pt_2(index) + 1
4411                end if
4412
4413                index = int((delphi/phi_bin_size) + 0.99999)
4414                if(index.ge.1 .and. index.le.max_h_1d) then
4415                   if(pid_index.eq.1) hist1_phi_1(index) =
4416      1                               hist1_phi_1(index) + 1
4417                   if(pid_index.eq.2) hist1_phi_2(index) =
4418      1                               hist1_phi_2(index) + 1
4419                end if
4420
4421                index = int((deleta/eta_bin_size) + 0.99999)
4422                if(index.ge.1 .and. index.le.max_h_1d) then
4423                   if(pid_index.eq.1) hist1_eta_1(index) =
4424      1                               hist1_eta_1(index) + 1
4425                   if(pid_index.eq.2) hist1_eta_2(index) =
4426      1                               hist1_eta_2(index) + 1
4427                end if
4428
4429             end if
4430          end do
4431
4432          if(pid_index .eq. 1) n_part_used_1_trk2 = trk2_counter
4433          if(pid_index .eq. 2) n_part_used_2_trk2 = trk2_counter
4434
4435 C------------
4436       End If   !   End Mode = 1,2,3,4 Selection Options
4437 C------------
4438
4439       Return
4440       END
4441
4442 C-----------------------------------------------------------------------
4443
4444       subroutine histog2(mode,itrack,px_sec_save,py_sec_save,
4445      1           pz_sec_save,px_save,py_save,pz_save,E_save)
4446       implicit none
4447
4448 CCC   This subroutine computes and/or updates the two-body histograms
4449 C     according to the selected 'mode' and for the necessary particle
4450 C     ID type(s).
4451
4452 C     Mode = 1,  Fill the two-body histograms (hist*) for all particles
4453 C                in table 'trk' for like and unlike pairs, for 1D and/or
4454 C                3D fine and 3D coarse mesh bins.
4455 C
4456 C     Mode = 2,  Remove all old track pairs for 'itrack' particle from
4457 C                all htmp* histograms, for particles in table 'trk', for
4458 C                like and unlike pairs, for 1D and/or 3D fine and 3D coarse
4459 C                mesh bins; using the saved momentum and track values.
4460 C
4461 C     Mode = 3,  Add all new track pairs for 'itrack' particle to
4462 C                all htmp* histograms, for particles in table 'trk', for
4463 C                like and unlike pairs, for 1D and/or 3D fine and 3D coarse
4464 C                mesh bins; using the values in table 'trk(itrack).*'
4465 C
4466 C     Mode = 4,  Fill and accumulate reference histograms (href*) for all
4467 C                particle pairs from tables 'trk' and 'trk2', for like and
4468 C                unlike pairs, for 1D and/or 3D fine and 3D coarse
4469 C                mesh bins.
4470 C
4471 C     itrack =   single track index in table 'trk' for pairs to be removed
4472 C                (mode = 2) or added (mode = 3).
4473
4474       Include 'common_parameters.inc'
4475       Include 'common_mesh.inc'
4476       Include 'common_histograms.inc'
4477
4478       Include 'common_track.inc'
4479       Include 'common_track2.inc'
4480       Include 'common_sec_track.inc'
4481       Include 'common_sec_track2.inc'
4482
4483 CCC   Local Variable Type Declarations:
4484
4485       integer*4 mode,itrack,i,j,k,jx,jy,jz
4486       integer*4 jsec,trkj_sector,imin,imax,njtrks
4487       integer*4 index1,index2,index3
4488       integer*4 findex1,findex2,findex3
4489       integer*4 ipxmin,ipymin,ipzmin
4490       integer*4 ipxmax,ipymax,ipzmax
4491       integer*4 trki_pid,trkj_pid
4492       integer*4 px_sec_save,py_sec_save,pz_sec_save
4493
4494       real*4    qinvar2,qtotal2,qvector2
4495       real*4    qside2, qout2,  qlong2
4496       real*4    qperp2, qtime2
4497       real*4    qdiff1, qdiff2, qdiff3
4498       real*4    px_save,py_save,pz_save,E_save
4499
4500       If (mode .eq. 1) Then     ! Full hist* filling; initialize arrays to zero.
4501
4502         do i = 1,max_h_1d
4503           hist_like_1d(i)   = 0
4504           hist_unlike_1d(i) = 0
4505         end do
4506
4507         do i = 1,max_h_3d
4508         do j = 1,max_h_3d
4509         do k = 1,max_h_3d
4510           hist_like_3d_fine(i,j,k)     = 0
4511           hist_unlike_3d_fine(i,j,k)   = 0
4512           hist_like_3d_coarse(i,j,k)   = 0
4513           hist_unlike_3d_coarse(i,j,k) = 0
4514         end do
4515         end do
4516         end do
4517
4518       End If
4519
4520 CCC   Select # of particles to loop over for each 'mode':
4521
4522       If (mode .eq. 1) Then
4523          imin = 2
4524          imax = n_part_tot_trk
4525       Else If (mode .eq. 2 .or. mode .eq. 3) Then
4526          imin = itrack
4527          imax = itrack
4528       Else If (mode .eq. 4) Then
4529          imin = 1
4530          imax = n_part_tot_trk
4531       End If
4532
4533 C------------------------------------------------------
4534 CCC   Begin Primary Loop over particles in Table 'trk':
4535 C------------------------------------------------------
4536
4537       do i = imin,imax
4538       if(trk_flag(i) .eq. 0) then
4539         trki_pid = trk_ge_pid(i)
4540         if(mode.eq.2) then
4541           Call sec_index(px_sec_save,n_px_bins,ipxmin,ipxmax)
4542           Call sec_index(py_sec_save,n_py_bins,ipymin,ipymax)
4543           Call sec_index(pz_sec_save,n_pz_bins,ipzmin,ipzmax)
4544         else
4545           Call sec_index(trk_px_sec(i),n_px_bins,ipxmin,ipxmax)
4546           Call sec_index(trk_py_sec(i),n_py_bins,ipymin,ipymax)
4547           Call sec_index(trk_pz_sec(i),n_pz_bins,ipzmin,ipzmax)
4548         end if
4549
4550 CCC   Begin Loop over neighboring sectors for track # 'i':
4551
4552         do jx = ipxmin,ipxmax
4553         do jy = ipymin,ipymax
4554         do jz = ipzmin,ipzmax
4555           trkj_sector = jx + (jy-1)*n_px_bins
4556      1                + (jz-1)*n_px_bins*n_py_bins
4557           njtrks = 0
4558           if(mode.le.3) njtrks = stm_n_trk_sec(trkj_sector)
4559           if(mode.eq.4) njtrks = stm2_n_trk_sec(trkj_sector)
4560           if(njtrks .gt. 0) then
4561
4562 CCC   Begin Secondary Loop over particles in selected sectors in tables
4563 CCC   'trk' or 'trk2':
4564             do jsec = 1,njtrks
4565               if(mode.le.3) j = stm_track_id(jsec,trkj_sector)
4566               if(mode.eq.4) j = stm2_track_id(jsec,trkj_sector)
4567               if((mode.eq.1 .and. j.lt.i .and. trk_flag(j).eq.0)
4568      1       .or.(mode.eq.2 .and. j.ne.i .and. trk_flag(j).eq.0)
4569      2       .or.(mode.eq.3 .and. j.ne.i .and. trk_flag(j).eq.0)
4570      3       .or.(mode.eq.4 .and. trk2_flag(j).eq.0)) then
4571
4572 CCC   Obtain 1D and 3D relative momenta:
4573
4574                 if(mode.eq.1 .or. mode.eq.3) then
4575                   trkj_pid = trk_ge_pid(j)
4576                   Call qdiff(trk_px(i),trk_py(i),trk_pz(i),trk_E(i),
4577      1                       trk_px(j),trk_py(j),trk_pz(j),trk_E(j),
4578      2              qinvar2,qtotal2,qvector2,qside2,qout2,qlong2,
4579      3              qperp2,qtime2)
4580                 else if(mode.eq.2) then
4581                   trkj_pid = trk_ge_pid(j)
4582                   Call qdiff(px_save,py_save,pz_save,E_save,
4583      1                       trk_px(j),trk_py(j),trk_pz(j),trk_E(j),
4584      2              qinvar2,qtotal2,qvector2,qside2,qout2,qlong2,
4585      3              qperp2,qtime2)
4586                 else if(mode.eq.4) then
4587                   trkj_pid = trk2_ge_pid(j)
4588                   Call qdiff(trk_px(i),trk_py(i),trk_pz(i),trk_E(i),
4589      1              trk2_px(j),trk2_py(j),trk2_pz(j),trk2_E(j),
4590      2              qinvar2,qtotal2,qvector2,qside2,qout2,qlong2,
4591      3              qperp2,qtime2)
4592                 end if
4593
4594 C-----------------------------------------------
4595 CCC   Fill and/or Update 1D two-body Histograms:
4596 C-----------------------------------------------
4597
4598                 if(switch_1d .gt. 0) then
4599
4600                   if(switch_1d .eq. 1) then
4601                     qdiff1 = sqrt(qinvar2)
4602                   else if(switch_1d .eq. 2) then
4603                     qdiff1 = sqrt(qtotal2)
4604                   else if(switch_1d .eq. 3) then
4605                     qdiff1 = sqrt(qvector2)
4606                   else
4607                     qdiff1 = sqrt(qvector2)
4608                   end if
4609
4610                   if(qdiff1 .le. qmid_1d) then
4611                     index1 = int((qdiff1/binsize_1d_fine)+0.99999)
4612                     if(index1 .eq. 0) index1 = 1
4613                   else if(qdiff1.gt.qmid_1d.and.qdiff1.le.qmax_1d) then
4614                     index1 = int(((qdiff1-qmid_1d)/binsize_1d_coarse)
4615      1                     + 0.99999)
4616                     if(index1.eq.0) index1 = 1
4617                     index1 = index1 + n_1d_fine
4618                   else
4619                     index1 = -86
4620                   end if
4621
4622                   if(index1.ge.1.and.index1.le.n_1d_total) then
4623                     if((trki_pid.eq.trkj_pid).and.(switch_type.eq.1
4624      1                  .or. switch_type.eq.3)) then
4625                       if(mode.eq.1) then
4626                         hist_like_1d(index1) = hist_like_1d(index1) + 1
4627                       else if(mode.eq.2) then
4628                         htmp_like_1d(index1) = htmp_like_1d(index1) - 1
4629                       else if(mode.eq.3) then
4630                         htmp_like_1d(index1) = htmp_like_1d(index1) + 1
4631                       else if(mode.eq.4) then
4632                         href_like_1d(index1) = href_like_1d(index1) + 1
4633                       end if
4634
4635                     else if((trki_pid.ne.trkj_pid).and.(switch_type.eq.2
4636      1                       .or. switch_type.eq.3)) then
4637                       if(mode.eq.1) then
4638                       hist_unlike_1d(index1) = hist_unlike_1d(index1)+1
4639                       else if(mode.eq.2) then
4640                       htmp_unlike_1d(index1) = htmp_unlike_1d(index1)-1
4641                       else if(mode.eq.3) then
4642                       htmp_unlike_1d(index1) = htmp_unlike_1d(index1)+1
4643                       else if(mode.eq.4) then
4644                       href_unlike_1d(index1) = href_unlike_1d(index1)+1
4645                       end if
4646
4647                     end if
4648                   end if
4649                 end if     ! End 1D Histogram Fill and/or Update.
4650
4651 C-----------------------------------------------
4652 CCC   Fill and/or Update 3D Two-Body Histograms:
4653 C-----------------------------------------------
4654
4655                 if(switch_3d .gt. 0) then
4656                   if(switch_3d .eq. 1) then
4657                     qdiff1 = sqrt(qside2)
4658                     qdiff2 = sqrt(qout2)
4659                     qdiff3 = sqrt(qlong2)
4660                   else if(switch_3d .eq. 2) then
4661                     qdiff1 = sqrt(qperp2)
4662                     qdiff2 = sqrt(qtime2)
4663                     qdiff3 = sqrt(qlong2)
4664                   else
4665                     qdiff1 = sqrt(qperp2)
4666                     qdiff2 = sqrt(qtime2)
4667                     qdiff3 = sqrt(qlong2)
4668                   end if
4669
4670                   if(qdiff1 .le. qmid_3d) then
4671                     findex1 = int((qdiff1/binsize_3d_fine)+0.99999)
4672                     if(findex1 .eq. 0) findex1 = 1
4673                     index1 = 1
4674                   else if(qdiff1.gt.qmid_3d.and.qdiff1.le.qmax_3d) then
4675                     index1 = int((qdiff1/binsize_3d_coarse)+0.99999)
4676                     if(index1.eq.1) index1 = 2
4677                     findex1 = 0
4678                   else
4679                     index1 = -86
4680                     findex1 = -86
4681                   end if
4682
4683                   if(qdiff2 .le. qmid_3d) then
4684                     findex2 = int((qdiff2/binsize_3d_fine)+0.99999)
4685                     if(findex2 .eq. 0) findex2 = 1
4686                     index2 = 1
4687                   else if(qdiff2.gt.qmid_3d.and.qdiff2.le.qmax_3d) then
4688                     index2 = int((qdiff2/binsize_3d_coarse)+0.99999)
4689                     if(index2.eq.1) index2 = 2
4690                     findex2 = 0
4691                   else
4692                     index2 = -86
4693                     findex2 = -86
4694                   end if
4695
4696                   if(qdiff3 .le. qmid_3d) then
4697                     findex3 = int((qdiff3/binsize_3d_fine)+0.99999)
4698                     if(findex3 .eq. 0) findex3 = 1
4699                     index3 = 1
4700                   else if(qdiff3.gt.qmid_3d.and.qdiff3.le.qmax_3d) then
4701                     index3 = int((qdiff3/binsize_3d_coarse)+0.99999)
4702                     if(index3.eq.1) index3 = 2
4703                     findex3 = 0
4704                   else
4705                     index3 = -86
4706                     findex3 = -86
4707                   end if
4708
4709                   if((index1.ge.1.and.index1.le.n_3d_coarse).and.
4710      1               (index2.ge.1.and.index2.le.n_3d_coarse).and.
4711      2               (index3.ge.1.and.index3.le.n_3d_coarse)) then
4712
4713                    if((index1+index2+index3).eq.3) then
4714
4715                     if(findex1.ge.1.and.findex1.le.n_3d_fine.and.
4716      1                 findex2.ge.1.and.findex2.le.n_3d_fine.and.
4717      2                 findex3.ge.1.and.findex3.le.n_3d_fine) then
4718
4719                      if((trki_pid.eq.trkj_pid).and.(switch_type.eq.1
4720      1                   .or. switch_type.eq.3)) then
4721
4722                       if(mode.eq.1) then
4723                        hist_like_3d_fine(findex1,findex2,findex3) =
4724      1                 hist_like_3d_fine(findex1,findex2,findex3) +1
4725                       else if(mode.eq.2) then
4726                        htmp_like_3d_fine(findex1,findex2,findex3) =
4727      1                 htmp_like_3d_fine(findex1,findex2,findex3) -1
4728                       else if(mode.eq.3) then
4729                        htmp_like_3d_fine(findex1,findex2,findex3) =
4730      1                 htmp_like_3d_fine(findex1,findex2,findex3) +1
4731                       else if(mode.eq.4) then
4732                        href_like_3d_fine(findex1,findex2,findex3) =
4733      1                 href_like_3d_fine(findex1,findex2,findex3) +1
4734                       end if
4735
4736                      else if((trki_pid.ne.trkj_pid).and.(switch_type
4737      1                    .eq.2 .or. switch_type.eq.3)) then
4738
4739                       if(mode.eq.1) then
4740                        hist_unlike_3d_fine(findex1,findex2,findex3) =
4741      1                 hist_unlike_3d_fine(findex1,findex2,findex3) +1
4742                       else if(mode.eq.2) then
4743                        htmp_unlike_3d_fine(findex1,findex2,findex3) =
4744      1                 htmp_unlike_3d_fine(findex1,findex2,findex3) -1
4745                       else if(mode.eq.3) then
4746                        htmp_unlike_3d_fine(findex1,findex2,findex3) =
4747      1                 htmp_unlike_3d_fine(findex1,findex2,findex3) +1
4748                       else if(mode.eq.4) then
4749                        href_unlike_3d_fine(findex1,findex2,findex3) =
4750      1                 href_unlike_3d_fine(findex1,findex2,findex3) +1
4751                       end if
4752
4753                      end if
4754                     end if
4755
4756                    else if((index1+index2+index3).gt.3) then
4757
4758                      if((trki_pid.eq.trkj_pid).and.(switch_type.eq.1
4759      1                   .or. switch_type.eq.3)) then
4760
4761                       if(mode.eq.1) then
4762                        hist_like_3d_coarse(index1,index2,index3) =
4763      1                 hist_like_3d_coarse(index1,index2,index3) +1
4764                       else if(mode.eq.2) then
4765                        htmp_like_3d_coarse(index1,index2,index3) =
4766      1                 htmp_like_3d_coarse(index1,index2,index3) -1
4767                       else if(mode.eq.3) then
4768                        htmp_like_3d_coarse(index1,index2,index3) =
4769      1                 htmp_like_3d_coarse(index1,index2,index3) +1
4770                       else if(mode.eq.4) then
4771                        href_like_3d_coarse(index1,index2,index3) =
4772      1                 href_like_3d_coarse(index1,index2,index3) +1
4773                       end if
4774
4775                      else if((trki_pid.ne.trkj_pid).and.(switch_type
4776      1                    .eq.2 .or. switch_type.eq.3)) then
4777
4778                       if(mode.eq.1) then
4779                        hist_unlike_3d_coarse(index1,index2,index3) =
4780      1                 hist_unlike_3d_coarse(index1,index2,index3) +1
4781                       else if(mode.eq.2) then
4782                        htmp_unlike_3d_coarse(index1,index2,index3) =
4783      1                 htmp_unlike_3d_coarse(index1,index2,index3) -1
4784                       else if(mode.eq.3) then
4785                        htmp_unlike_3d_coarse(index1,index2,index3) =
4786      1                 htmp_unlike_3d_coarse(index1,index2,index3) +1
4787                       else if(mode.eq.4) then
4788                        href_unlike_3d_coarse(index1,index2,index3) =
4789      1                 href_unlike_3d_coarse(index1,index2,index3) +1
4790                       end if
4791
4792                      end if
4793                     end if    ! End 3D Fine/Coarse Grid
4794                    end if
4795                   end if      ! End 3D Histogram Filling and/or Update
4796
4797                end if
4798                end do         ! End Secondary Track Loop
4799
4800             end if
4801             end do
4802             end do
4803             end do            ! End Neighboring Sector Loop
4804
4805          end if
4806       end do                  ! End Primary Track Loop
4807
4808       Return
4809       END
4810
4811 C-----------------------------------------------------------------------
4812
4813
4814       subroutine correlation_fit
4815       implicit none
4816
4817 CCC   This subroutine carries out the track momentum adjustment
4818 CCC   procedure in order to fit the requested model correlation
4819 CCC   function and the input one-body {pt,phi,eta} distributions.
4820
4821 CCC   The method used is similar to the Metropolis method.  Briefly:
4822 C
4823 C     1. The accepted tracks for each event in the 'event_text.in'
4824 C        input file are loaded into the 'trk' data structure table.
4825 C     2. The sector information, histograms, C2 and initial chi-square
4826 C        are computed.
4827 C     3. Each track momentum is randomly shifted within a specified
4828 C        range, one track at a time, the histograms are updated, and
4829 C        a new C2 and chi-square are computed.
4830 C     4. If the new track momentum is acceptable and if it results in a
4831 C        smaller value of chi-square, then this shifted momentum is
4832 C        retained, if not then the original momentum value is restored.
4833 C     5. This is done for all particles in the track table for the event.
4834 C     6. The entire process is repeated either until the maximum # of
4835 C        iterations is reached, or until the chi-square improvement with
4836 C        each iteration diminishes sufficiently.
4837 C     7. After completing the event loop, summary information is gathered
4838 C        and inclusive correlation functions and one-body distributions
4839 C        are calculated.
4840
4841       Include 'common_parameters.inc'
4842       Include 'common_mesh.inc'
4843       Include 'common_histograms.inc'
4844       Include 'common_correlations.inc'
4845       Include 'common_event_summary.inc'
4846
4847       Include 'common_track.inc'
4848       Include 'common_track2.inc'
4849       Include 'common_sec_track.inc'
4850       Include 'common_sec_track2.inc'
4851       Include 'common_particle.inc'
4852
4853 CCC   Local Variable Type Declarations:
4854
4855       integer*4 i,j,k,ievent,niter,ntracks_out,nev
4856       integer*4 ntracks_flagged,track_status,pid_index
4857       integer*4 px_sec_save,py_sec_save,pz_sec_save
4858
4859       real*4    px_save,py_save,pz_save,E_save
4860       real*4    pt_save,phi_save,eta_save,mass
4861       real*4    chisq_like_1d,chisq_unlike_1d
4862       real*4    chisq_like_3d_fine,chisq_unlike_3d_fine
4863       real*4    chisq_like_3d_coarse,chisq_unlike_3d_coarse
4864       real*4    chisq_hist1_1,chisq_hist1_2
4865       real*4    chisq_total,chisq_total_oldvalue,chisq_total_newvalue
4866       real*4    hbtpran
4867
4868 CCC   Initialize counters:
4869
4870       n_part_used_1_inc    = 0
4871       n_part_used_2_inc    = 0
4872       num_pairs_like_inc   = 0
4873       num_pairs_unlike_inc = 0
4874       event_line_counter   = 0
4875       file10_line_counter  = 0
4876
4877 CCC   Open event input, track selection flags and event output files:
4878
4879       If(ALICE .eq. 0) Then
4880       open(unit=2,status='old',access='sequential',
4881      1     file='event_text.in')
4882       open(unit=4,status='old',access='sequential',
4883      1     file='event_tracks.select')
4884       open(unit=10,status='unknown',access='sequential',
4885      1     file='event_hbt_text.out')
4886 CCC   Read/Write event header from/to I/O event text files
4887          Call read_data(7)
4888          Call read_data(8)
4889       End If
4890
4891 C-------------------------------------
4892 C  Begin Event Loop,
4893 C
4894       do ievent = 2, n_events + 1
4895 C-------------------------------------
4896
4897         If(ALICE .eq. 1) Then
4898            Call AliHbtp_SetActiveEventNumber(ievent-1)
4899 C           write(*,*) 'NEXT EVENT:', ievent
4900         End If
4901         Call read_data(7)
4902         if(n_part_tot_trk .gt. 0) then
4903
4904           write(6,98)
4905           Call tindex(1,0)  !  Fill initial track-sector info.
4906           Call stm_build(1,0,0)  ! Fill initial sector info.
4907           Call dist_range(1,ntracks_out,ntracks_flagged)
4908           num_pairs_like = (n_part_used_1_trk*(n_part_used_1_trk-1))/2
4909      1                   + (n_part_used_2_trk*(n_part_used_2_trk-1))/2
4910           num_pairs_unlike = n_part_used_1_trk*n_part_used_2_trk
4911           num_pairs_like_inc = num_pairs_like_inc + num_pairs_like
4912           num_pairs_unlike_inc = num_pairs_unlike_inc + num_pairs_unlike
4913           n_part_used_1_inc = n_part_used_1_inc + n_part_used_1_trk
4914           n_part_used_2_inc = n_part_used_2_inc + n_part_used_2_trk
4915
4916 C          write (*,*) 'num_pairs_like = ',num_pairs_like
4917 C          write (*,*) 'num_pairs_unlike = ',num_pairs_unlike
4918 C          write (*,*) 'num_pairs_like_inc = ',num_pairs_like_inc
4919 c          write (*,*) 'num_pairs_unlike_inc = ',num_pairs_unlike_inc
4920 c          write (*,*) 'n_part_used_1_inc = ',n_part_used_1_inc
4921 C          write (*,*) 'n_part_used_2_inc = ',n_part_used_2_inc
4922
4923           if(pid(1).gt.0) Call histog1(1,0,1,pid(1),0.,0.,0.)
4924           if(pid(2).gt.0) Call histog1(1,0,2,pid(2),0.,0.,0.)
4925           Call histog2(1,0,0,0,0,0.0,0.0,0.0,0.0)
4926           Call correl_fit(1)
4927           Call chisquare(1,chisq_like_1d,chisq_unlike_1d,
4928      1                   chisq_like_3d_fine,chisq_unlike_3d_fine,
4929      2                   chisq_like_3d_coarse,chisq_unlike_3d_coarse,
4930      3                   chisq_hist1_1,chisq_hist1_2)
4931           chisq_total = chisq_wt_like_1d    *chisq_like_1d
4932      1                + chisq_wt_unlike_1d  *chisq_unlike_1d
4933      2         + chisq_wt_like_3d_fine      *chisq_like_3d_fine
4934      3         + chisq_wt_unlike_3d_fine    *chisq_unlike_3d_fine
4935      4         + chisq_wt_like_3d_coarse    *chisq_like_3d_coarse
4936      5         + chisq_wt_unlike_3d_coarse  *chisq_unlike_3d_coarse
4937      6         + chisq_wt_hist1_1           *chisq_hist1_1
4938      7         + chisq_wt_hist1_2           *chisq_hist1_2
4939           chisq_total_oldvalue = chisq_total
4940           Call hist1_copy(1)
4941           Call hist2_copy(1)
4942
4943           niter = 0
4944 1000      Continue       ! Starting Point for Track Shift Iteration Loop:
4945           niter = niter + 1
4946
4947           if(niter.eq.1) then
4948              write(8,99)
4949              write(8,98)
4950              write(8,99)
4951           end if
4952 98        Format(5x,'**  START NEXT EVENT  **')
4953 99        Format(5x,'************************')
4954           write(8,100) ievent,niter,chisq_total
4955 100       Format(10x,'Event#+1,Iteration# and Chi-Sq = ',2I5,E11.4)
4956
4957           IF(maxit .eq. 0) GO TO 1001   ! Option to compute correlations
4958 C                                       ! for input events.
4959
4960 C-------------------------------------
4961 C  Begin Track Adjustment Loop:
4962
4963           do i = 1,n_part_tot_trk
4964 C-------------------------------------
4965
4966           if(trk_flag(i) .eq. 0) then
4967
4968 CCC   Save initial track parameters (those that might change):
4969
4970           px_save      = trk_px(i)
4971           py_save      = trk_py(i)
4972           pz_save      = trk_pz(i)
4973           E_save       = trk_E(i)
4974           pt_save      = trk_pt(i)
4975           phi_save     = trk_phi(i)
4976           eta_save     = trk_eta(i)
4977           px_sec_save  = trk_px_sec(i)
4978           py_sec_save  = trk_py_sec(i)
4979           pz_sec_save  = trk_pz_sec(i)
4980           old_sec_save = trk_sector(i)
4981
4982 CCC   Save the sector values that the track is initially located in:
4983
4984           old_sec_ntrk = stm_n_trk_sec(trk_sector(i))
4985           old_sec_flag = stm_flag(trk_sector(i))
4986           do k = 1,stm_n_trk_sec(trk_sector(i))
4987             old_sec_trkid(k) = stm_track_id(k,trk_sector(i))
4988           end do
4989
4990 CCC   Determine the particle ID type:
4991
4992           if(trk_ge_pid(i).eq.pid(1) .and. pid(1).gt.0) then
4993             pid_index = 1
4994           else if(trk_ge_pid(i).eq.pid(2).and.pid(2).gt.0) then
4995             pid_index = 2
4996           else
4997             pid_index = 1
4998           end if
4999
5000 CCC   Randomly shift track momentum vector and compute new kinematics:
5001
5002           trk_px(i) = trk_px(i) + deltap*(2.0*hbtpran(irand) - 1.0)
5003           trk_py(i) = trk_py(i) + deltap*(2.0*hbtpran(irand) - 1.0)
5004           trk_pz(i) = trk_pz(i) + deltap*(2.0*hbtpran(irand) - 1.0)
5005           mass = part_mass(trk_ge_pid(i))
5006           Call Hbtp_kin(trk_px(i),trk_py(i),trk_pz(i),trk_E(i),
5007      1                    trk_pt(i),trk_phi(i),trk_eta(i),mass,1)
5008           Call tindex(1,i)
5009           new_sec_save = trk_sector(i)
5010
5011 CCC   Determine if track has been shifted to a new sector, and if so,
5012 CCC   whether this overfills this new sector.  If all is well, then
5013 CCC   update histograms.  If not, then restore track parameters to their
5014 CCC   initial values prior to shifting.  Keep the status of track(i) in
5015 CCC   'track_status', where a value of 0 means the track is OK to use.
5016 CCC
5017 CCC   The Logical steps are the following:
5018 CCC
5019 C     IF(new track position is in same sector) THEN
5020 C       o Remove old track position from htmp1*, htmp* using old saved values.
5021 C       o Add new track position to htmp1*, htmp* using values in 'trk'
5022 C         (Sector information is unchanged)
5023 C     ELSE IF(new track position is in a different sector) THEN
5024 C       IF(# tracks in new sector is still OK, with the new track) THEN
5025 C         o Save values of new sector before trk was shifted into it.
5026 C         o Remove old trk position from htmp1*, htmp* using old saved values
5027 C         o Add new trk position to htmp1*, htmp* using values in trk
5028 C         o Update sector information in stm
5029 C       ELSE IF(# tracks in new sector becomes too many with new trk) THEN
5030 C         o Restore track parameters to pre-shifted values
5031 C         o Set track_status = 1, indicating the track could not be moved
5032 C       END IF
5033 C     END IF
5034
5035           track_status = 0
5036           if(old_sec_save .eq. new_sec_save) then
5037             Call histog1(2,i,pid_index,pid(pid_index),pt_save,
5038      1                   phi_save,eta_save)
5039             Call histog2(2,i,px_sec_save,py_sec_save,pz_sec_save,
5040      1           px_save,py_save,pz_save,E_save)
5041
5042             Call histog1(3,i,pid_index,pid(pid_index),0.,0.,0.)
5043             Call histog2(3,i,0,0,0,0.0,0.0,0.0,0.0)
5044
5045           else if(old_sec_save .ne. new_sec_save) then
5046
5047             if(stm_n_trk_sec(new_sec_save) .lt. max_trk_sec) then
5048               new_sec_ntrk = stm_n_trk_sec(new_sec_save)
5049               new_sec_flag = stm_flag(new_sec_save)
5050               if(new_sec_ntrk .gt. 0) then
5051                 do k = 1,new_sec_ntrk
5052                   new_sec_trkid(k) = stm_track_id(k,new_sec_save)
5053                 end do
5054               end if
5055
5056               Call histog1(2,i,pid_index,pid(pid_index),pt_save,
5057      1                   phi_save,eta_save)
5058               Call histog2(2,i,px_sec_save,py_sec_save,pz_sec_save,
5059      1           px_save,py_save,pz_save,E_save)
5060
5061               Call histog1(3,i,pid_index,pid(pid_index),
5062      1           0.,0.,0.)
5063               Call histog2(3,i,0,0,0,0.0,0.0,0.0,0.0)
5064
5065               Call stm_build(1,i,old_sec_save)
5066
5067             else if(stm_n_trk_sec(new_sec_save) .ge. max_trk_sec) then
5068
5069               track_status = 1
5070               trk_px(i)      = px_save
5071               trk_py(i)      = py_save
5072               trk_pz(i)      = pz_save
5073               trk_E(i)       = E_save
5074               trk_pt(i)      = pt_save
5075               trk_phi(i)     = phi_save
5076               trk_eta(i)     = eta_save
5077               trk_px_sec(i)  = px_sec_save
5078               trk_py_sec(i)  = py_sec_save
5079               trk_pz_sec(i)  = pz_sec_save
5080               trk_sector(i)  = old_sec_save
5081
5082             end if
5083           end if        ! End Histogram and Sector Update
5084
5085 CCC   If the track was succesfully shifted then compute C2 and determine
5086 C     if the chi-square decreases (improves) or increases.  If it improves,
5087 C     then store the new chi-square value and keep the 1- and 2-body
5088 C     histograms in hist1* and hist*, repsectively.  If chi-square
5089 C     increases (worsens), then restore the track parameters to the
5090 C     pre-shifted values, restore the histograms and if a new sector was
5091 C     involved, then restore both the old and new sector values.
5092 C
5093 C     The Logical steps are the following:
5094 C
5095 C     IF(new track position is OK, (i.e. track_status = 0)) Then
5096 C       o Compute C2 using htmp*
5097 C       o Compute chi-square and save
5098 C       IF(chi-square improves) Then
5099 C         o Replace previous (best) chi-square with new value
5100 C         o Update histograms, i.e. copy htmp1* -> hist1* and
5101 C                                   copy htmp*  -> hist*
5102 C       ELSE IF(chi-square increases) Then
5103 C         o Restore track parameters
5104 C         o Restore histograms, i.e. copy hist1* -> htmp1* and
5105 C                                    copy hist*  -> htmp*
5106 C         IF(new sector was used) Then
5107 C           o Restore old sector values to pre-shifted values
5108 C           o Restore new sector values to pre-shifted values
5109 C         END IF
5110 C       END IF
5111 C     END IF
5112
5113           If(track_status .eq.0) Then
5114             Call correl_fit(2)
5115             Call chisquare(2,chisq_like_1d,chisq_unlike_1d,
5116      1                     chisq_like_3d_fine,chisq_unlike_3d_fine,
5117      2                     chisq_like_3d_coarse,chisq_unlike_3d_coarse,
5118      3                     chisq_hist1_1,chisq_hist1_2)
5119             chisq_total_newvalue =
5120      1         chisq_wt_like_1d           *chisq_like_1d
5121      2       + chisq_wt_unlike_1d         *chisq_unlike_1d
5122      3       + chisq_wt_like_3d_fine      *chisq_like_3d_fine
5123      4       + chisq_wt_unlike_3d_fine    *chisq_unlike_3d_fine
5124      5       + chisq_wt_like_3d_coarse    *chisq_like_3d_coarse
5125      6       + chisq_wt_unlike_3d_coarse  *chisq_unlike_3d_coarse
5126      7       + chisq_wt_hist1_1           *chisq_hist1_1
5127      8       + chisq_wt_hist1_2           *chisq_hist1_2
5128
5129             if(chisq_total_newvalue .lt. chisq_total_oldvalue) then
5130               chisq_total_oldvalue = chisq_total_newvalue
5131               Call hist1_copy(2)
5132               Call hist2_copy(2)
5133             else if(chisq_total_newvalue.ge.chisq_total_oldvalue) then
5134               trk_px(i)      = px_save
5135               trk_py(i)      = py_save
5136               trk_pz(i)      = pz_save
5137               trk_E(i)       = E_save
5138               trk_pt(i)      = pt_save
5139               trk_phi(i)     = phi_save
5140               trk_eta(i)     = eta_save
5141               trk_px_sec(i)  = px_sec_save
5142               trk_py_sec(i)  = py_sec_save
5143               trk_pz_sec(i)  = pz_sec_save
5144               trk_sector(i)  = old_sec_save
5145               Call hist1_copy(1)
5146               Call hist2_copy(1)
5147
5148               If(old_sec_save .ne. new_sec_save) then
5149
5150                 stm_n_trk_sec(old_sec_save) = old_sec_ntrk
5151                 stm_flag(old_sec_save)      = old_sec_flag
5152                 do k = 1,max_trk_sec
5153                   stm_track_id(k,old_sec_save) = 0
5154                 end do
5155                 do k = 1,old_sec_ntrk
5156                   stm_track_id(k,old_sec_save) = old_sec_trkid(k)
5157                 end do
5158
5159                 stm_n_trk_sec(new_sec_save) = new_sec_ntrk
5160                 stm_flag(new_sec_save)      = new_sec_flag
5161                 do k = 1,max_trk_sec
5162                   stm_track_id(k,new_sec_save) = 0
5163                 end do
5164                 do k = 1,new_sec_ntrk
5165                   stm_track_id(k,new_sec_save) = new_sec_trkid(k)
5166                 end do
5167
5168               end if
5169             end if
5170           end if         ! End Chi-Square Determination
5171         end if           ! End valid tracks option
5172         end do           ! End Track Shift Loop
5173
5174 CCC   Check chi-square for this iteration --
5175 C        Best, current chi-square value is in 'chisq_total_oldvalue'
5176 C        Chi-square value at the beginning of the iteration loop is in
5177 C        'chisq_total'.
5178
5179         If(abs(200.0*(chisq_total_oldvalue - chisq_total)/
5180      1    (chisq_total_oldvalue + chisq_total)) .lt. delchi) then
5181           write(8,101)
5182 101       Format(/5x,'Chi-Sq reduced .lt. delchi % on last iteration',
5183      1           ' - Stop Search')
5184           go to 1001
5185         End If
5186         If (niter .gt. maxit) Then
5187           write(8,102)
5188 102       Format(/5x,'Max # Search Iterations Reached - Abort track ',
5189      1           'Adj. process')
5190           go to 1001
5191         End If
5192         chisq_total = chisq_total_oldvalue
5193         go to 1000
5194
5195 1001    Continue
5196
5197 CCC   Finished Track Adjustment Iteration Loop for event # 'ievent'
5198
5199         if((ievent - 1) .le. max_events) then
5200           Call dist_range(1,ntracks_out,ntracks_flagged)
5201           num_iter(ievent-1) = float(niter)
5202           n_part_used_1_store(ievent-1) = float(n_part_used_1_trk)
5203           n_part_used_2_store(ievent-1) = float(n_part_used_2_trk)
5204           n_part_tot_store(ievent-1) = float(n_part_tot_trk)
5205           frac_trks_out(ievent-1)=float(ntracks_out)/
5206      1                            float(n_part_tot_trk)
5207           frac_trks_flag(ievent-1) =
5208      1         float(ntracks_flagged)/float(n_part_tot_trk)
5209         end if
5210
5211         Call correl_fit(1)
5212         Call chisquare(1,chisq_like_1d,chisq_unlike_1d,
5213      1                 chisq_like_3d_fine,chisq_unlike_3d_fine,
5214      2                 chisq_like_3d_coarse,chisq_unlike_3d_coarse,
5215      3                 chisq_hist1_1,chisq_hist1_2)
5216         chisq_total = chisq_wt_like_1d    *chisq_like_1d
5217      1              + chisq_wt_unlike_1d  *chisq_unlike_1d
5218      2       + chisq_wt_like_3d_fine      *chisq_like_3d_fine
5219      3       + chisq_wt_unlike_3d_fine    *chisq_unlike_3d_fine
5220      4       + chisq_wt_like_3d_coarse    *chisq_like_3d_coarse
5221      5       + chisq_wt_unlike_3d_coarse  *chisq_unlike_3d_coarse
5222      6       + chisq_wt_hist1_1           *chisq_hist1_1
5223      7       + chisq_wt_hist1_2           *chisq_hist1_2
5224
5225         if((ievent - 1) .le. max_events) then
5226           chisq_like_1d_store(ievent-1)          = chisq_like_1d
5227           chisq_unlike_1d_store(ievent-1)        = chisq_unlike_1d
5228           chisq_like_3d_fine_store(ievent-1)     = chisq_like_3d_fine
5229           chisq_unlike_3d_fine_store(ievent-1)   = chisq_unlike_3d_fine
5230           chisq_like_3d_coarse_store(ievent-1)   = chisq_like_3d_coarse
5231           chisq_unlike_3d_coarse_store(ievent-1) =chisq_unlike_3d_coarse
5232           chisq_hist1_1_store(ievent-1)          = chisq_hist1_1
5233           chisq_hist1_2_store(ievent-1)          = chisq_hist1_2
5234           chisq_total_store(ievent-1)            = chisq_total
5235
5236 CCC   Count # sectors with stm().flag = 1, indicating that too many
5237 C     tracks were attempted to be loaded into that sector.
5238
5239           num_sec_flagged_store(ievent-1) = 0.0
5240           do k = 1,n_sectors
5241             if(stm_flag(k) .eq. 1) then
5242               num_sec_flagged_store(ievent-1) =
5243      1             num_sec_flagged_store(ievent-1) + 1.0
5244             end if
5245           end do
5246         end if
5247
5248         Call hist1_incl_sum
5249         Call hist2_incl_sum
5250         if(print_full .eq. 1) Call write_data(5,ievent-1)
5251
5252       end if    !  End event-with-tracks processing.
5253         Call read_data(8)
5254
5255 C-------------------------------
5256       end do    ! End Event Loop
5257 C-------------------------------
5258
5259 CCC   Compute Correlation Functions for the Inclusive Histograms
5260
5261       Call correl_fit(3)
5262
5263 CCC   Compute Mean and Std. dev of event monitor and summary quantities:
5264
5265       if(n_events .le. max_events) then
5266          nev = n_events
5267       else
5268          nev = max_events
5269       end if
5270
5271       Call mean_rms(num_iter,nev,nev,niter_mean,niter_rms)
5272       Call mean_rms(n_part_used_1_store,nev,nev,npart1_mean,npart1_rms)
5273       Call mean_rms(n_part_used_2_store,nev,nev,npart2_mean,npart2_rms)
5274       Call mean_rms(n_part_tot_store,nev,nev,npart_tot_mean,
5275      1              npart_tot_rms)
5276       Call mean_rms(num_sec_flagged_store,nev,nev,
5277      1              nsec_flag_mean,nsec_flag_rms)
5278       Call mean_rms(frac_trks_out,nev,nev,
5279      1              frac_trks_out_mean,frac_trks_out_rms)
5280       Call mean_rms(frac_trks_flag,nev,nev,
5281      1              frac_trks_flag_mean,frac_trks_flag_rms)
5282       Call mean_rms(chisq_like_1d_store,nev,nev,
5283      1              chi_l1d_mean,chi_l1d_rms)
5284       Call mean_rms(chisq_unlike_1d_store,nev,nev,
5285      1              chi_u1d_mean,chi_u1d_rms)
5286       Call mean_rms(chisq_like_3d_fine_store,nev,nev,
5287      1              chi_l3f_mean,chi_l3f_rms)
5288       Call mean_rms(chisq_unlike_3d_fine_store,nev,nev,
5289      1              chi_u3f_mean,chi_u3f_rms)
5290       Call mean_rms(chisq_like_3d_coarse_store,nev,nev,
5291      1              chi_l3c_mean,chi_l3c_rms)
5292       Call mean_rms(chisq_unlike_3d_coarse_store,nev,nev,
5293      1              chi_u3c_mean,chi_u3c_rms)
5294       Call mean_rms(chisq_hist1_1_store,nev,nev,
5295      1              chi_1_1_mean, chi_1_1_rms)
5296       Call mean_rms(chisq_hist1_2_store,nev,nev,
5297      1              chi_1_2_mean, chi_1_2_rms)
5298       Call mean_rms(chisq_total_store,nev,nev,
5299      1              chi_tot_mean, chi_tot_rms)
5300
5301       If(ALICE .eq. 0) Then
5302       Close(unit=2)
5303       Close(unit=4)
5304       Close(unit=10)
5305       End If
5306
5307       Return
5308       END
5309
5310 C------------------------------------------------------------------------
5311
5312
5313       subroutine hist1_copy(mode)
5314       implicit none
5315
5316 CCC   Copy 1-body histograms if:
5317 CCC
5318 CCC   mode = 1, then copy hist1* -> htmp1*
5319 CCC   mode = 2, then copy htmp1* -> hist1*
5320
5321       Include 'common_parameters.inc'
5322       Include 'common_mesh.inc'
5323       Include 'common_histograms.inc'
5324
5325 CCC   Local Variable Type Declarations:
5326
5327       integer*4  mode, i
5328
5329 C---------------------------
5330       If(mode .eq. 1) Then       !  Copy hist1* -> htmp1*
5331 C---------------------------
5332
5333         if(pid(1) .gt. 0) then
5334           do i = 1,n_pt_bins
5335             htmp1_pt_1(i)  = hist1_pt_1(i)
5336           end do
5337           do i = 1,n_phi_bins
5338             htmp1_phi_1(i) = hist1_phi_1(i)
5339           end do
5340           do i = 1,n_eta_bins
5341             htmp1_eta_1(i) = hist1_eta_1(i)
5342           end do
5343         end if
5344
5345         if(pid(2) .gt. 0) then
5346           do i = 1,n_pt_bins
5347             htmp1_pt_2(i)  = hist1_pt_2(i)
5348           end do
5349           do i = 1,n_phi_bins
5350             htmp1_phi_2(i) = hist1_phi_2(i)
5351           end do
5352           do i = 1,n_eta_bins
5353             htmp1_eta_2(i) = hist1_eta_2(i)
5354           end do
5355         end if
5356
5357 C--------------------------------
5358       Else If (mode .eq. 2) Then   ! Copy htmp1* -> hist1*
5359 C--------------------------------
5360
5361         if(pid(1) .gt. 0) then
5362           do i = 1,n_pt_bins
5363             hist1_pt_1(i)  = htmp1_pt_1(i)
5364           end do
5365           do i = 1,n_phi_bins
5366             hist1_phi_1(i) = htmp1_phi_1(i)
5367           end do
5368           do i = 1,n_eta_bins
5369             hist1_eta_1(i) = htmp1_eta_1(i)
5370           end do
5371         end if
5372
5373         if(pid(2) .gt. 0) then
5374           do i = 1,n_pt_bins
5375             hist1_pt_2(i)  = htmp1_pt_2(i)
5376           end do
5377           do i = 1,n_phi_bins
5378             hist1_phi_2(i) = htmp1_phi_2(i)
5379           end do
5380           do i = 1,n_eta_bins
5381             hist1_eta_2(i) = htmp1_eta_2(i)
5382           end do
5383         end if
5384
5385 C------------
5386       End If
5387 C------------
5388
5389       Return
5390       END
5391
5392 C----------------------------------------------------------------------
5393
5394       subroutine hist2_copy(mode)
5395       implicit none
5396
5397 CCC   Copy 2-body histograms if:
5398 CCC
5399 CCC   mode = 1, then copy hist* -> htmp*
5400 CCC   mode = 2, then copy htmp* -> hist*
5401
5402       Include 'common_parameters.inc'
5403       Include 'common_mesh.inc'
5404       Include 'common_histograms.inc'
5405
5406 CCC   Local Variable Type Declarations:
5407
5408       integer*4  mode, i,j,k
5409
5410 C---------------------------
5411       If (mode .eq. 1) Then    !   Copy hist* -> htmp*
5412 C---------------------------
5413
5414         if(switch_1d.gt.0 .and. n_1d_total.gt.0) then
5415           if(switch_type.eq.1 .or. switch_type.eq.3) then
5416             do i = 1,n_1d_total
5417               htmp_like_1d(i) = hist_like_1d(i)
5418             end do
5419           end if
5420           if(switch_type.eq.2 .or. switch_type.eq.3) then
5421             do i = 1,n_1d_total
5422               htmp_unlike_1d(i) = hist_unlike_1d(i)
5423             end do
5424           end if
5425         end if     ! End 1D histogram copy
5426
5427         if(switch_3d.gt.0) then
5428           if(switch_type.eq.1 .or. switch_type.eq.3) then
5429
5430             if(n_3d_fine .gt. 0) then
5431               do i = 1,n_3d_fine
5432               do j = 1,n_3d_fine
5433               do k = 1,n_3d_fine
5434                 htmp_like_3d_fine(i,j,k) = hist_like_3d_fine(i,j,k)
5435               end do
5436               end do
5437               end do
5438             end if
5439
5440             if(n_3d_coarse .gt. 0) then
5441               do i = 1,n_3d_coarse
5442               do j = 1,n_3d_coarse
5443               do k = 1,n_3d_coarse
5444                 htmp_like_3d_coarse(i,j,k) = hist_like_3d_coarse(i,j,k)
5445               end do
5446               end do
5447               end do
5448             end if
5449
5450           end if
5451
5452           if(switch_type.eq.2 .or. switch_type.eq.3) then
5453
5454             if(n_3d_fine .gt. 0) then
5455               do i = 1,n_3d_fine
5456               do j = 1,n_3d_fine
5457               do k = 1,n_3d_fine
5458                 htmp_unlike_3d_fine(i,j,k) = hist_unlike_3d_fine(i,j,k)
5459               end do
5460               end do
5461               end do
5462             end if
5463
5464             if(n_3d_coarse .gt. 0) then
5465               do i = 1,n_3d_coarse
5466               do j = 1,n_3d_coarse
5467               do k = 1,n_3d_coarse
5468                htmp_unlike_3d_coarse(i,j,k)=hist_unlike_3d_coarse(i,j,k)
5469               end do
5470               end do
5471               end do
5472             end if
5473
5474           end if
5475         end if     ! End 3D histogram copy
5476
5477 C--------------------------------
5478       Else If (mode .eq. 2) Then   !   Copy htmp* -> hist*
5479 C--------------------------------
5480
5481         if(switch_1d.gt.0 .and. n_1d_total.gt.0) then
5482           if(switch_type.eq.1 .or. switch_type.eq.3) then
5483             do i = 1,n_1d_total
5484               hist_like_1d(i) = htmp_like_1d(i)
5485             end do
5486           end if
5487           if(switch_type.eq.2 .or. switch_type.eq.3) then
5488             do i = 1,n_1d_total
5489               hist_unlike_1d(i) = htmp_unlike_1d(i)
5490             end do
5491           end if
5492         end if     ! End 1D histogram copy
5493
5494         if(switch_3d.gt.0) then
5495           if(switch_type.eq.1 .or. switch_type.eq.3) then
5496
5497             if(n_3d_fine .gt. 0) then
5498               do i = 1,n_3d_fine
5499               do j = 1,n_3d_fine
5500               do k = 1,n_3d_fine
5501                 hist_like_3d_fine(i,j,k) = htmp_like_3d_fine(i,j,k)
5502               end do
5503               end do
5504               end do
5505             end if
5506
5507             if(n_3d_coarse .gt. 0) then
5508               do i = 1,n_3d_coarse
5509               do j = 1,n_3d_coarse
5510               do k = 1,n_3d_coarse
5511                 hist_like_3d_coarse(i,j,k) = htmp_like_3d_coarse(i,j,k)
5512               end do
5513               end do
5514               end do
5515             end if
5516
5517           end if
5518
5519           if(switch_type.eq.2 .or. switch_type.eq.3) then
5520
5521             if(n_3d_fine .gt. 0) then
5522               do i = 1,n_3d_fine
5523               do j = 1,n_3d_fine
5524               do k = 1,n_3d_fine
5525                 hist_unlike_3d_fine(i,j,k) = htmp_unlike_3d_fine(i,j,k)
5526               end do
5527               end do
5528               end do
5529             end if
5530
5531             if(n_3d_coarse .gt. 0) then
5532               do i = 1,n_3d_coarse
5533               do j = 1,n_3d_coarse
5534               do k = 1,n_3d_coarse
5535                hist_unlike_3d_coarse(i,j,k)=htmp_unlike_3d_coarse(i,j,k)
5536               end do
5537               end do
5538               end do
5539             end if
5540
5541           end if
5542         end if     ! End 3D histogram copy
5543
5544 C-------------
5545       End If       ! End mode selection options
5546 C-------------
5547
5548       Return
5549       END
5550
5551 C-----------------------------------------------------------------------
5552
5553
5554       subroutine hist1_incl_sum
5555       implicit none
5556
5557 CCC   Sum 1-body histograms for each event into inclusive totals, where
5558 CCC   hinc1* = SUM[hist1*]
5559
5560       Include 'common_parameters.inc'
5561       Include 'common_mesh.inc'
5562       Include 'common_histograms.inc'
5563
5564 CCC   Local Variable Type Declarations:
5565
5566       integer*4 i
5567
5568       if(pid(1) .gt. 0) then
5569         do i = 1,n_pt_bins
5570           hinc1_pt_1(i) = hinc1_pt_1(i) + hist1_pt_1(i)
5571         end do
5572         do i = 1,n_phi_bins
5573           hinc1_phi_1(i) = hinc1_phi_1(i) + hist1_phi_1(i)
5574         end do
5575         do i = 1,n_eta_bins
5576           hinc1_eta_1(i) = hinc1_eta_1(i) + hist1_eta_1(i)
5577         end do
5578       end if
5579
5580       if(pid(2) .gt. 0) then
5581         do i = 1,n_pt_bins
5582           hinc1_pt_2(i) = hinc1_pt_2(i) + hist1_pt_2(i)
5583         end do
5584         do i = 1,n_phi_bins
5585           hinc1_phi_2(i) = hinc1_phi_2(i) + hist1_phi_2(i)
5586         end do
5587         do i = 1,n_eta_bins
5588           hinc1_eta_2(i) = hinc1_eta_2(i) + hist1_eta_2(i)
5589         end do
5590       end if
5591
5592       Return
5593       END
5594
5595
5596 C------------------------------------------------------------------------
5597
5598
5599       subroutine hist2_incl_sum
5600       implicit none
5601
5602 CCC   Sum 2-body histograms for each event into inclusive totals, where
5603 CCC   hinc* = SUM[hist*]
5604
5605       Include 'common_parameters.inc'
5606       Include 'common_mesh.inc'
5607       Include 'common_histograms.inc'
5608
5609 CCC   Local Variable Type Declarations:
5610
5611       integer*4 i,j,k
5612
5613       if(switch_1d.gt.0 .and. n_1d_total.gt.0) then
5614         if(switch_type.eq.1 .or. switch_type.eq.3) then
5615           do i = 1,n_1d_total
5616             hinc_like_1d(i) = hinc_like_1d(i) + hist_like_1d(i)
5617           end do
5618         end if
5619         if(switch_type.eq.2 .or. switch_type.eq.3) then
5620           do i = 1,n_1d_total
5621             hinc_unlike_1d(i) = hinc_unlike_1d(i) + hist_unlike_1d(i)
5622           end do
5623         end if
5624       end if      ! End 1D Inclusive Histogram Sum
5625
5626       if(switch_3d.gt.0) then
5627         if(switch_type.eq.1 .or. switch_type.eq.3) then
5628
5629           if(n_3d_fine .gt. 0) then
5630             do i = 1,n_3d_fine
5631             do j = 1,n_3d_fine
5632             do k = 1,n_3d_fine
5633               hinc_like_3d_fine(i,j,k) = hinc_like_3d_fine(i,j,k)
5634      1                                 + hist_like_3d_fine(i,j,k)
5635             end do
5636             end do
5637             end do
5638           end if
5639
5640           if(n_3d_coarse .gt. 0) then
5641             do i = 1,n_3d_coarse
5642             do j = 1,n_3d_coarse
5643             do k = 1,n_3d_coarse
5644               hinc_like_3d_coarse(i,j,k) = hinc_like_3d_coarse(i,j,k)
5645      1                                   + hist_like_3d_coarse(i,j,k)
5646             end do
5647             end do
5648             end do
5649           end if
5650
5651         end if
5652
5653         if(switch_type.eq.2 .or. switch_type.eq.3) then
5654
5655           if(n_3d_fine .gt. 0) then
5656             do i = 1,n_3d_fine
5657             do j = 1,n_3d_fine
5658             do k = 1,n_3d_fine
5659               hinc_unlike_3d_fine(i,j,k) = hinc_unlike_3d_fine(i,j,k)
5660      1                                   + hist_unlike_3d_fine(i,j,k)
5661             end do
5662             end do
5663             end do
5664           end if
5665
5666           if(n_3d_coarse .gt. 0) then
5667             do i = 1,n_3d_coarse
5668             do j = 1,n_3d_coarse
5669             do k = 1,n_3d_coarse
5670              hinc_unlike_3d_coarse(i,j,k) = hinc_unlike_3d_coarse(i,j,k)
5671      1                                    + hist_unlike_3d_coarse(i,j,k)
5672             end do
5673             end do
5674             end do
5675           end if
5676
5677         end if
5678       end if      ! End 3D Inclusive Histogram Sum
5679
5680       Return
5681       END
5682
5683 C--------------------------------------------------------------------------
5684
5685
5686       subroutine correl_fit(mode)
5687       implicit none
5688
5689 CCC   This subroutine calculates the 2-body correlation function with
5690 CCC   errors for the cases:
5691 CCC
5692 CCC      (1) 1D and/or 3D fine and coarse grid distributions
5693 CCC      (2) like pairs and/or unlike pairs
5694 CCC
5695 CCC   Uses the signal and reference histograms.  The input parameter
5696 CCC   'mode' selects which histograms to use.
5697 CCC
5698 CCC      Mode = 1, use hist*
5699 CCC      Mode = 2, use htmp*
5700 CCC      Mode = 3, use hinc*
5701
5702       Include 'common_parameters.inc'
5703       Include 'common_mesh.inc'
5704       Include 'common_histograms.inc'
5705       Include 'common_correlations.inc'
5706
5707 CCC   Local Variable Type Declarations:
5708
5709       integer*4 mode,i,j,k
5710
5711 CCC   Initialize correlation functions and error arrays to zero:
5712
5713       do i = 1,max_c2_1d
5714          c2fit_like_1d(i)   = 0.0
5715          c2fit_unlike_1d(i) = 0.0
5716          c2err_like_1d(i)   = 0.0
5717          c2err_unlike_1d(i) = 0.0
5718       end do
5719
5720       do i = 1,max_c2_3d
5721       do j = 1,max_c2_3d
5722       do k = 1,max_c2_3d
5723          c2fit_like_3d_fine(i,j,k)     = 0.0
5724          c2fit_unlike_3d_fine(i,j,k)   = 0.0
5725          c2fit_like_3d_coarse(i,j,k)   = 0.0
5726          c2fit_unlike_3d_coarse(i,j,k) = 0.0
5727          c2err_like_3d_fine(i,j,k)     = 0.0
5728          c2err_unlike_3d_fine(i,j,k)   = 0.0
5729          c2err_like_3d_coarse(i,j,k)   = 0.0
5730          c2err_unlike_3d_coarse(i,j,k) = 0.0
5731       end do
5732       end do
5733       end do
5734
5735 CCC   Compute 1D Correlation Functions and Errors:
5736
5737       if(switch_1d .gt. 0) then
5738         if(switch_type.eq.1 .or. switch_type.eq.3) then
5739
5740           if(mode .eq. 1) then
5741             Call c2_1d(hist_like_1d,href_like_1d,c2fit_like_1d,
5742      1           c2err_like_1d,max_h_1d,max_c2_1d,n_1d_total,
5743      2           num_pairs_like,num_pairs_like_ref)
5744           else if (mode .eq. 2) then
5745             Call c2_1d(htmp_like_1d,href_like_1d,c2fit_like_1d,
5746      1           c2err_like_1d,max_h_1d,max_c2_1d,n_1d_total,
5747      2           num_pairs_like,num_pairs_like_ref)
5748           else if (mode .eq. 3) then
5749             Call c2_1d(hinc_like_1d,href_like_1d,c2fit_like_1d,
5750      1           c2err_like_1d,max_h_1d,max_c2_1d,n_1d_total,
5751      2           num_pairs_like_inc,num_pairs_like_ref)
5752           end if
5753
5754         end if
5755
5756         if(switch_type.eq.2 .or. switch_type.eq.3) then
5757
5758           if(mode .eq. 1) then
5759             Call c2_1d(hist_unlike_1d,href_unlike_1d,c2fit_unlike_1d,
5760      1           c2err_unlike_1d,max_h_1d,max_c2_1d,n_1d_total,
5761      2           num_pairs_unlike,num_pairs_unlike_ref)
5762           else if (mode .eq. 2) then
5763             Call c2_1d(htmp_unlike_1d,href_unlike_1d,c2fit_unlike_1d,
5764      1           c2err_unlike_1d,max_h_1d,max_c2_1d,n_1d_total,
5765      2           num_pairs_unlike,num_pairs_unlike_ref)
5766           else if (mode .eq. 3) then
5767             Call c2_1d(hinc_unlike_1d,href_unlike_1d,c2fit_unlike_1d,
5768      1           c2err_unlike_1d,max_h_1d,max_c2_1d,n_1d_total,
5769      2           num_pairs_unlike_inc,num_pairs_unlike_ref)
5770           end if
5771         end if
5772       end if        ! End 1D correlations
5773
5774 CCC   Compute 3D Correlation Functions and Errors:
5775
5776       if(switch_3d .gt. 0) then
5777         if(switch_type.eq.1 .or. switch_type.eq.3) then
5778
5779           if(mode .eq. 1) then
5780             Call c2_3d(hist_like_3d_fine,href_like_3d_fine,
5781      1           c2fit_like_3d_fine,c2err_like_3d_fine,
5782      2           max_h_3d,max_c2_3d,n_3d_fine,
5783      3           num_pairs_like,num_pairs_like_ref)
5784             Call c2_3d(hist_like_3d_coarse,href_like_3d_coarse,
5785      1           c2fit_like_3d_coarse,c2err_like_3d_coarse,
5786      2           max_h_3d,max_c2_3d,n_3d_coarse,
5787      3           num_pairs_like,num_pairs_like_ref)
5788           else if(mode .eq. 2) then
5789             Call c2_3d(htmp_like_3d_fine,href_like_3d_fine,
5790      1           c2fit_like_3d_fine,c2err_like_3d_fine,
5791      2           max_h_3d,max_c2_3d,n_3d_fine,
5792      3           num_pairs_like,num_pairs_like_ref)
5793             Call c2_3d(htmp_like_3d_coarse,href_like_3d_coarse,
5794      1           c2fit_like_3d_coarse,c2err_like_3d_coarse,
5795      2           max_h_3d,max_c2_3d,n_3d_coarse,
5796      3           num_pairs_like,num_pairs_like_ref)
5797           else if(mode .eq. 3) then
5798             Call c2_3d(hinc_like_3d_fine,href_like_3d_fine,
5799      1           c2fit_like_3d_fine,c2err_like_3d_fine,
5800      2           max_h_3d,max_c2_3d,n_3d_fine,
5801      3           num_pairs_like_inc,num_pairs_like_ref)
5802             Call c2_3d(hinc_like_3d_coarse,href_like_3d_coarse,
5803      1           c2fit_like_3d_coarse,c2err_like_3d_coarse,
5804      2           max_h_3d,max_c2_3d,n_3d_coarse,
5805      3           num_pairs_like_inc,num_pairs_like_ref)
5806           end if
5807
5808         end if
5809
5810         if(switch_type.eq.2 .or. switch_type.eq.3) then
5811
5812           if(mode .eq. 1) then
5813             Call c2_3d(hist_unlike_3d_fine,href_unlike_3d_fine,
5814      1           c2fit_unlike_3d_fine,c2err_unlike_3d_fine,
5815      2           max_h_3d,max_c2_3d,n_3d_fine,
5816      3           num_pairs_unlike,num_pairs_unlike_ref)
5817             Call c2_3d(hist_unlike_3d_coarse,href_unlike_3d_coarse,
5818      1           c2fit_unlike_3d_coarse,c2err_unlike_3d_coarse,
5819      2           max_h_3d,max_c2_3d,n_3d_coarse,
5820      3           num_pairs_unlike,num_pairs_unlike_ref)
5821           else if(mode .eq. 2) then
5822             Call c2_3d(htmp_unlike_3d_fine,href_unlike_3d_fine,
5823      1           c2fit_unlike_3d_fine,c2err_unlike_3d_fine,
5824      2           max_h_3d,max_c2_3d,n_3d_fine,
5825      3           num_pairs_unlike,num_pairs_unlike_ref)
5826             Call c2_3d(htmp_unlike_3d_coarse,href_unlike_3d_coarse,
5827      1           c2fit_unlike_3d_coarse,c2err_unlike_3d_coarse,
5828      2           max_h_3d,max_c2_3d,n_3d_coarse,
5829      3           num_pairs_unlike,num_pairs_unlike_ref)
5830           else if(mode .eq. 3) then
5831             Call c2_3d(hinc_unlike_3d_fine,href_unlike_3d_fine,
5832      1           c2fit_unlike_3d_fine,c2err_unlike_3d_fine,
5833      2           max_h_3d,max_c2_3d,n_3d_fine,
5834      3           num_pairs_unlike_inc,num_pairs_unlike_ref)
5835             Call c2_3d(hinc_unlike_3d_coarse,href_unlike_3d_coarse,
5836      1           c2fit_unlike_3d_coarse,c2err_unlike_3d_coarse,
5837      2           max_h_3d,max_c2_3d,n_3d_coarse,
5838      3           num_pairs_unlike_inc,num_pairs_unlike_ref)
5839           end if
5840         end if
5841       end if     ! End 3D correlations
5842
5843       Return
5844       END
5845
5846
5847 C-----------------------------------------------------------------------
5848
5849
5850       subroutine c2_1d(h,href,c2,c2err,maxh,maxc2,n,num_pairs_sig,
5851      1                 num_pairs_bkg)
5852       implicit none
5853
5854 CCC   Computes the two-body correlation function for 1D distributions.
5855 CCC   Errors are also computed.
5856 CCC
5857 CCC   Description of Input Variables in Argument List:
5858 C
5859 C     h(maxh)       = signal histogram (numerator)
5860 C     href(maxh)    = background histogram (denominator)
5861 C     c2(maxc2)     = correlation function = a/b
5862 C     c2err(maxc2)  = correlation function error
5863 C     maxh          = dimension of histogram arrays
5864 C     maxc2         = dimension of correlation function array.
5865 C     n             = # bins to use
5866 C     num_pairs_sig = # pairs used in signal histogram
5867 C     num_pairs_bkg = # pairs used in background histogram
5868 C
5869
5870 CCC   Local Variable Type Declarations:
5871
5872       integer*4 maxh,maxc2,n,num_pairs_sig,num_pairs_bkg
5873       integer*4 h(maxh), href(maxh)
5874       integer*4 k
5875
5876       real*4    c2(maxc2), c2err(maxc2)
5877       real*4    a,a_error,b,b_error
5878
5879       do k = 1,n
5880         if(href(k).le.0 .or. h(k).le.0) then
5881           c2(k) = 0.0
5882           c2err(k) = 1.0
5883         else
5884           a = float(h(k))/float(num_pairs_sig)
5885           a_error = sqrt(float(h(k)))/float(num_pairs_sig)
5886           b = float(href(k))/float(num_pairs_bkg)
5887           b_error = sqrt(float(href(k)))/float(num_pairs_bkg)
5888           c2(k) = a/b
5889           c2err(k) = c2(k)*sqrt((a_error/a)**2 + (b_error/b)**2)
5890         end if
5891       end do
5892
5893       Return
5894       END
5895
5896 C-----------------------------------------------------------------------
5897
5898
5899       subroutine c2_3d(h,href,c2,c2err,maxh,maxc2,n,num_pairs_sig,
5900      1                 num_pairs_bkg)
5901       implicit none
5902
5903 CCC   Computes the two-body correlation function for 3D distributions.
5904 CCC   Errors are also computed.
5905 CCC
5906 CCC   Description of Input Variables in Argument List:
5907 C
5908 C     h(maxh,maxh,maxh)         = 3D signal histogram (numerator)
5909 C     href(maxh,maxh,maxh))     = 3D background histogram (denominator)
5910 C     c2(maxc2,maxc2,maxc2)     = 3D correlation function = a/b
5911 C     c2err(maxc2,maxc2,maxc2)  = 3D correlation function error
5912 C     maxh          = dimension of 3D histogram arrays
5913 C     maxc2         = dimension of 3D correlation function array.
5914 C     n             = # bins to use
5915 C     num_pairs_sig = # pairs used in signal histogram
5916 C     num_pairs_bkg = # pairs used in background histogram
5917 C
5918
5919 CCC   Local Variable Type Declarations:
5920
5921       integer*4 maxh,maxc2,n,num_pairs_sig,num_pairs_bkg
5922       integer*4 h(maxh,maxh,maxh), href(maxh,maxh,maxh)
5923       integer*4 i,j,k
5924
5925       real*4    c2(maxc2,maxc2,maxc2), c2err(maxc2,maxc2,maxc2)
5926       real*4    a,a_error,b,b_error
5927
5928       do i = 1,n
5929       do j = 1,n
5930       do k = 1,n
5931         if(href(i,j,k).le.0 .or. h(i,j,k).le.0) then
5932           c2(i,j,k) = 0.0
5933           c2err(i,j,k) = 1.0
5934         else
5935           a = float(h(i,j,k))/float(num_pairs_sig)
5936           a_error = sqrt(float(h(i,j,k)))/float(num_pairs_sig)
5937           b = float(href(i,j,k))/float(num_pairs_bkg)
5938           b_error = sqrt(float(href(i,j,k)))/float(num_pairs_bkg)
5939           c2(i,j,k) = a/b
5940           c2err(i,j,k) = c2(i,j,k)*sqrt((a_error/a)**2 + (b_error/b)**2)
5941         end if
5942       end do
5943       end do
5944       end do
5945
5946       Return
5947       END
5948
5949
5950 C-------------------------------------------------------------------------
5951
5952
5953       subroutine chisquare(mode,chisq_like_1d,chisq_unlike_1d,
5954      1           chisq_like_3d_fine,chisq_unlike_3d_fine,
5955      2           chisq_like_3d_coarse,chisq_unlike_3d_coarse,
5956      3           chisq_hist1_1,chisq_hist1_2)
5957       implicit none
5958
5959 CCC   This subroutine calculates the chi-squares for the following:
5960 C       o Like pair   1D 2-body correlations
5961 C       o Unlike pair 1D 2-body correlations
5962 C       o Like pair   3D, Fine Mesh   2-body correlations
5963 C       o Unlike pair 3D, Fine Mesh   2-body correlations
5964 C       o Like pair   3D, Coarse Mesh 2-body correlations
5965 C       o Unlike pair 3D, Coarse Mesh 2-body correlations
5966 C       o One-body 1D {pt,phi,eta} (summed) distributions for PID#1
5967 C       o One-body 1D {pt,phi,eta} (summed) distributions for PID#2
5968 C
5969 C         (where the separate chi-squares for the 1D pt, phi and eta
5970 C          one-body distributions are added and only the sum is returned.)
5971 C
5972 C     'Mode' determines which one-body histogram is compared to the
5973 C     reference histogram, where:
5974 C
5975 C     If mode = 1, then hist1* are used
5976 C     If mode = 2, then htmp1* are used
5977 C
5978 C     The one-body reference histograms used in the chi-square calculation
5979 C     are in href1*
5980
5981       Include 'common_parameters.inc'
5982       Include 'common_mesh.inc'
5983       Include 'common_histograms.inc'
5984       Include 'common_correlations.inc'
5985
5986 CCC   Local Variable Type Declarations:
5987
5988       integer*4 i,j,k,mode
5989
5990       real*4    chisq_like_1d, chisq_unlike_1d
5991       real*4    chisq_like_3d_fine,chisq_unlike_3d_fine
5992       real*4    chisq_like_3d_coarse,chisq_unlike_3d_coarse
5993       real*4    chisq_hist1_1,chisq_hist1_2
5994
5995       real*4    n1fac,n2fac   ! # part 1(2) used/# part 1(2) used in Ref.
5996       real*4    avgerrsq_pt_1, avgerrsq_phi_1, avgerrsq_eta_1
5997       real*4    avgerrsq_pt_2, avgerrsq_phi_2, avgerrsq_eta_2
5998       real*4    avgerrsq_pt_ref_1,avgerrsq_phi_ref_1,avgerrsq_eta_ref_1
5999       real*4    avgerrsq_pt_ref_2,avgerrsq_phi_ref_2,avgerrsq_eta_ref_2
6000       real*4    chisq1
6001
6002 CCC   Initialize all chi-square values to zero:
6003
6004       chisq_like_1d          = 0.0
6005       chisq_unlike_1d        = 0.0
6006       chisq_like_3d_fine     = 0.0
6007       chisq_unlike_3d_fine   = 0.0
6008       chisq_like_3d_coarse   = 0.0
6009       chisq_unlike_3d_coarse = 0.0
6010       chisq_hist1_1          = 0.0
6011       chisq_hist1_2          = 0.0
6012
6013       if(switch_1d .gt. 0) then
6014         if(switch_type.eq.1 .or. switch_type.eq.3) then
6015           do i = 1,n_1d_total
6016             if(c2fit_like_1d(i) .ne. 0.0) then
6017               chisq_like_1d = chisq_like_1d + ((c2fit_like_1d(i)
6018      1          - c2mod_like_1d(i))/c2err_like_1d(i))**2
6019             end if
6020           end do
6021         end if
6022         if(switch_type.eq.2 .or. switch_type.eq.3) then
6023           do i = 1,n_1d_total
6024             if(c2fit_unlike_1d(i) .ne. 0.0) then
6025               chisq_unlike_1d = chisq_unlike_1d + ((c2fit_unlike_1d(i)
6026      1          - c2mod_unlike_1d(i))/c2err_unlike_1d(i))**2
6027             end if
6028           end do
6029         end if
6030       end if        ! End 1D correlation function, chi-square option
6031
6032       if(switch_3d .gt. 0) then
6033         if(switch_type.eq.1 .or. switch_type.eq.3) then
6034
6035           if(n_3d_fine .gt. 0) then
6036             do i = 1,n_3d_fine
6037             do j = 1,n_3d_fine
6038             do k = 1,n_3d_fine
6039               if(c2fit_like_3d_fine(i,j,k).ne.0.0) then
6040               chisq_like_3d_fine = chisq_like_3d_fine
6041      1          + ((c2fit_like_3d_fine(i,j,k)
6042      2          -   c2mod_like_3d_fine(i,j,k))
6043      3             /c2err_like_3d_fine(i,j,k))**2
6044               end if
6045             end do
6046             end do
6047             end do
6048           end if
6049
6050           if(n_3d_coarse .gt. 0) then
6051             do i = 1,n_3d_coarse
6052             do j = 1,n_3d_coarse
6053             do k = 1,n_3d_coarse
6054               if((i+j+k).gt.3) then
6055               if(c2fit_like_3d_coarse(i,j,k).ne.0.0) then
6056               chisq_like_3d_coarse = chisq_like_3d_coarse
6057      1          +((c2fit_like_3d_coarse(i,j,k)
6058      2          -  c2mod_like_3d_coarse(i,j,k))
6059      3            /c2err_like_3d_coarse(i,j,k))**2
6060               end if
6061               end if
6062             end do
6063             end do
6064             end do
6065           end if
6066
6067         end if
6068
6069         if(switch_type.eq.2 .or. switch_type.eq.3) then
6070
6071           if(n_3d_fine .gt. 0) then
6072             do i = 1,n_3d_fine
6073             do j = 1,n_3d_fine
6074             do k = 1,n_3d_fine
6075               if(c2fit_unlike_3d_fine(i,j,k).ne.0.0) then
6076               chisq_unlike_3d_fine = chisq_unlike_3d_fine
6077      1          + ((c2fit_unlike_3d_fine(i,j,k)
6078      2          -   c2mod_unlike_3d_fine(i,j,k))
6079      3             /c2err_unlike_3d_fine(i,j,k))**2
6080               end if
6081             end do
6082             end do
6083             end do
6084           end if
6085
6086           if(n_3d_coarse .gt. 0) then
6087             do i = 1,n_3d_coarse
6088             do j = 1,n_3d_coarse
6089             do k = 1,n_3d_coarse
6090               if((i+j+k).gt.3) then
6091               if(c2fit_unlike_3d_coarse(i,j,k).ne.0.0) then
6092               chisq_unlike_3d_coarse = chisq_unlike_3d_coarse
6093      1          +((c2fit_unlike_3d_coarse(i,j,k)
6094      2          -  c2mod_unlike_3d_coarse(i,j,k))
6095      3            /c2err_unlike_3d_coarse(i,j,k))**2
6096               end if
6097               end if
6098             end do
6099             end do
6100             end do
6101           end if
6102
6103         end if
6104       end if         !  End of 3D Correlation Function, Chi-Square Option
6105
6106 CCC   Obtain chi-squares for one-body distributions
6107
6108       if(pid(1) .gt. 0) then
6109         n1fac = float(n_part_used_1_trk)/float(n_part_used_1_ref)
6110         avgerrsq_pt_1      = float(n_part_used_1_trk)/float(n_pt_bins)
6111         avgerrsq_phi_1     = float(n_part_used_1_trk)/float(n_phi_bins)
6112         avgerrsq_eta_1     = float(n_part_used_1_trk)/float(n_eta_bins)
6113         avgerrsq_pt_ref_1  = float(n_part_used_1_ref)/float(n_pt_bins)
6114         avgerrsq_phi_ref_1 = float(n_part_used_1_ref)/float(n_phi_bins)
6115         avgerrsq_eta_ref_1 = float(n_part_used_1_ref)/float(n_eta_bins)
6116       end if
6117
6118       if(pid(2) .gt. 0) then
6119         n2fac = float(n_part_used_2_trk)/float(n_part_used_2_ref)
6120         avgerrsq_pt_2      = float(n_part_used_2_trk)/float(n_pt_bins)
6121         avgerrsq_phi_2     = float(n_part_used_2_trk)/float(n_phi_bins)
6122         avgerrsq_eta_2     = float(n_part_used_2_trk)/float(n_eta_bins)
6123         avgerrsq_pt_ref_2  = float(n_part_used_2_ref)/float(n_pt_bins)
6124         avgerrsq_phi_ref_2 = float(n_part_used_2_ref)/float(n_phi_bins)
6125         avgerrsq_eta_ref_2 = float(n_part_used_2_ref)/float(n_eta_bins)
6126       end if
6127
6128       if(pid(1) .gt. 0) then
6129         if(mode .eq. 1) then
6130
6131           chisq_hist1_1 =
6132      1      chisq1(hist1_pt_1,href1_pt_1,max_h_1d,avgerrsq_pt_1,
6133      2             avgerrsq_pt_ref_1,n1fac,n_pt_bins)
6134      3     +chisq1(hist1_phi_1,href1_phi_1,max_h_1d,avgerrsq_phi_1,
6135      4             avgerrsq_phi_ref_1,n1fac,n_phi_bins)
6136      5     +chisq1(hist1_eta_1,href1_eta_1,max_h_1d,avgerrsq_eta_1,
6137      6             avgerrsq_eta_ref_1,n1fac,n_eta_bins)
6138
6139         else if(mode .eq. 2) then
6140
6141           chisq_hist1_1 =
6142      1      chisq1(htmp1_pt_1,href1_pt_1,max_h_1d,avgerrsq_pt_1,
6143      2             avgerrsq_pt_ref_1,n1fac,n_pt_bins)
6144      3     +chisq1(htmp1_phi_1,href1_phi_1,max_h_1d,avgerrsq_phi_1,
6145      4             avgerrsq_phi_ref_1,n1fac,n_phi_bins)
6146      5     +chisq1(htmp1_eta_1,href1_eta_1,max_h_1d,avgerrsq_eta_1,
6147      6             avgerrsq_eta_ref_1,n1fac,n_eta_bins)
6148
6149         end if
6150       end if     ! End pid(1) one-body histogram chi-square calculation
6151
6152       if(pid(2) .gt. 0) then
6153         if(mode .eq. 1) then
6154
6155           chisq_hist1_2 =
6156      1      chisq1(hist1_pt_2,href1_pt_2,max_h_1d,avgerrsq_pt_2,
6157      2             avgerrsq_pt_ref_2,n2fac,n_pt_bins)
6158      3     +chisq1(hist1_phi_2,href1_phi_2,max_h_1d,avgerrsq_phi_2,
6159      4             avgerrsq_phi_ref_2,n2fac,n_phi_bins)
6160      5     +chisq1(hist1_eta_2,href1_eta_2,max_h_1d,avgerrsq_eta_2,
6161      6             avgerrsq_eta_ref_2,n2fac,n_eta_bins)
6162
6163         else if(mode .eq. 2) then
6164
6165           chisq_hist1_2 =
6166      1      chisq1(htmp1_pt_2,href1_pt_2,max_h_1d,avgerrsq_pt_2,
6167      2             avgerrsq_pt_ref_2,n2fac,n_pt_bins)
6168      3     +chisq1(htmp1_phi_2,href1_phi_2,max_h_1d,avgerrsq_phi_2,
6169      4             avgerrsq_phi_ref_2,n2fac,n_phi_bins)
6170      5     +chisq1(htmp1_eta_2,href1_eta_2,max_h_1d,avgerrsq_eta_2,
6171      6             avgerrsq_eta_ref_2,n2fac,n_eta_bins)
6172
6173         end if
6174       end if     ! End pid(2) one-body histogram chi-square calculation
6175
6176       Return
6177       END
6178
6179 C----------------------------------------------------------------------
6180
6181
6182       real*4 function chisq1(h,href,maxh,herravgsq,hreferravgsq,
6183      1                       numfac,nbins)
6184       implicit none
6185
6186 CCC   Compute chi-square for 1D histogram h(), with respect to the
6187 CCC   reference histogram, href().
6188 C
6189 C     h(maxh)       = 1D histogram array
6190 C     href(maxh)    = 1D reference histogram array
6191 C     maxh          = dimension of histogram arrays
6192 C     herravgsq     = average error squared in histogram h's bins
6193 C     hreferravgsq  = average error squared in ref. hist. href's bins
6194 C     numfac        = ratio of total number of entries in h to that
6195 C                     in href
6196 C     nbins         = # bins to use in chi-square sum, starting at array
6197 C                     element 1,2,... nbins (where nbins .le. maxh)
6198 C
6199 C     The chi-square value is returned in chisq1
6200
6201 CCC   Local Variable Type Declarations:
6202
6203       integer*4 maxh, nbins, i
6204       integer*4 h(maxh),href(maxh)
6205
6206       real*4 herravgsq,hreferravgsq,numfac,numfacsq
6207       real*4 herrsq,hreferrsq
6208
6209       chisq1 = 0.0
6210       numfacsq = numfac*numfac
6211
6212       do i = 1,nbins
6213         if(h(i) .gt. 0) then
6214           herrsq = float(h(i))
6215         else
6216           herrsq = herravgsq
6217         end if
6218
6219         if(href(i) .gt. 0) then
6220           hreferrsq = float(href(i))
6221         else
6222           hreferrsq = hreferravgsq
6223         end if
6224
6225         chisq1 = chisq1 + ((float(h(i)) - numfac*float(href(i)))**2)
6226      1           /(herrsq + numfacsq*hreferrsq)
6227       end do
6228
6229       Return
6230       END
6231
6232 C-----------------------------------------------------------------------
6233
6234
6235       Subroutine write_data(mode,ievent)
6236       implicit none
6237
6238 CCC   This subroutine writes the main output file, 'hbt_simulation.out'
6239 C     on File Unit 8.  File Unit 8 is opened and closed by the main
6240 C     program.
6241 C
6242 C     Also, the computed 1- and 2-body reference histograms are printed
6243 C     out from this subroutine on File Units 11 and 9, respectively.  These
6244 C     files are opened/closed here.
6245 C
6246 C     Output content determined by input parameter 'mode', where:
6247 C
6248 C     Mode           Description of Output
6249 C    -----   -----------------------------------------------------------
6250 C      1     basic output file header
6251 C            input and derived quantities
6252 C
6253 C      2     reference histograms (1 and 2-body)
6254 C            saved to separate I/O File Unit=11,9 respectively
6255 C
6256 C      3     reference histogram output
6257 C
6258 C      4     correlation model
6259 C
6260 C      5     correlation fit and one-body distributions
6261 C            for each event, optional output
6262 C
6263 C      6     inclusive one-body distributions and inclusive
6264 C            correlation fit; projection onto 1D axes.
6265 C
6266
6267       Include 'common_parameters.inc'
6268       Include 'common_mesh.inc'
6269       Include 'common_histograms.inc'
6270       Include 'common_correlations.inc'
6271       Include 'common_coulomb.inc'
6272       Include 'common_event_summary.inc'
6273
6274       Include 'common_track.inc'
6275       Include 'common_sec_track.inc'
6276       Include 'common_sec_track2.inc'
6277
6278 CCC   Local Variable Type Declarations:
6279
6280       integer*4 mode,i,j,k,ievent,ref_print,nev
6281
6282       real*4 nfac1,nfac2,ref_error
6283       real*4 c2mod_proj1(max_c2_3d)
6284       real*4 c2mod_proj2(max_c2_3d)
6285       real*4 c2mod_proj3(max_c2_3d)
6286       real*4 c2fit_proj1(max_c2_3d)
6287       real*4 c2fit_proj2(max_c2_3d)
6288       real*4 c2fit_proj3(max_c2_3d)
6289       real*4 c2err_proj1(max_c2_3d)
6290       real*4 c2err_proj2(max_c2_3d)
6291       real*4 c2err_proj3(max_c2_3d)
6292
6293 C-------------------------------------------
6294       If(mode.eq.1) Then   !Basic Output Header
6295 C-------------------------------------------
6296
6297       write(8,100)
6298       write(8,101)
6299       write(8,100)
6300 C     write(8,102) n_events
6301       write(8,103) n_pid_types,pid(1),mass1,pid(2),mass2
6302       write(8,104) ref_control
6303       write(8,105) switch_1d
6304       write(8,106) switch_3d
6305       write(8,107) switch_type
6306       write(8,108) switch_coherence
6307       write(8,109) switch_coulomb
6308       write(8,110) switch_fermi_bose
6309       write(8,1101) trk_accep
6310       write(8,111) print_full,print_sector_data
6311 C     write(8,112) n_part_used_1_ref,n_part_used_2_ref
6312 C     write(8,113) n_part_used_1_inc,n_part_used_2_inc
6313 C     write(8,114) num_pairs_like_ref,num_pairs_unlike_ref
6314 C     write(8,115) num_pairs_like_inc,num_pairs_unlike_inc
6315       write(8,116) lambda
6316       write(8,117) R_1d
6317       write(8,118) Rside,Rout,Rlong
6318       write(8,119) Rperp,Rparallel,R0
6319       write(8,120) Q0
6320       write(8,121) irand
6321       write(8,122) maxit
6322       write(8,123) deltap
6323       write(8,124) delchi
6324       write(8,125) chisq_wt_like_1d
6325       write(8,126) chisq_wt_unlike_1d
6326       write(8,127) chisq_wt_like_3d_fine
6327       write(8,128) chisq_wt_unlike_3d_fine
6328       write(8,129) chisq_wt_like_3d_coarse
6329       write(8,130) chisq_wt_unlike_3d_coarse
6330       write(8,131) chisq_wt_hist1_1
6331       write(8,132) chisq_wt_hist1_2
6332       write(8,133)
6333       write(8,134) n_pt_bins,pt_bin_size,pt_min,pt_max
6334       write(8,135) n_phi_bins,phi_bin_size,phi_min,phi_max
6335       write(8,136) n_eta_bins,eta_bin_size,eta_min,eta_max
6336       write(8,137)
6337       write(8,138) n_px_bins,delpx,px_min,px_max
6338       write(8,139) n_py_bins,delpy,py_min,py_max
6339       write(8,140) n_pz_bins,delpz,pz_min,pz_max
6340       write(8,141) n_sectors
6341       write(8,142)
6342       write(8,143) n_1d_fine,n_1d_coarse,n_1d_total
6343       write(8,144) binsize_1d_fine,binsize_1d_coarse
6344       write(8,145) qmid_1d,qmax_1d
6345       write(8,146)
6346       write(8,147) n_3d_fine,n_3d_coarse,n_3d_total
6347       write(8,148) binsize_3d_fine,binsize_3d_coarse
6348       write(8,149) qmid_3d,qmax_3d
6349       write(8,150) n_3d_fine_project
6350
6351 CCC   Formats for Mode=1 Output
6352
6353  100  format(   15x,50('*'))
6354  101  format(   15x,'*****',7x,'HBT CORRELATION SIMULATION',7x,'*****')
6355  102  format(///15x,'Number of Events in Event Text Input File=',I5)
6356  103  format(  /15x,'#PID types=',I2,'  PID#,mass=',I2,F8.5,
6357      1'  PID#,mass=',I2,F8.5)
6358  104  format(/  15x,'Reference Spectra Selection Option=',I2)
6359  105  format(// 15x,'Control Switches: Switch_1d         =',I2)
6360  106  format(   15x,'                  Switch_3d         =',I2)
6361  107  format(   15x,'                  Switch_type       =',I2)
6362  108  format(   15x,'                  Switch_coherence  =',I2)
6363  109  format(   15x,'                  Switch_coulomb    =',I2)
6364  110  format(   15x,'                  Switch_fermi_bose =',I2)
6365 1101  format(   15x,'                  trk_accep         =',F10.7)
6366  111  format(/  15x,'Print Options: Full=',I2,'  Sectors=',I2)
6367  112  format(// 15x,
6368      1'Number particles used in Reference, for PID types=',2I5)
6369  113  format( 15x,
6370      1'Number particles used in Inclusive, for PID types=',2I5)
6371  114  format(/  15x,
6372      1'Number pairs used in Reference, like and unlike=',2I5)
6373  115  format(  15x,
6374      1'Number pairs used in Inclusive, like and unlike=',2I5)
6375  116  format(//  15x,'Correlation Model Parameters: Chaoticity =',F8.5)
6376  117  format(    15x,'1D Spherical Source Radius=',F8.4)
6377  118  format(    15x,'Bertsch-Pratt R-side,out,long=',3F8.4)
6378  119  format(    15x,'YKP R-perp,parallel,time=',3F8.4)
6379  120  format(    15x,'Coulomb parameter=',F8.5)
6380  121  format(//  15x,'Iteration Controls: Random # seed        =',I10)
6381  122  format(    15x,'                    Max # iterations     =',I5)
6382  123  format(    15x,'                    Momentum Shift Range =',F8.5)
6383  124  format(    15x,'                    Min % Chi-Sq limit   =',F8.5)
6384  125  format(//  15x,'CHI-Sq Weights: correl,like,  1d       =',F8.5)
6385  126  format(    15x,'                correl,unlike,1d       =',F8.5)
6386  127  format(    15x,'                correl,like,  3d_fine  =',F8.5)
6387  128  format(    15x,'                correl,unlike,3d_fine  =',F8.5)
6388  129  format(    15x,'                correl,like,  3d_coarse=',F8.5)
6389  130  format(    15x,'                correl,unlike,3d_coarse=',F8.5)
6390  131  format(    15x,'                1-body, PID#1          =',F8.5)
6391  132  format(    15x,'                1-body, PID#2          =',F8.5)
6392  133  format(//  15x,'Momentum Space Acceptance Range and 1D Bins:')
6393  134  format(    15x,'#bins,bin size,min,max for pt =',I5,3F8.5)
6394  135  format(    15x,'#bins,bin size,min,max for phi=',I5,3F8.4)
6395  136  format(    15x,'#bins,bin size,min,max for eta=',I5,3F8.4)
6396  137  format(//  15x,'Momentum Space Sectors:')
6397  138  format(    15x,'#sectors,sectorsize,min,max for px=',I5,3F8.4)
6398  139  format(    15x,'#sectors,sectorsize,min,max for py=',I5,3F8.4)
6399  140  format(    15x,'#sectors,sectorsize,min,max for pz=',I5,3F8.4)
6400  141  format(    15x,'Total Number of Sectors           =',I5)
6401  142  format(//  15x,'2-Body Correlations, 1-D Grid:')
6402  143  format(    15x,'#bins_fine,coarse,total     =',3I5)
6403  144  format(    15x,'bin size - fine, coarse     =',2F8.5)
6404  145  format(    15x,'Q mid point, Q maximum      =',2F8.5)
6405  146  format(//  15x,'2-Body Correlations, 3-D Grid:')
6406  147  format(    15x,'#bins - fine, coarse, total =',3I5)
6407  148  format(    15x,'bin size - fine, coarse     =',2F8.5)
6408  149  format(    15x,'Q mid point, Q maximum      =',2F8.5)
6409  150  format(    15x,'# 3D fine bin projected     =',I5)
6410
6411 CCC   END mode=1 Output and Formats
6412
6413 C-----------------------------
6414       Else If(mode.eq.2) Then   !Store 2- and 1-body Ref. Histograms
6415 C-----------------------------
6416
6417
6418       open(unit=9,status='unknown',access='sequential',
6419      1     file='hbt_pair_reference.hist')
6420       open(unit=11,status='unknown',access='sequential',
6421      1     file='hbt_singles_reference.hist')
6422
6423 C     Write Pair Reference Hist:
6424
6425       write(9,201) n_pid_types,pid(1),pid(2)
6426       write(9,202) n_pt_bins,pt_min,pt_max
6427       write(9,202) n_phi_bins,phi_min,phi_max
6428       write(9,202) n_eta_bins,eta_min,eta_max
6429       write(9,201) switch_1d,switch_3d,switch_type
6430       write(9,203) n_1d_fine,n_1d_coarse,n_3d_fine,n_3d_coarse
6431       write(9,204) binsize_1d_fine,binsize_1d_coarse,
6432      1             binsize_3d_fine,binsize_3d_coarse
6433       write(9,201) num_pairs_like_ref,num_pairs_unlike_ref
6434  201  format(2x,3I10)
6435  202  format(2x,I10,2E15.6)
6436  203  format(2x,4I10)
6437  204  format(2x,4E15.6)
6438  205  format(2x,I20)
6439
6440       if(switch_1d.gt.0.and.n_1d_total.gt.0) then
6441         if(switch_type.eq.1.or.switch_type.eq.3) then
6442           write(9,205) (href_like_1d(i),i=1,n_1d_total)
6443         end if
6444         if(switch_type.eq.2.or.switch_type.eq.3) then
6445           write(9,205) (href_unlike_1d(i),i=1,n_1d_total)
6446         endif
6447       endif     !End 1D Ref. Hist. Output
6448
6449       if(switch_3d.gt.0) then
6450         if(switch_type.eq.1.or.switch_type.eq.3) then
6451
6452           if(n_3d_fine.gt.0) then
6453             do i=1,n_3d_fine
6454             do j=1,n_3d_fine
6455             do k=1,n_3d_fine
6456                write(9,205) href_like_3d_fine(i,j,k)
6457             enddo
6458             enddo
6459             enddo
6460           endif
6461
6462           if(n_3d_coarse.gt.0) then
6463             do i=1,n_3d_coarse
6464             do j=1,n_3d_coarse
6465             do k=1,n_3d_coarse
6466                write(9,205) href_like_3d_coarse(i,j,k)
6467             enddo
6468             enddo
6469             enddo
6470           endif
6471
6472         end if
6473
6474         if(switch_type.eq.2.or.switch_type.eq.3) then
6475
6476           if(n_3d_fine.gt.0) then
6477             do i=1,n_3d_fine
6478             do j=1,n_3d_fine
6479             do k=1,n_3d_fine
6480                write(9,205) href_unlike_3d_fine(i,j,k)
6481             enddo
6482             enddo
6483             enddo
6484           endif
6485
6486           if(n_3d_coarse.gt.0) then
6487             do i=1,n_3d_coarse
6488             do j=1,n_3d_coarse
6489             do k=1,n_3d_coarse
6490                write(9,205) href_unlike_3d_coarse(i,j,k)
6491             enddo
6492             enddo
6493             enddo
6494           endif
6495
6496         endif
6497       endif     !End 3D Reference Histograms Output
6498
6499 CC    Write One-Body  - singles histograms:
6500
6501       write(11,201) n_pid_types,pid(1),pid(2)
6502       write(11,202) n_pt_bins,pt_min,pt_max
6503       write(11,202) n_phi_bins,phi_min,phi_max
6504       write(11,202) n_eta_bins,eta_min,eta_max
6505       write(11,201) n_part_used_1_ref,n_part_used_2_ref
6506
6507       if(pid(1).gt.0) then
6508         write(11,205)(href1_pt_1(i),i=1,n_pt_bins)
6509         write(11,205)(href1_phi_1(i),i=1,n_phi_bins)
6510         write(11,205)(href1_eta_1(i),i=1,n_eta_bins)
6511       endif
6512
6513
6514       if(pid(2).gt.0) then
6515         write(11,205)(href1_pt_2(i),i=1,n_pt_bins)
6516         write(11,205)(href1_phi_2(i),i=1,n_phi_bins)
6517         write(11,205)(href1_eta_2(i),i=1,n_eta_bins)
6518       endif
6519
6520       close(unit=9)
6521       close(unit=11)
6522
6523 CCC   END mode=2 Reference Histogram Output
6524
6525 C-----------------------------
6526       Else If(mode.eq.3) Then   !Print out the Reference Histograms
6527 C-----------------------------
6528
6529       write(8,300)
6530       write(8,301)
6531       write(8,302) n_pt_bins,pt_min,pt_max
6532       write(8,303) n_phi_bins,phi_min,phi_max
6533       write(8,304) n_eta_bins,eta_min,eta_max
6534       write(8,305) n_part_used_1_ref,n_part_used_2_ref
6535
6536       write(8,306)
6537       do i=1,n_pt_bins
6538          write(8,307) i,href1_pt_1(i),href1_pt_2(i)
6539       enddo
6540
6541       write(8,308)
6542       do i=1,n_phi_bins
6543          write(8,307) i,href1_phi_1(i),href1_phi_2(i)
6544       enddo
6545
6546       write(8,309)
6547       do i=1,n_eta_bins
6548          write(8,307) i,href1_eta_1(i),href1_eta_2(i)
6549       enddo
6550
6551       write(8,310)
6552       write(8,311) n_1d_fine,n_1d_coarse
6553       write(8,312) binsize_1d_fine,binsize_1d_coarse
6554       write(8,313) n_3d_fine,n_3d_coarse
6555       write(8,314) binsize_3d_fine,binsize_3d_coarse
6556       write(8,315) num_pairs_like_ref,num_pairs_unlike_ref
6557
6558       if(switch_1d.gt.0.and.n_1d_total.gt.0) then
6559         write(8,316)
6560             do i=1,n_1d_total
6561                write(8,307) i,href_like_1d(i),href_unlike_1d(i)
6562             enddo
6563       endif     !End Print Out of 2-body, 1D reference histogram
6564
6565       if(switch_3d.gt.0.and.n_3d_fine.gt.0) then
6566         write(8,317)
6567         do i=1,n_3d_fine
6568         do j=1,n_3d_fine
6569         do k=1,n_3d_fine
6570            write(8,318) i,j,k,href_like_3d_fine(i,j,k),
6571      1                  href_unlike_3d_fine(i,j,k)
6572         enddo
6573         enddo
6574         enddo
6575       endif          !End Print Out of 2-Body, 3D-Fine Mesh Ref. Hist.
6576
6577
6578       if(switch_3d.gt.0.and.n_3d_coarse.gt.0) then
6579         write(8,319)
6580         do i=1,n_3d_coarse
6581         do j=1,n_3d_coarse
6582         do k=1,n_3d_coarse
6583            write(8,318) i,j,k,href_like_3d_coarse(i,j,k),
6584      1                  href_unlike_3d_coarse(i,j,k)
6585         enddo
6586         enddo
6587         enddo
6588       endif         !End Print Out of 2-Body, 3D-Coarse Mesh Ref. Hist.
6589
6590 CCC   Formats for mode=3 Output:
6591
6592  300  format(///5x,15('*'),'REFERENCE HISTOGRAMS',15('*'))
6593  301  format(//15x,'ONE-BODY REFERENCE DISTRIBUTIONS:')
6594  302  format(/ 15x,'PT BINS: (#,min,max)=',I5,2F8.4)
6595  303  format(  15x,'PHI BINS:(#,min,max)=',I5,2F8.4)
6596  304  format(  15x,'ETA BINS:(#,min,max)=',I5,2F8.4)
6597  305  format(  15x,'Number particles used in Ref, PID type1,2=',2I8)
6598  306  format(/  9x,'PT',10x,'BIN#',5x,'PID-1',5x,'PID-2')
6599  308  format(/  9x,'PHI',9x,'BIN#',5x,'PID-1',5x,'PID-2')
6600  309  format(/  9x,'ETA',9x,'BIN#',5x,'PID-1',5x,'PID-2')
6601  307  format(  20x,I5,2I10)
6602  310  format(///15x,'TWO-BODY REFERENCE DISTRIBUTIONS:')
6603  311  format(/  15x,'#BINS FOR 1D-Fine and Coarse Grid =',2I5)
6604  312  format(   15x,'BIN SIZES FOR 1D-Fine and Coarse  =',2F8.5)
6605  313  format(   15x,'#BINS FOR 3D-Fine and Coarse Grid =',2I5)
6606  314  format(   15x,'BIN SIZES FOR 3D-Fine and Coarse  =',2F8.5)
6607  315  format(   15x,'Number of Like and Unlike Pairs For Ref. = ',
6608      1             2I10)
6609  316  format(/5x,'2-BODY, 1D',6x,'BIN#',5x,'LIKE',5x,'UNLIKE')
6610  317  format(/3x,'2-BODY, 3D-FINE',2x,'BIN:i',4x,'j',4x,
6611      1     'k',5x,'LIKE',5x,'UNLIKE')
6612  318  format(   20x,3I5,2I10)
6613  319  format(/2x,'2-BODY, 3D-COARSE',1x,'BIN:i',4x,'j',4x,
6614      1     'k',5x,'LIKE',5x,'UNLIKE')
6615
6616 CCC   END mode=3  Output and Formats
6617
6618 C----------------------------
6619       Else If(mode.eq.4) Then   !Print Correlation Function Model
6620 C----------------------------
6621
6622       write(8,400)
6623       write(8,311) n_1d_fine,n_1d_coarse
6624       write(8,312) binsize_1d_fine,binsize_1d_coarse
6625       write(8,313) n_3d_fine,n_3d_coarse
6626       write(8,314) binsize_3d_fine,binsize_3d_coarse
6627
6628
6629       if(switch_1d.gt.0.and.n_1d_total.gt.0) then
6630         write(8,316)
6631             do i=1,n_1d_total
6632                write(8,407) i,c2mod_like_1d(i),c2mod_unlike_1d(i)
6633             enddo
6634       endif     !End Print Out of 2-body, 1D Model Correction Functions
6635
6636       if(switch_3d.gt.0.and.n_3d_fine.gt.0) then
6637         write(8,317)
6638         do i=1,n_3d_fine
6639         do j=1,n_3d_fine
6640         do k=1,n_3d_fine
6641           write(8,418) i,j,k,c2mod_like_3d_fine(i,j,k),
6642      1                 c2mod_unlike_3d_fine(i,j,k)
6643         enddo
6644         enddo
6645         enddo
6646       endif  !End Print Out of 2-Body, 3D-Fine mesh Model Correl. Function
6647
6648       if(switch_3d.gt.0.and.n_3d_coarse.gt.0) then
6649         write(8,319)
6650         do i=1,n_3d_coarse
6651         do j=1,n_3d_coarse
6652         do k=1,n_3d_coarse
6653           write(8,418) i,j,k,c2mod_like_3d_coarse(i,j,k),
6654      1                 c2mod_unlike_3d_coarse(i,j,k)
6655         enddo
6656         enddo
6657         enddo
6658       endif  !End Print Out of 2-Body, 3D-Coarse Model Correlation Function
6659
6660       if(switch_coulomb.eq.3) then ! Print interpolated Pratt Model
6661 CC                                 ! Coulomb Correction for Finite
6662 CC                                 ! Source Radius Q0
6663         write(8,401)Q0
6664         write(8,402)
6665         do i=1,max_c2_coul
6666            write(8,403) i,q_coul(i),c2_coul_like(i),
6667      1                  c2_coul_unlike(i)
6668         enddo
6669       endif
6670
6671 CCC   Additional Formats for Mode=4 Output:
6672
6673  400  format(///5x,15('*'),'MODEL CORRELATION FUNCTIONS',15('*'))
6674  401  format(///15x,'COULOMB SOURCE RADIUS FOR PRATT MODEL=',F8.4)
6675  402  format(// 5x,'q-bin',2x,'q',4x,'C2_coul_like',2x,
6676      1             'C2_coul_unlike')
6677  403  format(   5x,I5,3E15.6)
6678  407  format(  20x,I5,2F10.7)
6679  418  format(   20x,3I5,2F10.7)
6680
6681 CCC   END MODE = 4  OUTPUT AND FORMATS
6682
6683 C------------------------------
6684       Else If(mode.eq.5) Then   ! Optional Output for 1- and 2-Body Fits
6685 C------------------------------ ! for each event.
6686 C      write(*,*)'Event ', ievent
6687 C      write(*,*)'chisq_total_store(event) ',chisq_total_store(ievent)
6688       write(8,500) ievent
6689       write(8,501) n_part_1_trk,n_part_2_trk,n_part_tot_trk
6690       write(8,502) n_part_used_1_trk, n_part_used_2_trk
6691       write(8,503) num_pairs_like, num_pairs_unlike
6692
6693 CCC   Output one-body distributions for event:
6694
6695       write(8,504)
6696       if(pid(1) .gt. 0) then
6697          nfac1 = float(n_part_used_1_trk)/float(n_part_used_1_ref)
6698          write(8,505) nfac1
6699
6700          write(8,507)
6701          do i = 1,n_pt_bins
6702            ref_print = int(nfac1*float(href1_pt_1(i)))
6703            ref_error = nfac1*sqrt(float(href1_pt_1(i)))
6704            write(8,510) i,hist1_pt_1(i),ref_print,ref_error
6705          end do
6706
6707          write(8,508)
6708          do i = 1,n_phi_bins
6709            ref_print = int(nfac1*float(href1_phi_1(i)))
6710            ref_error = nfac1*sqrt(float(href1_phi_1(i)))
6711            write(8,510) i,hist1_phi_1(i),ref_print,ref_error
6712          end do
6713
6714          write(8,509)
6715          do i = 1,n_eta_bins
6716            ref_print = int(nfac1*float(href1_eta_1(i)))
6717            ref_error = nfac1*sqrt(float(href1_eta_1(i)))
6718            write(8,510) i,hist1_eta_1(i),ref_print,ref_error
6719          end do
6720
6721       end if    !  End PID # 1, One-Body Distribution Output
6722
6723       if(pid(2) .gt. 0) then
6724          nfac2 = float(n_part_used_2_trk)/float(n_part_used_2_ref)
6725          write(8,506) nfac2
6726
6727          write(8,507)
6728          do i = 1,n_pt_bins
6729            ref_print = int(nfac2*float(href1_pt_2(i)))
6730            ref_error = nfac2*sqrt(float(href1_pt_2(i)))
6731            write(8,510) i,hist1_pt_2(i),ref_print,ref_error
6732          end do
6733
6734          write(8,508)
6735          do i = 1,n_phi_bins
6736            ref_print = int(nfac2*float(href1_phi_2(i)))
6737            ref_error = nfac2*sqrt(float(href1_phi_2(i)))
6738            write(8,510) i,hist1_phi_2(i),ref_print,ref_error
6739          end do
6740
6741          write(8,509)
6742          do i = 1,n_eta_bins
6743            ref_print = int(nfac2*float(href1_eta_2(i)))
6744            ref_error = nfac2*sqrt(float(href1_eta_2(i)))
6745            write(8,510) i,hist1_eta_2(i),ref_print,ref_error
6746          end do
6747
6748       end if    !  End PID # 2, One-Body Distribution Output
6749
6750 CCC   Output Two-Body Correlation Functions for Event:
6751
6752       write(8,520)
6753       if(switch_1d.gt.0 .and. n_1d_total.gt.0) then
6754          write(8,530)
6755          write(8,521)
6756          write(8,522)
6757          do i = 1,n_1d_total
6758             write(8,523) i,c2mod_like_1d(i),c2fit_like_1d(i),
6759      1           c2err_like_1d(i),c2mod_unlike_1d(i),
6760      2           c2fit_unlike_1d(i),c2err_unlike_1d(i)
6761          end do
6762       end if    !  End 1D Correlation Model and Fit Output
6763
6764       if(switch_3d.gt.0 .and. n_3d_fine.gt.0) then
6765          write(8,531)
6766          write(8,524)
6767          write(8,525)
6768          do i = 1,n_3d_fine
6769          do j = 1,n_3d_fine
6770          do k = 1,n_3d_fine
6771             write(8,526) i,j,k,c2mod_like_3d_fine(i,j,k),
6772      1      c2fit_like_3d_fine(i,j,k),c2err_like_3d_fine(i,j,k),
6773      2      c2mod_unlike_3d_fine(i,j,k),c2fit_unlike_3d_fine(i,j,k),
6774      3      c2err_unlike_3d_fine(i,j,k)
6775          end do
6776          end do
6777          end do
6778       end if    !  End 3D Fine Mesh Correlation Model and Fit Output
6779
6780       if(switch_3d.gt.0 .and. n_3d_coarse.gt.0) then
6781          write(8,532)
6782          write(8,524)
6783          write(8,525)
6784          do i = 1,n_3d_coarse
6785          do j = 1,n_3d_coarse
6786          do k = 1,n_3d_coarse
6787             write(8,526) i,j,k,c2mod_like_3d_coarse(i,j,k),
6788      1      c2fit_like_3d_coarse(i,j,k),c2err_like_3d_coarse(i,j,k),
6789      2      c2mod_unlike_3d_coarse(i,j,k),c2fit_unlike_3d_coarse(i,j,k),
6790      3      c2err_unlike_3d_coarse(i,j,k)
6791          end do
6792          end do
6793          end do
6794       end if    !  End 3D Coarse Mesh Correlation Model and Fit Output
6795
6796 CCC   Output Event Summary and Chi-Square Information for Event:
6797
6798       write(8,539) ievent
6799       write(8,540) num_iter(ievent)
6800       write(8,541) n_part_used_1_store(ievent),
6801      1             n_part_used_2_store(ievent)
6802       write(8,5411) n_part_tot_store(ievent)
6803       write(8,542) num_sec_flagged_store(ievent)
6804       write(8,543) frac_trks_out(ievent),frac_trks_flag(ievent)
6805       write(8,544) chisq_like_1d_store(ievent),
6806      1             chisq_unlike_1d_store(ievent)
6807       write(8,545) chisq_like_3d_fine_store(ievent),
6808      1             chisq_unlike_3d_fine_store(ievent)
6809       write(8,546) chisq_like_3d_coarse_store(ievent),
6810      1             chisq_unlike_3d_coarse_store(ievent)
6811       write(8,547) chisq_hist1_1_store(ievent),
6812      1             chisq_hist1_2_store(ievent)
6813       write(8,548) chisq_total_store(ievent)
6814
6815 CCC   Formats for Mode = 5 Output:
6816
6817 500   Format(///5x,5('*'),'Fitted 1-Body Distributions and ',
6818      1      'Correlations for Event #',I5,5('*'))
6819 501   Format(//15x,'Number of Particles of PID types 1,2,total = ',
6820      1      3I5)
6821 502   Format(  15x,'Number of Particles of PID types 1,2 Used  = ',
6822      1      2I5)
6823 503   Format(  15x,'Number of Pairs Used - Like and Unlike = ',2I10)
6824 504   Format(//5x,'Fitted and Normalized Reference One-Body ',
6825      1      'Distributions')
6826 505   Format( /10x,'Particle Type 1: Reference Scale Factor = ',E12.5)
6827 506   Format( /10x,'Particle Type 2: Reference Scale Factor = ',E12.5)
6828 507   Format(/2x,' PT: BIN#',5x,'hist1',7x,'href1-scaled',2x,
6829      1       'ref-err-scaled')
6830 508   Format(/2x,'PHI: BIN#',5x,'hist1',7x,'href1-scaled',2x,
6831      1       'ref-err-scaled')
6832 509   Format(/2x,'ETA: BIN#',5x,'hist1',7x,'href1-scaled',2x,
6833      1       'ref-err-scaled')
6834 510   Format(7x,I4,3x,I7,8x,I7,7x,F10.5)
6835 520   Format(//5x,'Model and Fitted Correlations')
6836 530   Format(//21x,'One-Dimensional Fit - Fine & Coarse Mesh')
6837 531   Format(//25x,'Three-Dimensional Fit - Fine Mesh')
6838 532   Format(//24x,'Three-Dimensional Fit - Coarse Mesh')
6839 521   Format(/1x,'BIN',13x,'LIKE PAIRS',27x,'UNLIKE PAIRS')
6840 522   Format(8x,'MOD',9x,'FIT',9x,'ERR',11x,'MOD',9x,'FIT',9x,
6841      1       'ERR',/)
6842 523   Format(1x,I3,3E12.4,2x,3E12.4)
6843 524   Format(/2x,'BINS',12x,'LIKE PAIRS',24x,'UNLIKE PAIRS')
6844 525   Format(1x,' i j k',4x,'MOD',8x,'FIT',8x,'ERR',10x,'MOD',
6845      1      8x,'FIT',8x,'ERR',/)
6846 526   Format(1x,3I2,3E11.4,2x,3E11.4)
6847 539   Format(///10x,'Event and Chi-Square Summary for Event #',I5)
6848 540   Format( //15x,'Number of Iterations             =',F10.2)
6849 541   Format(   15x,'# Particles Used for PID Types1,2=',2F10.2)
6850 5411  Format(   15x,'Total # Particles in track table =',F10.2)
6851 542   Format(   15x,'# Sectors Flagged                =',F10.2)
6852 543   Format(   15x,'Frac Trks Out of Accep., Flagged =',2E11.4)
6853 544   Format(   15x,'Chi-Sq: 1D - Like & Unlike       =',2E11.4)
6854 545   Format(   15x,'Chi-Sq: 3D - Fine -Like & Unlike =',2E11.4)
6855 546   Format(   15x,'Chi-Sq: 3D - Coarse-Like &Unlike =',2E11.4)
6856 547   Format(   15x,'Chi-Sq: One-Body Dist. PID# 1&2  =',2E11.4)
6857 548   Format(   15x,'Chi-Sq: Total Weighted           =',E11.4)
6858
6859 CCC   End Mode = 5 Output and Formats
6860
6861 C------------------------------
6862       Else If(mode.eq.6) Then   ! Inclusive 1 & 2 Body Output
6863 C------------------------------
6864       write(8,600) n_events
6865       write(8,601) n_part_used_1_inc,n_part_used_2_inc
6866       write(8,602) num_pairs_like_inc,num_pairs_unlike_inc
6867
6868       write(8,603)
6869       if(pid(1).gt.0) then
6870 C    Division by zero check
6871         IF (n_part_used_1_ref .LE. 0) THEN
6872          PRINT*,'************************************'
6873          PRINT*,'*        HBT PROCESSOR             *'
6874          PRINT*,'* Number of particles selected for *'
6875          PRINT*,'*   processing is less or equal    *'
6876          PRINT*,'* !!!!!!!!  ZER0  !!!!!!!!!!       *'
6877          PRINT*,'* unable to proceed                *'
6878          PRINT*,'* EXITING FORTRAN                  *'
6879          PRINT*,'*                                  *'
6880          PRINT*,'* HINT: broad the parameter regions*'
6881          PRINT*,'* OR/AND number of particles OR/AND*'
6882          PRINT*,'* number of events                 *'
6883          PRINT*,'************************************'
6884          WRITE(7,5481)
6885 5481     FORMAT(5x,'Number of particles selected for processing is',
6886      1             ' less or equal 0',
6887      2             ' - STOP')
6888          errorcode = 1
6889          Return
6890         END IF
6891         nfac1=float(n_part_used_1_inc)/float(n_part_used_1_ref)
6892         write(8,604) nfac1
6893         write(8,605)
6894         do i = 1,n_pt_bins
6895           ref_print=int(nfac1*float(href1_pt_1(i)))
6896           ref_error=nfac1*sqrt(float(href1_pt_1(i)))
6897           write(8,510) i,hinc1_pt_1(i),ref_print,ref_error
6898         enddo
6899
6900         write(8,606)
6901         do i = 1,n_phi_bins
6902           ref_print=int(nfac1*float(href1_phi_1(i)))
6903           ref_error=nfac1*sqrt(float(href1_phi_1(i)))
6904           write(8,510) i,hinc1_phi_1(i),ref_print,ref_error
6905         enddo
6906
6907         write(8,607)
6908         do i = 1,n_eta_bins
6909           ref_print=int(nfac1*float(href1_eta_1(i)))
6910           ref_error=nfac1*sqrt(float(href1_eta_1(i)))
6911           write(8,510) i,hinc1_eta_1(i),ref_print,ref_error
6912         enddo
6913
6914       endif     !END PID #1  One-BODY INCL. DISTRIBUTION OUTPUT
6915
6916       if(pid(2).gt.0) then
6917         nfac2=float(n_part_used_2_inc)/float(n_part_used_2_ref)
6918         write(8,608) nfac2
6919         write(8,605)
6920         do i = 1,n_pt_bins
6921           ref_print=int(nfac2*float(href1_pt_2(i)))
6922           ref_error=nfac2*sqrt(float(href1_pt_2(i)))
6923           write(8,510) i,hinc1_pt_2(i),ref_print,ref_error
6924         enddo
6925
6926         write(8,606)
6927         do i = 1,n_phi_bins
6928           ref_print=int(nfac2*float(href1_phi_2(i)))
6929           ref_error=nfac2*sqrt(float(href1_phi_2(i)))
6930           write(8,510) i,hinc1_phi_2(i),ref_print,ref_error
6931         enddo
6932
6933         write(8,607)
6934         do i = 1,n_eta_bins
6935           ref_print=int(nfac2*float(href1_eta_2(i)))
6936           ref_error=nfac2*sqrt(float(href1_eta_2(i)))
6937           write(8,510) i,hinc1_eta_2(i),ref_print,ref_error
6938         enddo
6939
6940       endif     !END PID #2  One-BODY INCl. DISTRIBUTION OUTPUT
6941
6942 CC    OUTPUT TWO-BODY INCLUSIVE HISTOGRAMS:
6943
6944       write(8,660)
6945       if(switch_1d.gt.0.and.n_1d_total.gt.0) then
6946          write(8,316)
6947          do i=1,n_1d_total
6948             write(8,307) i,hinc_like_1d(i),hinc_unlike_1d(i)
6949          end do
6950       end if   ! End Print out of 2-Body, 1D Inclusive Histograms
6951
6952       if(switch_3d.gt.0.and.n_3d_fine.gt.0) then
6953          write(8,317)
6954          do i=1,n_3d_fine
6955          do j=1,n_3d_fine
6956          do k=1,n_3d_fine
6957             write(8,318) i,j,k,hinc_like_3d_fine(i,j,k),
6958      1                         hinc_unlike_3d_fine(i,j,k)
6959         enddo
6960         enddo
6961         enddo
6962       endif   ! End Print out of 2-Body, 3D-Fine Inclusive Histograms
6963
6964       if(switch_3d.gt.0.and.n_3d_coarse.gt.0) then
6965          write(8,319)
6966          do i=1,n_3d_coarse
6967          do j=1,n_3d_coarse
6968          do k=1,n_3d_coarse
6969             write(8,318) i,j,k,hinc_like_3d_coarse(i,j,k),
6970      1                         hinc_unlike_3d_coarse(i,j,k)
6971         enddo
6972         enddo
6973         enddo
6974       endif   ! End Print out of 2-Body, 3D-Coarse Inclusive Histograms
6975
6976 CC    OUTPUT TWO-BODY INCL.CORRELATION FUNCTIONS FOR EVENT
6977
6978       write(8,620)
6979       if(switch_1d.gt.0.and.n_1d_total.gt.0) then
6980         write(8,530)
6981         write(8,521)
6982         write(8,522)
6983         do i=1,n_1d_total
6984            write(8,523) i,c2mod_like_1d(i),c2fit_like_1d(i),
6985      1                  c2err_like_1d(i),c2mod_unlike_1d(i),
6986      2                  c2fit_unlike_1d(i),c2err_unlike_1d(i)
6987         enddo
6988       endif
6989
6990       if(switch_3d.gt.0.and.n_3d_fine.gt.0) then
6991         write(8,531)
6992         write(8,524)
6993         write(8,525)
6994         do i=1,n_3d_fine
6995         do j=1,n_3d_fine
6996         do k=1,n_3d_fine
6997            write(8,526) i,j,k,c2mod_like_3d_fine(i,j,k),
6998      1                       c2fit_like_3d_fine(i,j,k),
6999      2                       c2err_like_3d_fine(i,j,k),
7000      3                       c2mod_unlike_3d_fine(i,j,k),
7001      4                       c2fit_unlike_3d_fine(i,j,k),
7002      5                       c2err_unlike_3d_fine(i,j,k)
7003
7004         enddo
7005         enddo
7006         enddo
7007       endif
7008
7009       if(switch_3d.gt.0.and.n_3d_coarse.gt.0) then
7010         write(8,532)
7011         write(8,524)
7012         write(8,525)
7013         do i=1,n_3d_coarse
7014         do j=1,n_3d_coarse
7015         do k=1,n_3d_coarse
7016            write(8,526) i,j,k,c2mod_like_3d_coarse(i,j,k),
7017      1                       c2fit_like_3d_coarse(i,j,k),
7018      2                       c2err_like_3d_coarse(i,j,k),
7019      3                       c2mod_unlike_3d_coarse(i,j,k),
7020      4                       c2fit_unlike_3d_coarse(i,j,k),
7021      5                       c2err_unlike_3d_coarse(i,j,k)
7022
7023         enddo
7024         enddo
7025         enddo
7026       endif
7027
7028 CCC   Compute and Print 1D projections of 3D fine mesh C2 model,
7029 CCC   fit and errors for like and unlike pairs.
7030
7031       if(switch_3d .gt. 0 .and. n_3d_fine .gt. 0) then
7032          if(switch_type .eq. 1 .or. switch_type .eq. 3) then
7033             Call c2_3d_projected(hinc_like_3d_fine,
7034      1         href_like_3d_fine,c2mod_like_3d_fine,
7035      2         c2mod_proj1,c2mod_proj2,c2mod_proj3,
7036      3         c2fit_proj1,c2fit_proj2,c2fit_proj3,
7037      4         c2err_proj1,c2err_proj2,c2err_proj3,
7038      5         max_h_3d, max_c2_3d, n_3d_fine,
7039      6         n_3d_fine_project,num_pairs_like_inc,
7040      7         num_pairs_like_ref)
7041             write(8,650)
7042             write(8,651)
7043             write(8,657)
7044             do i = 1,n_3d_fine
7045              write(8,658) i,c2mod_proj1(i),c2fit_proj1(i),c2err_proj1(i)
7046             end do
7047             write(8,652)
7048             write(8,657)
7049             do i = 1,n_3d_fine
7050              write(8,658) i,c2mod_proj2(i),c2fit_proj2(i),c2err_proj2(i)
7051             end do
7052             write(8,653)
7053             write(8,657)
7054             do i = 1,n_3d_fine
7055              write(8,658) i,c2mod_proj3(i),c2fit_proj3(i),c2err_proj3(i)
7056             end do
7057          end if       !  End Like pair output
7058
7059          if(switch_type .eq. 2 .or. switch_type .eq. 3) then
7060             Call c2_3d_projected(hinc_unlike_3d_fine,
7061      1         href_unlike_3d_fine,c2mod_unlike_3d_fine,
7062      2         c2mod_proj1,c2mod_proj2,c2mod_proj3,
7063      3         c2fit_proj1,c2fit_proj2,c2fit_proj3,
7064      4         c2err_proj1,c2err_proj2,c2err_proj3,
7065      5         max_h_3d, max_c2_3d, n_3d_fine,
7066      6         n_3d_fine_project,num_pairs_unlike_inc,
7067      7         num_pairs_unlike_ref)
7068             write(8,654)
7069             write(8,657)
7070             do i = 1,n_3d_fine
7071              write(8,658) i,c2mod_proj1(i),c2fit_proj1(i),c2err_proj1(i)
7072             end do
7073             write(8,655)
7074             write(8,657)
7075             do i = 1,n_3d_fine
7076              write(8,658) i,c2mod_proj2(i),c2fit_proj2(i),c2err_proj2(i)
7077             end do
7078             write(8,656)
7079             write(8,657)
7080             do i = 1,n_3d_fine
7081              write(8,658) i,c2mod_proj3(i),c2fit_proj3(i),c2err_proj3(i)
7082             end do
7083          end if       !  End Unlike pair output
7084       end if          !  End 1D projections
7085
7086
7087 CCC   EVENT AND CHISQ SUMMARY INFORMATION:
7088
7089       if(n_events.le.max_events) then
7090         nev=n_events
7091       else
7092         nev=max_events
7093       endif
7094
7095       write(8,621)
7096       write(8,622)
7097
7098       do i=1,nev
7099         write(8,623) i,num_iter(i),n_part_used_1_store(i),
7100      1               n_part_used_2_store(i),
7101      2               num_sec_flagged_store(i),
7102      3               frac_trks_out(i),frac_trks_flag(i),
7103      4               chisq_total_store(i)
7104       enddo
7105
7106       write(8,6231) trk_maxlen
7107       write(8,6232)
7108       do i=1,nev
7109         write(8,6233) i,n_part_tot_store(i)
7110       end do
7111
7112       write(8,624)
7113       do i=1,nev
7114         write(8,625) i,chisq_like_1d_store(i),
7115      1               chisq_unlike_1d_store(i)
7116       enddo
7117
7118
7119       write(8,626)
7120       do i=1,nev
7121         write(8,625) i,chisq_like_3d_fine_store(i),
7122      1               chisq_unlike_3d_fine_store(i)
7123       enddo
7124
7125
7126       write(8,627)
7127       do i=1,nev
7128         write(8,625) i,chisq_like_3d_coarse_store(i),
7129      1               chisq_unlike_3d_coarse_store(i)
7130       enddo
7131
7132
7133       write(8,628)
7134       do i=1,nev
7135         write(8,625) i,chisq_hist1_1_store(i),
7136      1                 chisq_hist1_2_store(i)
7137       enddo
7138
7139 CCC   Output the Mean and RMS values for the Event Loop:
7140
7141       write(8,629)
7142       write(8,630)
7143       write(8,631) niter_mean,niter_rms
7144       write(8,632) npart1_mean,npart1_rms
7145       write(8,633) npart2_mean,npart2_rms
7146       write(8,6331) npart_tot_mean, npart_tot_rms
7147       write(8,634) nsec_flag_mean,nsec_flag_rms
7148       write(8,635) frac_trks_out_mean,frac_trks_out_rms
7149       write(8,636) frac_trks_flag_mean,frac_trks_flag_rms
7150       write(8,637) chi_l1d_mean,chi_l1d_rms
7151       write(8,638) chi_u1d_mean,chi_u1d_rms
7152       write(8,639) chi_l3f_mean,chi_l3f_rms
7153       write(8,640) chi_u3f_mean,chi_u3f_rms
7154       write(8,641) chi_l3c_mean,chi_l3c_rms
7155       write(8,642) chi_u3c_mean,chi_u3c_rms
7156       write(8,643) chi_1_1_mean,chi_1_1_rms
7157       write(8,644) chi_1_2_mean,chi_1_2_rms
7158       write(8,645) chi_tot_mean,chi_tot_rms
7159
7160 CCC   FORMATS FOR MODE = 6 OUTPUT
7161
7162  600  format(/// 2x,'FITTED 1-BODY DIST. AND CORRELATIONS ',
7163      1      'FOR INCLUSIVE SUM OF',I5,' EVENTS')
7164  601  format(// 15x,'Inclusive # Particles USED of PID ',
7165      1      'types 1,2=',2I8)
7166  602  format(   15x,'Inclusive # of pairs used; like/unlike=',
7167      1       2I10)
7168  603  format(//  5x,'Inclusive and Normalized Reference ',
7169      1       'One-Body Distributions')
7170  604  format(/  10x,'Inclusive: Particle Type 1 - Reference ',
7171      1       'Scale Factor=',E12.5)
7172  605  format(/   2x,' PT: BIN#',5x,'hinc1',7x,'href1-scaled',2x,
7173      1      'ref-err-scaled')
7174  606  format(/   2x,'PHI: BIN#',5x,'hinc1',7x,'href1-scaled',2x,
7175      1      'ref-err-scaled')
7176  607  format(/   2x,'ETA: BIN#',5x,'hinc1',7x,'href1-scaled',2x,
7177      1      'ref-err-scaled')
7178  608  format(/  10x,'Inclusive: Particle Type 2 - ',
7179      1      'Reference Scale Factor=',E12.5)
7180  620  format(//  5x,'MODEL AND INCLUSIVE FITTED CORRELATIONS')
7181  621  format(// 15x,'Event and Chi-Square Summary Lists')
7182  622  format(/   3x,'event',2x,'#iter',3x,'#PID1',4x,'#PID2',3x,
7183      1      '#sec-flg',3x,'frac-out',4x,'frac-flg',3x,'CHISQ-TOT')
7184  623  format(3x,I5,2x,F6.0,2(1x,F8.0),1x,F9.0,
7185      1           2(1x,F11.8),1x,E11.4)
7186 6231  format(/5x,'Max# tracks allowed in track table = ',I8)
7187 6232  format(/5x,'event',4x,'Tot# trks')
7188 6233  format(5x,I5,F12.2)
7189  624  format(/5x,'event',4x,'CHI_l1d',8x,'CHI_u1d')
7190  626  format(/5x,'event',4x,'CHI_l3f',8x,'CHI_u3f')
7191  627  format(/5x,'event',4x,'CHI_l3c',8x,'CHI_u3c')
7192  628  format(/5x,'event',4x,'CHI_1-1',8x,'CHI_1-2')
7193  625  format(5x,I5,2E15.6)
7194  629  format(// 10x,'Event and Chi-Square Summary - ',
7195      1     'Mean and RMS Values')
7196  630  format(/  14x,'Quantity',15x,'Mean',11x,'RMS')
7197  631  format(    5x,'Number of Iterations      ',2E15.6)
7198  632  format(    5x,'#PID Type 1               ',2E15.6)
7199  633  format(    5x,'#PID Type 2               ',2E15.6)
7200 6331  format(    5x,'Tot # Tracks in Table     ',2E15.6)
7201  634  format(    5x,'#Sectors Flagged          ',2E15.6)
7202  635  format(    5x,'Frac. Trks Out of Accept. ',2E15.6)
7203  636  format(    5x,'Frac. Trks Flagged        ',2E15.6)
7204  637  format(    5x,'CHISQ like 1D             ',2E15.6)
7205  638  format(    5x,'CHISQ unlike 1D           ',2E15.6)
7206  639  format(    5x,'CHISQ like 3D Fine        ',2E15.6)
7207  640  format(    5x,'CHISQ unlike 3D Fine      ',2E15.6)
7208  641  format(    5x,'CHISQ like 3D Coarse      ',2E15.6)
7209  642  format(    5x,'CHISQ unlike 3D Coarse    ',2E15.6)
7210  643  format(    5x,'CHISQ 1 Body #1           ',2E15.6)
7211  644  format(    5x,'CHISQ 1 Body #2           ',2E15.6)
7212  645  format(    5x,'CHISQ Total               ',2E15.6)
7213  650  format(//10x ,'Inclusive Three-Dimensional Projected Fits -',
7214      1       ' Fine Mesh')
7215  651  format( /25x ,'Like Pairs - Axis #1 ')
7216  652  format( /25x ,'Like Pairs - Axis #2 ')
7217  653  format( /25x ,'Like Pairs - Axis #3 ')
7218  654  format( /25x ,'Unlike Pairs - Axis #1 ')
7219  655  format( /25x ,'Unlike Pairs - Axis #2 ')
7220  656  format( /25x ,'Unlike Pairs - Axis #3 ')
7221  657  format(    2x,'BIN#',3x,'Model',8x,'Fit',8x,'Error')
7222  658  format(    3x,I3,3E12.4)
7223  660  format(//  5x,'INCLUSIVE TWO-BODY HISTOGRAMS')
7224
7225 CCC   END MODE = 6 OUTPUT AND FORMATS
7226
7227 C----------------
7228       END IF
7229 C----------------
7230
7231       Return
7232       END
7233
7234 C-----------------------------------------------------------------------
7235
7236
7237       subroutine c2_3d_projected(h,href,c2mod,
7238      1           c2mod_proj1,c2mod_proj2,c2mod_proj3,
7239      2           c2fit_proj1,c2fit_proj2,c2fit_proj3,
7240      3           c2err_proj1,c2err_proj2,c2err_proj3,
7241      4           maxh,maxc2,n,n_proj,num_pairs_sig,
7242      5           num_pairs_bkg)
7243
7244       implicit none
7245
7246 CCC   This Subroutine computes the projected two-body correlation
7247 CCC   function for 3D distributions - fine mesh only; for both the
7248 CCC   correlation model (weighted with the reference histogram) and
7249 CCC   the inclusive correlation fit.
7250 CCC
7251 CCC   Description of Input Variables in the Argument List:
7252 CCC
7253 CCC      h(maxh,maxh,maxh)         = 3D fine mesh inclusive signal histog.
7254 CCC      href(maxh,maxh,maxh)      = 3D fine mesh inclusive background hist.
7255 CCC      c2mod(maxc2,maxc2,maxc2)  = 3D fine mesh correlation model
7256 CCC      maxh       = Dimension of 3D fine mesh histogram arrays
7257 CCC      maxc2      = Dimension of 3D fine mesh correlation function arrays
7258 CCC      n          = Number of bins to use
7259 CCC      n_proj     = Number of bins to integrate in (i,j) to project onto (k)
7260 CCC      num_pairs_sig = # pairs used in signal histogram
7261 CCC      num_pairs_bkg = # pairs used in background histogram
7262 CCC
7263 CCC   Description of Output quantities:
7264 CCC
7265 CCC      c2mod_proj1,2,3(maxc2) = Reference histogram weighted 1D projections
7266 CCC                               of C2 model function along {1,2,3} axes.
7267 CCC      c2fit_proj1,2,3(maxc2) = Fitted 3D correlation function projected
7268 CCC                               onto {1,2,3} axes.
7269 CCC      c2err_proj1,2,3(maxc2) = Error in fitted 3D correlation function
7270 CCC                               projected onto {1,2,3} axes.
7271
7272 CCC   Local Variable Type Declarations:
7273
7274       integer*4 maxh,maxc2,n,n_proj,num_pairs_sig,num_pairs_bkg
7275       integer*4 h(maxh,maxh,maxh),href(maxh,maxh,maxh)
7276       integer*4 i,j,k
7277
7278       real*4 c2mod(maxc2,maxc2,maxc2)
7279       real*4 c2mod_proj1(maxc2),c2mod_proj2(maxc2),c2mod_proj3(maxc2)
7280       real*4 c2fit_proj1(maxc2),c2fit_proj2(maxc2),c2fit_proj3(maxc2)
7281       real*4 c2err_proj1(maxc2),c2err_proj2(maxc2),c2err_proj3(maxc2)
7282       real*4 a,a_error,b,b_error
7283       real*4 sum1n,sum1d,sum2n,sum2d,sum3n,sum3d
7284
7285 CCC   Initialize arrays to zero:
7286
7287       do i = 1,maxc2
7288          c2mod_proj1(i) = 0.0
7289          c2mod_proj2(i) = 0.0
7290          c2mod_proj3(i) = 0.0
7291          c2fit_proj1(i) = 0.0
7292          c2fit_proj2(i) = 0.0
7293          c2fit_proj3(i) = 0.0
7294          c2err_proj1(i) = 0.0
7295          c2err_proj2(i) = 0.0
7296          c2err_proj3(i) = 0.0
7297       end do
7298
7299 CCC   Project Reference spectra (histogram) weighted model correlation:
7300
7301       do i = 1,n
7302          sum1n = 0.0
7303          sum1d = 0.0
7304          sum2n = 0.0
7305          sum2d = 0.0
7306          sum3n = 0.0
7307          sum3d = 0.0
7308          do j = 1,n_proj
7309          do k = 1,n_proj
7310             sum1n = sum1n + c2mod(i,j,k)*float(href(i,j,k))
7311             sum1d = sum1d +              float(href(i,j,k))
7312             sum2n = sum2n + c2mod(k,i,j)*float(href(k,i,j))
7313             sum2d = sum2d +              float(href(k,i,j))
7314             sum3n = sum3n + c2mod(j,k,i)*float(href(j,k,i))
7315             sum3d = sum3d +              float(href(j,k,i))
7316          end do
7317          end do
7318          if(sum1d .le. 0.0) then
7319             c2mod_proj1(i) = 0.0
7320          else
7321             c2mod_proj1(i) = sum1n/sum1d
7322          end if
7323          if(sum2d .le. 0.0) then
7324             c2mod_proj2(i) = 0.0
7325          else
7326             c2mod_proj2(i) = sum2n/sum2d
7327          end if
7328          if(sum3d .le. 0.0) then
7329             c2mod_proj3(i) = 0.0
7330          else
7331             c2mod_proj3(i) = sum3n/sum3d
7332          end if
7333       end do
7334
7335 CCC   Calculate and Project the fitted correlation functions:
7336
7337       do i = 1,n
7338          sum1n = 0.0
7339          sum1d = 0.0
7340          sum2n = 0.0
7341          sum2d = 0.0
7342          sum3n = 0.0
7343          sum3d = 0.0
7344          do j = 1,n_proj
7345          do k = 1,n_proj
7346             sum1n = sum1n + float(h(i,j,k))
7347             sum1d = sum1d + float(href(i,j,k))
7348             sum2n = sum2n + float(h(k,i,j))
7349             sum2d = sum2d + float(href(k,i,j))
7350             sum3n = sum3n + float(h(j,k,i))
7351             sum3d = sum3d + float(href(j,k,i))
7352          end do
7353          end do
7354          if(sum1n .le. 0.0 .or. sum1d .le. 0.0) then
7355             c2fit_proj1(i) = 0.0
7356             c2err_proj1(i) = 1.0
7357          else
7358             a = sum1n/float(num_pairs_sig)
7359             a_error = sqrt(sum1n)/float(num_pairs_sig)
7360             b = sum1d/float(num_pairs_bkg)
7361             b_error = sqrt(sum1d)/float(num_pairs_bkg)
7362             c2fit_proj1(i) = a/b
7363             c2err_proj1(i) = c2fit_proj1(i)*sqrt((a_error/a)**2
7364      1                       + (b_error/b)**2)
7365          end if
7366          if(sum2n .le. 0.0 .or. sum2d .le. 0.0) then
7367             c2fit_proj2(i) = 0.0
7368             c2err_proj2(i) = 1.0
7369          else
7370             a = sum2n/float(num_pairs_sig)
7371             a_error = sqrt(sum2n)/float(num_pairs_sig)
7372             b = sum2d/float(num_pairs_bkg)
7373             b_error = sqrt(sum2d)/float(num_pairs_bkg)
7374             c2fit_proj2(i) = a/b
7375             c2err_proj2(i) = c2fit_proj2(i)*sqrt((a_error/a)**2
7376      1                       + (b_error/b)**2)
7377          end if
7378          if(sum3n .le. 0.0 .or. sum3d .le. 0.0) then
7379             c2fit_proj3(i) = 0.0
7380             c2err_proj3(i) = 1.0
7381          else
7382             a = sum3n/float(num_pairs_sig)
7383             a_error = sqrt(sum3n)/float(num_pairs_sig)
7384             b = sum3d/float(num_pairs_bkg)
7385             b_error = sqrt(sum3d)/float(num_pairs_bkg)
7386             c2fit_proj3(i) = a/b
7387             c2err_proj3(i) = c2fit_proj3(i)*sqrt((a_error/a)**2
7388      1                       + (b_error/b)**2)
7389          end if
7390       end do
7391
7392       Return
7393       END
7394
7395 C----------------------------------------------------------------------
7396
7397 C>>>>>>>>>>>>>>   Piotr, this needs to be replaced with Ali random
7398 C>>>>>>>>>>>>>>>   number generator
7399
7400 *      real*4 function hbtpran(i)
7401 *      implicit none
7402 *      integer i
7403 *      real*4 r
7404 *      Call ranhbtp(r,1,i)
7405 *      hbtpran = r
7406 *      Return
7407 *      END
7408
7409 *      Include 'ranlux2.f'
7410 C----------------------------------------------------------------------
7411
7412
7413
7414