From 18448239f9c07cdc114b8dfd3d47314e8b6d0a2c Mon Sep 17 00:00:00 2001 From: hristov Date: Thu, 27 Sep 2001 16:30:22 +0000 Subject: [PATCH] HBTP code imported (P.Skowronski) --- HBTP/Makefile | 73 + HBTP/common_correlations.inc | 56 + HBTP/common_coulomb.inc | 40 + HBTP/common_event_summary.inc | 56 + HBTP/common_histograms.inc | 111 + HBTP/common_mesh.inc | 89 + HBTP/common_parameters.inc | 132 + HBTP/common_particle.inc | 24 + HBTP/common_sec_track.inc | 29 + HBTP/common_sec_track2.inc | 31 + HBTP/common_track.inc | 56 + HBTP/common_track2.inc | 58 + HBTP/dummyhbtproc.f | 49 + HBTP/hbt_event_processor.f | 7391 +++++++++++++++++++++++++++++++++ HBTP/hbt_particle_st.inc | 13 + HBTP/hbt_sec_track2_st.inc | 21 + HBTP/hbt_sec_track_st.inc | 19 + HBTP/hbt_track2_st.inc | 33 + HBTP/hbt_track_st.inc | 31 + HBTP/ranlux.f | 309 ++ HBTP/ranlux2.f | 316 ++ 21 files changed, 8937 insertions(+) create mode 100644 HBTP/Makefile create mode 100644 HBTP/common_correlations.inc create mode 100644 HBTP/common_coulomb.inc create mode 100644 HBTP/common_event_summary.inc create mode 100644 HBTP/common_histograms.inc create mode 100644 HBTP/common_mesh.inc create mode 100644 HBTP/common_parameters.inc create mode 100644 HBTP/common_particle.inc create mode 100644 HBTP/common_sec_track.inc create mode 100644 HBTP/common_sec_track2.inc create mode 100644 HBTP/common_track.inc create mode 100644 HBTP/common_track2.inc create mode 100644 HBTP/dummyhbtproc.f create mode 100644 HBTP/hbt_event_processor.f create mode 100644 HBTP/hbt_particle_st.inc create mode 100644 HBTP/hbt_sec_track2_st.inc create mode 100644 HBTP/hbt_sec_track_st.inc create mode 100644 HBTP/hbt_track2_st.inc create mode 100644 HBTP/hbt_track_st.inc create mode 100644 HBTP/ranlux.f create mode 100644 HBTP/ranlux2.f diff --git a/HBTP/Makefile b/HBTP/Makefile new file mode 100644 index 00000000000..2808a2278c6 --- /dev/null +++ b/HBTP/Makefile @@ -0,0 +1,73 @@ +############################### HBTPROCESSOR Makefile ############################### + +# Include machine specific definitions + +include $(ALICE_ROOT)/conf/GeneralDef +include $(ALICE_ROOT)/conf/MachineDef.$(ALICE_TARGET) + +PACKAGE = HBTPROCESSOR +MAKEFLAGS = + +# C sources + +CSRCS = + + +# C Objects + +COBJS = $(patsubst %.c,tgt_$(ALICE_TARGET)/%.o,$(CSRCS)) + +##### MACROS ##### + +FSRCS = hbt_event_processor.f +#hbt_event_processor.f + +FOBJS = $(patsubst %.f,tgt_$(ALICE_TARGET)/%.o,$(FSRCS)) + +SRCS = $(FSRCS) $(CSRCS) +OBJS = $(FOBJS) $(COBJS) + +DSRCS = dummyhbtproc.f +#dummyhbtprocessor.f + +DOBJS = $(patsubst %.f,tgt_$(ALICE_TARGET)/%.o,$(DSRCS)) + +# C++ compilation flags + +CXXFLAGS = $(CXXOPTS) $(CLIBCXXOPTS) $(CLIBDEFS) + +# C compilation flags + +CFLAGS = $(COPT) $(CLIBCOPT) $(CLIBDEFS) + +# FORTRAN compilation flags + +FFLAGS = $(FOPT) $(CLIBFOPT) $(CLIBDEFS) + +##### TARGETS ##### + +# Target + +SLIBRARY = $(LIBDIR)/libhbtprocessor.$(SL) $(LIBDIR)/libdummyhbtproc.$(SL) +ALIBRARY = $(LIBDIR)/libhbtprocessor.a $(LIBDIR)/dummyhbtprocessor.a + +default: $(SLIBRARY) + +$(LIBDIR)/libhbtprocessor.$(SL): $(OBJS) +$(LIBDIR)/libdummyhbtproc.$(SL): $(DOBJS) + +depend: $(CSRCS) $(DSRCS) + +TOCLEAN = $(OBJS) $(DOBJS) *Cint.cxx *Cint.h + +############################### General Macros ################################ + +include $(ALICE_ROOT)/conf/GeneralMacros + +############################ Dependencies ##################################### + +-include tgt_$(ALICE_TARGET)/Make-depend + +clean: + rm -f $(SLIBRARY) $(OBJS) $(DOBJS) + diff --git a/HBTP/common_correlations.inc b/HBTP/common_correlations.inc new file mode 100644 index 00000000000..e3104baef1b --- /dev/null +++ b/HBTP/common_correlations.inc @@ -0,0 +1,56 @@ +CCC common/correlations/ +C +C This common block includes the following data: +C +C o Two-Body Correlation Arrays for the following cases: +C - c2mod* = Model +C - c2fit* = Fitted +C - c2err* = Errors for fitted +C +C Where (*) denotes the following cases: +C Like Pairs, 1D dist +C Unlike Pairs, 1D dist +C Like Pairs, 3D dist, Fine Mesh +C Unlike Pairs, 3D dist, Fine Mesh +C Like Pairs, 3D dist, Coarse Mesh +C Unlike Pairs, 3D dist, Coarse Mesh + + integer*4 max_c2_1d, max_c2_3d + parameter (max_c2_1d = 100) + parameter (max_c2_3d = 10) + + common/correlations/ + 1 c2mod_like_1d(max_c2_1d), c2mod_unlike_1d(max_c2_1d), + 2 c2fit_like_1d(max_c2_1d), c2fit_unlike_1d(max_c2_1d), + 3 c2err_like_1d(max_c2_1d), c2err_unlike_1d(max_c2_1d), + 4 c2mod_like_3d_fine(max_c2_3d,max_c2_3d,max_c2_3d), + 5 c2mod_unlike_3d_fine(max_c2_3d,max_c2_3d,max_c2_3d), + 6 c2mod_like_3d_coarse(max_c2_3d,max_c2_3d,max_c2_3d), + 7 c2mod_unlike_3d_coarse(max_c2_3d,max_c2_3d,max_c2_3d), + 4 c2fit_like_3d_fine(max_c2_3d,max_c2_3d,max_c2_3d), + 5 c2fit_unlike_3d_fine(max_c2_3d,max_c2_3d,max_c2_3d), + 6 c2fit_like_3d_coarse(max_c2_3d,max_c2_3d,max_c2_3d), + 7 c2fit_unlike_3d_coarse(max_c2_3d,max_c2_3d,max_c2_3d), + 4 c2err_like_3d_fine(max_c2_3d,max_c2_3d,max_c2_3d), + 5 c2err_unlike_3d_fine(max_c2_3d,max_c2_3d,max_c2_3d), + 6 c2err_like_3d_coarse(max_c2_3d,max_c2_3d,max_c2_3d), + 7 c2err_unlike_3d_coarse(max_c2_3d,max_c2_3d,max_c2_3d) + +CCC Variable Type Declarations: + +CCC One-dimensional Functions: + + real*4 c2mod_like_1d, c2mod_unlike_1d + real*4 c2fit_like_1d, c2fit_unlike_1d + real*4 c2err_like_1d, c2err_unlike_1d + +CCC Three-dimensional Functions: + + real*4 c2mod_like_3d_fine, c2mod_unlike_3d_fine + real*4 c2mod_like_3d_coarse, c2mod_unlike_3d_coarse + real*4 c2fit_like_3d_fine, c2fit_unlike_3d_fine + real*4 c2fit_like_3d_coarse, c2fit_unlike_3d_coarse + real*4 c2err_like_3d_fine, c2err_unlike_3d_fine + real*4 c2err_like_3d_coarse, c2err_unlike_3d_coarse + +CCC END common/correlations/ diff --git a/HBTP/common_coulomb.inc b/HBTP/common_coulomb.inc new file mode 100644 index 00000000000..eeeac7959cb --- /dev/null +++ b/HBTP/common_coulomb.inc @@ -0,0 +1,40 @@ +CCC common/coulmb/ +C +C This common block includes the following data: +C +C o input q mesh (GeV/c) +C o interpolated Coulomb correction for a specified +C Coulomb source size (input as parameter Q0 when +C switch_coulomb = 3) for both like and unlike pairs. +C +C The correction corresponds to John Cramer's tabulation +C of Scott Pratt's Coulomb wave function integration code +C results for finite size spherical sources. The present +C code reads these tables and interpolates to the requested +C source radius. +C +C The input source radii, the number of input files of data +C and the q-space grid are assumed static and are therefore +C hard-coded as follows: + + integer*4 max_c2_coul ! # q-mesh pts for input Coul. correc. + integer*4 ncoulradsteps ! # input radii values (= # files) + parameter (max_c2_coul = 288) + parameter (ncoulradsteps = 7) + + real*4 coulradmin ! min source radius (fm) for Coul Correc. tables + real*4 coulradmax ! max source radius (fm) for Coul Correc. tables + real*4 coulradstep ! Source radius step size for Coul Correc. tables + parameter (coulradmin = 6.0) + parameter (coulradmax = 18.0) + parameter (coulradstep = 2.0) + + common/coulmb/ + 1 c2_coul_like(max_c2_coul),c2_coul_unlike(max_c2_coul), + 2 q_coul(max_c2_coul) + + real*4 c2_coul_like ! Finite source size Coul. correc for like pairs + real*4 c2_coul_unlike ! Finite source size Coul. correc for unlike pairs + real*4 q_coul ! Momentum transfer grid (GeV/c). + +CCC END common/coulmb/ diff --git a/HBTP/common_event_summary.inc b/HBTP/common_event_summary.inc new file mode 100644 index 00000000000..493aea0d931 --- /dev/null +++ b/HBTP/common_event_summary.inc @@ -0,0 +1,56 @@ +CCC common/event_summary/ +C +C This common block includes the following data: +C +C o Event processing summary and diagnostic information +C o Chi-Square values + + integer*4 max_events ! Limit on stored values, this is NOT +C ! a limit on the number of events that +C ! can be processed in the input event +C ! text file. + parameter (max_events = 100) + + common/event_summary/ + 1num_iter(max_events), niter_mean, niter_rms, + 2n_part_used_1_store(max_events), npart1_mean, npart1_rms, + 3n_part_used_2_store(max_events), npart2_mean, npart2_rms, + 4n_part_tot_store(max_events), npart_tot_mean, npart_tot_rms, + 5num_sec_flagged_store(max_events), nsec_flag_mean, nsec_flag_rms, + 6frac_trks_out(max_events), frac_trks_out_mean,frac_trks_out_rms, + 7frac_trks_flag(max_events),frac_trks_flag_mean,frac_trks_flag_rms, + 8chisq_like_1d_store(max_events), chi_l1d_mean,chi_l1d_rms, + 9chisq_unlike_1d_store(max_events), chi_u1d_mean,chi_u1d_rms, + 1chisq_like_3d_fine_store(max_events), chi_l3f_mean,chi_l3f_rms, + 2chisq_unlike_3d_fine_store(max_events), chi_u3f_mean,chi_u3f_rms, + 3chisq_like_3d_coarse_store(max_events), chi_l3c_mean,chi_l3c_rms, + 4chisq_unlike_3d_coarse_store(max_events),chi_u3c_mean,chi_u3c_rms, + 5chisq_hist1_1_store(max_events), chi_1_1_mean, chi_1_1_rms, + 6chisq_hist1_2_store(max_events), chi_1_2_mean, chi_1_2_rms, + 7chisq_total_store(max_events), chi_tot_mean, chi_tot_rms + +CCC Variable Type Declarations: + +CCC Event processing summary and diagnostic information: + + real*4 num_iter, niter_mean, niter_rms + real*4 n_part_used_1_store, npart1_mean, npart1_rms + real*4 n_part_used_2_store, npart2_mean, npart2_rms + real*4 n_part_tot_store, npart_tot_mean, npart_tot_rms + real*4 num_sec_flagged_store, nsec_flag_mean, nsec_flag_rms + real*4 frac_trks_out, frac_trks_out_mean,frac_trks_out_rms + real*4 frac_trks_flag,frac_trks_flag_mean,frac_trks_flag_rms + +CCC Chi-Square values: + + real*4 chisq_like_1d_store, chi_l1d_mean,chi_l1d_rms + real*4 chisq_unlike_1d_store, chi_u1d_mean,chi_u1d_rms + real*4 chisq_like_3d_fine_store, chi_l3f_mean,chi_l3f_rms + real*4 chisq_unlike_3d_fine_store, chi_u3f_mean,chi_u3f_rms + real*4 chisq_like_3d_coarse_store, chi_l3c_mean,chi_l3c_rms + real*4 chisq_unlike_3d_coarse_store,chi_u3c_mean,chi_u3c_rms + real*4 chisq_hist1_1_store, chi_1_1_mean, chi_1_1_rms + real*4 chisq_hist1_2_store, chi_1_2_mean, chi_1_2_rms + real*4 chisq_total_store, chi_tot_mean, chi_tot_rms + +CCC END common/event_summary/ diff --git a/HBTP/common_histograms.inc b/HBTP/common_histograms.inc new file mode 100644 index 00000000000..4ed64eef9d7 --- /dev/null +++ b/HBTP/common_histograms.inc @@ -0,0 +1,111 @@ +CCC common/histograms/ +C +C This common block includes the following data: +C +C o One- and Two-Body Histograms: +C +C One-Body: hist1* - Originally filled and updated after each +C iteration where Chi-Square is improved. +C htmp1* - Working copy used within the track adjustment +C iteration loop +C href1* - Fixed reference distributions obtained from +C event text input file for all events. +C hinc1* - Inclusive event sum of all final, fitted +C one-body distributions +C +C (*) denotes pt,phi,eta and PID#1,2 +C NOTE: The pt,phi,eta distributions are +C projections of the full, 3D dist. +C onto these axes. +C +C Two-Body: hist* - Originally filled and updated after each +C iteration where Chi-Square is improved. +C htmp* - Working copy used within the track adjustment +C iteration loop +C href* - Fixed reference distributions obtained from +C event text input file for all events. +C hinc* - Inclusive event sum of all final, fitted +C two-body distributions +C +C (*) denotes arrays for the following: +C - Like pairs, 1D distributions +C - Unlike pairs, 1D distributions +C - Like pairs, 3D dist., Fine Mesh +C - Unlike pairs, 3D dist., Fine Mesh +C - Like pairs, 3D dist., Coarse Mesh +C - Unlike pairs, 3D dist., Coarse Mesh + + integer*4 max_h_1d, max_h_3d + parameter (max_h_1d = 100) + parameter (max_h_3d = 10 ) + + common/histograms/ + 1 hist1_pt_1(max_h_1d),hist1_phi_1(max_h_1d),hist1_eta_1(max_h_1d), + 2 hist1_pt_2(max_h_1d),hist1_phi_2(max_h_1d),hist1_eta_2(max_h_1d), + 3 htmp1_pt_1(max_h_1d),htmp1_phi_1(max_h_1d),htmp1_eta_1(max_h_1d), + 4 htmp1_pt_2(max_h_1d),htmp1_phi_2(max_h_1d),htmp1_eta_2(max_h_1d), + 5 href1_pt_1(max_h_1d),href1_phi_1(max_h_1d),href1_eta_1(max_h_1d), + 6 href1_pt_2(max_h_1d),href1_phi_2(max_h_1d),href1_eta_2(max_h_1d), + 7 hinc1_pt_1(max_h_1d),hinc1_phi_1(max_h_1d),hinc1_eta_1(max_h_1d), + 8 hinc1_pt_2(max_h_1d),hinc1_phi_2(max_h_1d),hinc1_eta_2(max_h_1d), + 9 hist_like_1d(max_h_1d),hist_unlike_1d(max_h_1d), + 1 htmp_like_1d(max_h_1d),htmp_unlike_1d(max_h_1d), + 2 href_like_1d(max_h_1d),href_unlike_1d(max_h_1d), + 3 hinc_like_1d(max_h_1d),hinc_unlike_1d(max_h_1d), + 4 hist_like_3d_fine(max_h_3d,max_h_3d,max_h_3d), + 5 hist_unlike_3d_fine(max_h_3d,max_h_3d,max_h_3d), + 6 hist_like_3d_coarse(max_h_3d,max_h_3d,max_h_3d), + 7 hist_unlike_3d_coarse(max_h_3d,max_h_3d,max_h_3d), + 4 htmp_like_3d_fine(max_h_3d,max_h_3d,max_h_3d), + 5 htmp_unlike_3d_fine(max_h_3d,max_h_3d,max_h_3d), + 6 htmp_like_3d_coarse(max_h_3d,max_h_3d,max_h_3d), + 7 htmp_unlike_3d_coarse(max_h_3d,max_h_3d,max_h_3d), + 4 href_like_3d_fine(max_h_3d,max_h_3d,max_h_3d), + 5 href_unlike_3d_fine(max_h_3d,max_h_3d,max_h_3d), + 6 href_like_3d_coarse(max_h_3d,max_h_3d,max_h_3d), + 7 href_unlike_3d_coarse(max_h_3d,max_h_3d,max_h_3d), + 4 hinc_like_3d_fine(max_h_3d,max_h_3d,max_h_3d), + 5 hinc_unlike_3d_fine(max_h_3d,max_h_3d,max_h_3d), + 6 hinc_like_3d_coarse(max_h_3d,max_h_3d,max_h_3d), + 7 hinc_unlike_3d_coarse(max_h_3d,max_h_3d,max_h_3d) + +CCC Variable Type Declarations: + +CCC One-Body Distributions: + + integer*4 hist1_pt_1,hist1_phi_1,hist1_eta_1 + integer*4 hist1_pt_2,hist1_phi_2,hist1_eta_2 + integer*4 htmp1_pt_1,htmp1_phi_1,htmp1_eta_1 + integer*4 htmp1_pt_2,htmp1_phi_2,htmp1_eta_2 + integer*4 href1_pt_1,href1_phi_1,href1_eta_1 + integer*4 href1_pt_2,href1_phi_2,href1_eta_2 + integer*4 hinc1_pt_1,hinc1_phi_1,hinc1_eta_1 + integer*4 hinc1_pt_2,hinc1_phi_2,hinc1_eta_2 + +CCC Two-Body Distributions 1D: + + integer*4 hist_like_1d, hist_unlike_1d + integer*4 htmp_like_1d, htmp_unlike_1d + integer*4 href_like_1d, href_unlike_1d + integer*4 hinc_like_1d, hinc_unlike_1d + +CCC Two-Body Distributions 3D: + + integer*4 hist_like_3d_fine + integer*4 hist_unlike_3d_fine + integer*4 hist_like_3d_coarse + integer*4 hist_unlike_3d_coarse + integer*4 htmp_like_3d_fine + integer*4 htmp_unlike_3d_fine + integer*4 htmp_like_3d_coarse + integer*4 htmp_unlike_3d_coarse + integer*4 href_like_3d_fine + integer*4 href_unlike_3d_fine + integer*4 href_like_3d_coarse + integer*4 href_unlike_3d_coarse + integer*4 hinc_like_3d_fine + integer*4 hinc_unlike_3d_fine + integer*4 hinc_like_3d_coarse + integer*4 hinc_unlike_3d_coarse + +CCC END common/histograms/ diff --git a/HBTP/common_mesh.inc b/HBTP/common_mesh.inc new file mode 100644 index 00000000000..7ca8bf19dba --- /dev/null +++ b/HBTP/common_mesh.inc @@ -0,0 +1,89 @@ +CCC common/mesh/ +C +C This common block includes the following data: +C +C o Mesh Bin Definitions for the following: +C i) One-Body distributions in {pt,phi,eta} +C ii) Two-Body Histograms and Correlations for 1D and 3D +C iii) Momentum space sectors for track sorting in {px,py,pz} + + integer*4 max_trk_save + parameter (max_trk_save = 150) + + common/mesh/ + 1 n_pt_bins,n_phi_bins,n_eta_bins, + 2 n_1d_fine,n_1d_coarse,n_1d_total, + 3 n_3d_fine,n_3d_coarse,n_3d_total,n_3d_fine_project, + 4 n_px_bins,n_py_bins,n_pz_bins,n_sectors, + 5 old_sec_ntrk,old_sec_flag,old_sec_trkid(max_trk_save), + 6 new_sec_ntrk,new_sec_flag,new_sec_trkid(max_trk_save), + 7 new_sec_save,old_sec_save, + 8 pt_bin_size,pt_min,pt_max, + 9 phi_bin_size,phi_min,phi_max, + 1 eta_bin_size,eta_min,eta_max, + 2 binsize_1d_fine,binsize_1d_coarse,qmid_1d,qmax_1d, + 3 binsize_3d_fine,binsize_3d_coarse,qmid_3d,qmax_3d, + 4 px_min,px_max,delpx, + 5 py_min,py_max,delpy, + 6 pz_min,pz_max,delpz + +CCC Variable Type Declarations: + +CCC One-Body Mesh: + + integer*4 n_pt_bins ! # one-body pt bins + integer*4 n_phi_bins ! # one-body phi bins + integer*4 n_eta_bins ! # one-body eta bins + real*4 pt_bin_size ! One-body pt bin size in (GeV/c) + real*4 phi_bin_size ! One-body phi bin size in (degrees) + real*4 eta_bin_size ! One-body eta bin size + real*4 pt_min, pt_max ! One-body pt min/max in (GeV/c) + real*4 phi_min, phi_max ! One-body phi min/max in (degrees) + real*4 eta_min, eta_max ! One-body eta min/max + +CCC Two-Body Histograms and Correlation Mesh for 1D and 3D distributions: + + integer*4 n_1d_fine ! # bins for 1D, Fine Mesh + integer*4 n_1d_coarse ! # bins for 1D, Coarse Mesh + integer*4 n_1d_total ! Total # bins for 1D + integer*4 n_3d_fine ! # bins for 3D, Fine Mesh + integer*4 n_3d_coarse ! # bins for 3D, Coarse Mesh + integer*4 n_3d_total ! Total # bins for 3D + integer*4 n_3d_fine_project ! # 3D fine mesh bins to sum over for +C ! projections onto single axis. + + real*4 binsize_1d_fine ! Bin Size - 1D, Fine Mesh in (GeV/c) + real*4 binsize_1d_coarse ! Bin Size - 1D, Coarse Mesh in (GeV/c) + real*4 qmid_1d ! q (GeV/c) at fine-coarse mesh boundary + real*4 qmax_1d ! Max q (GeV/c) for 1D distributions + real*4 binsize_3d_fine ! Bin Size - 3D, Fine Mesh in (GeV/c) + real*4 binsize_3d_coarse ! Bin Size - 3D, Coarse Mesh in (GeV/c) + real*4 qmid_3d ! q (GeV/c) at fine-coarse mesh boundary + real*4 qmax_3d ! Max q (GeV/c) for 3D distributions + +CCC Momentum Space Sectors for Track Sorting: + + integer*4 n_px_bins ! # sector bins in px + integer*4 n_py_bins ! # sector bins in py + integer*4 n_pz_bins ! # sector bins in pz + integer*4 n_sectors ! Total # sectors in 3D momentum space + + real*4 delpx ! Mom. space sector cell size - px(GeV/c) + real*4 delpy ! Mom. space sector cell size - py(GeV/c) + real*4 delpz ! Mom. space sector cell size - pz(GeV/c) + real*4 px_min, px_max ! Sector range in px in GeV/c + real*4 py_min, py_max ! Sector range in py in GeV/c + real*4 pz_min, pz_max ! Sector range in pz in GeV/c + +CCC Temporary Momentum Space Sector information storage during trk adjust. + + integer*4 old_sec_ntrk ! Old sector # tracks + integer*4 old_sec_flag ! Old sector flag value + integer*4 old_sec_trkid ! Old sector track id array + integer*4 old_sec_save ! Old sector ID value + integer*4 new_sec_ntrk ! New sector # tracks + integer*4 new_sec_flag ! New sector flag value + integer*4 new_sec_trkid ! New sector track id array + integer*4 new_sec_save ! New sector ID value + +CCC End common/mesh/ diff --git a/HBTP/common_parameters.inc b/HBTP/common_parameters.inc new file mode 100644 index 00000000000..1dc568e0c24 --- /dev/null +++ b/HBTP/common_parameters.inc @@ -0,0 +1,132 @@ +CCC common/parameters/ +C +C This common block includes the following data: +C +C o Run control switches +C o Correlation model selection switches +C o Correlation model parameters +C o Numbers of particles and pairs of particles +C o Track momentum adjustment parameters +C o Constants and Chi-Square values + + common/parameters/ + 1 ALICE,errorcode, + 2 ref_control,print_full,print_sector_data,n_pid_types,pid(2), + 3 n_events,switch_1d,switch_3d,switch_type,switch_coherence, + 4 switch_coulomb,switch_fermi_bose,n_part_1_trk,n_part_2_trk, + 5 n_part_tot_trk,n_part_1_trk2,n_part_2_trk2,n_part_tot_trk2, + 6 n_part_used_1_trk,n_part_used_2_trk,n_part_used_1_trk2, + 7 n_part_used_2_trk2,n_part_used_1_ref,n_part_used_2_ref, + 8 n_part_used_1_inc,n_part_used_2_inc,num_pairs_like, + 9 num_pairs_unlike,num_pairs_like_ref,num_pairs_unlike_ref, + 1 num_pairs_like_inc,num_pairs_unlike_inc,event_line_counter, + 2 maxit,irand,file10_line_counter, + 3 lambda,R_1d,Rside,Rout,Rlong,Rperp,Rparallel,R0,Q0,deltap, + 4 delchi,pi,rad,hbc,chisq_wt_like_1d,chisq_wt_unlike_1d, + 5 chisq_wt_like_3d_fine,chisq_wt_unlike_3d_fine, + 6 chisq_wt_like_3d_coarse,chisq_wt_unlike_3d_coarse, + 7 chisq_wt_hist1_1,chisq_wt_hist1_2,mass1,mass2,trk_accep + +CCC Variable Type Declarations: + +CCC ALICE specific variables, DATA I/O option and return error code + + integer*4 ALICE ! To I/O from files or AliRoot strucs + integer*4 errorcode ! Processor error code to stop +CCC calculation and return to calling +CCC program. +CCC Run Control and Model Switches: + + integer*4 ref_control ! Select Reference Histograms + integer*4 print_full ! Full print out option - each event + integer*4 print_sector_data ! Print sector overflow diagnostics + integer*4 n_pid_types ! # particle ID types to correlate + integer*4 pid ! Geant particle ID #s, max of 2 types + integer*4 n_events ! # events in input event text file + integer*4 switch_1d ! Include 1D correlations + integer*4 switch_3d ! Include 3D correlations + integer*4 switch_type ! For like, unlike or both PID pairs + integer*4 switch_coherence ! To include incoh/coher mixed source + integer*4 switch_coulomb ! Coulomb correction selection options + integer*4 switch_fermi_bose ! For fermions or bosons + +CCC Numbers of particles and pairs: + + integer*4 n_part_1_trk ! Total # PID #1 in 'trk', all flags + integer*4 n_part_2_trk ! Total # PID #2 in 'trk', all flags + integer*4 n_part_tot_trk ! Total # all part. in 'trk', all flgs + integer*4 n_part_used_1_trk ! # PID#1, used (flag=0) in 'trk' + integer*4 n_part_used_2_trk ! # PID#2, used (flag=0) in 'trk' + + integer*4 n_part_1_trk2 ! Total # PID #1 in 'trk2', all flags + integer*4 n_part_2_trk2 ! Total # PID #2 in 'trk2', all flags + integer*4 n_part_tot_trk2 ! Total # all part. in 'trk2', all flgs + integer*4 n_part_used_1_trk2 ! # PID#1, used (flag=0) in 'trk2' + integer*4 n_part_used_2_trk2 ! # PID#2, used (flag=0) in 'trk2' + + integer*4 n_part_used_1_ref ! # PID#1, used (flag=0) in Reference + integer*4 n_part_used_2_ref ! # PID#2, used (flag=0) in Reference + integer*4 n_part_used_1_inc ! # PID#1, used (flag=0) in Inclusive + integer*4 n_part_used_2_inc ! # PID#2, used (flag=0) in Inclusive + + integer*4 num_pairs_like ! # like pairs used (flag=0) in fit + integer*4 num_pairs_unlike ! # unlike pairs used (flag=0) in fit + integer*4 num_pairs_like_ref ! # like pairs used (flag=0) in Ref. + integer*4 num_pairs_unlike_ref ! # unlike pairs used (flag=0) in Ref. + integer*4 num_pairs_like_inc ! # like pairs used (flag=0) in Incl. + integer*4 num_pairs_unlike_inc ! # unlike pairs used (flag=0) in Incl. + +CCC Counters: + + integer*4 event_line_counter ! Input event text file line counter + integer*4 file10_line_counter ! Output, correlated event text file +CCC ! line counter + +CCC Correlation Model Parameters: + + real*4 lambda ! Chaoticity parameter + real*4 R_1d ! Spherical source radius (fm) + real*4 Rside ! 3D Bertsch-Pratt source 'side' R (fm) + real*4 Rout ! 3D Bertsch-Pratt source 'out' R (fm) + real*4 Rlong ! 3D Bertsch-Pratt source 'long' R (fm) + real*4 Rperp ! 3D YKP source transverse radius (fm) + real*4 Rparallel ! 3D YKP source longitudinal radius(fm) + real*4 R0 ! 3D YKP source emission time durat(fm) + real*4 Q0 ! NA35 Coulomb parameter (GeV/c) or +CCC ! Coul radius for Pratt finite src (fm) + +CCC Search Control Parameters: + + integer*4 maxit ! Max # iterations in track adjustment + real*4 deltap ! Max limit for x,y,z momt shifts(GeV/c) + real*4 delchi ! Min% change in Chi-Sq to stop iterat. + +CCC Chi-Square Values: + + real*4 chisq_wt_like_1d ! 1D, Like pairs + real*4 chisq_wt_unlike_1d ! 1D, Unlike pairs + real*4 chisq_wt_like_3d_fine ! 3D, Like pairs, Fine Mesh + real*4 chisq_wt_unlike_3d_fine ! 3D, Unlike pairs, Fine Mesh + real*4 chisq_wt_like_3d_coarse ! 3D, Like pairs, Coarse Mesh + real*4 chisq_wt_unlike_3d_coarse ! 3D, Unlike pairs, Coarse Mesh + real*4 chisq_wt_hist1_1 ! One-body, particle ID type #1 + real*4 chisq_wt_hist1_2 ! One-body, particle ID type #2 + +CCC Particle Masses: + + real*4 mass1, mass2 ! Particle ID# 1 and 2 masses (GeV) + +CCC Constants: + + integer*4 irand ! Random # starting seed (Def=12345) + real*4 pi, hbc ! PI and h-bar-c (GeV*fm) + real*4 rad ! radian = 180.0/pi +C parameter (pi = 3.141592654) +C parameter (hbc = 0.19732891) + +CCC Random Track Selection Fraction, for low multiplicity particles + + real*4 trk_accep ! ranges from 0.0 -> 1.0 + +CCC END common/parameters/ + diff --git a/HBTP/common_particle.inc b/HBTP/common_particle.inc new file mode 100644 index 00000000000..adcbcbd85fa --- /dev/null +++ b/HBTP/common_particle.inc @@ -0,0 +1,24 @@ +CCC common/particle/ +C +CCC Geant Particle Properties: +CCC (Converted to common block for ALICE application, 12/1/2000) + + Integer*4 part_maxlen + Parameter (part_maxlen = 50) + + common/particle/ + 1 part_id(part_maxlen), + 2 part_charge(part_maxlen), + 3 part_mass(part_maxlen), + 4 part_lifetime(part_maxlen) + + +CCC Variable Type Declarations: + + Integer*4 part_id ! Geant particle ID code number; required +CCC ! to be equal to the row number + Integer*4 part_charge ! Electric charge in units of |e| + Real*4 part_mass ! Rest mass in GeV/c**2 + Real*4 part_lifetime ! Proper lifetime in sec. + +CCC END common/particle/ diff --git a/HBTP/common_sec_track.inc b/HBTP/common_sec_track.inc new file mode 100644 index 00000000000..c2b8cd4c1ff --- /dev/null +++ b/HBTP/common_sec_track.inc @@ -0,0 +1,29 @@ +CCC common/sec_trk_map/ +C +CCC Track-to-Sector Mapping data structure: +CCC (Converted to common block for ALICE application, 12/1/2000) + + Integer*4 max_trk_sec + Integer*4 sec_maxlen + Parameter (max_trk_sec = 150) + Parameter (sec_maxlen = 28000) + + common/sec_trk_map/ + 1 stm_sec_id(sec_maxlen), + 2 stm_n_trk_sec(sec_maxlen), + 3 stm_flag(sec_maxlen), + 4 stm_track_id(max_trk_sec,sec_maxlen) + +CCC Variable Type Declarations: + + Integer*4 stm_sec_id ! unique sector ID number + Integer*4 stm_n_trk_sec ! Number of tracks assigned to sector + Integer*4 stm_flag ! normally=0, if = 1 then more than +CCC ! max_trk_sec tracks could have been +CCC ! assigned to this sector, however the +CCC ! maximum number that can be assigned is +CCC ! max_trk_sec. + Integer*4 stm_track_id ! Foreign keys to tracks in /track/ that +CCC ! are assigned to this sector. + +CCC END common/sec_trk_map/ diff --git a/HBTP/common_sec_track2.inc b/HBTP/common_sec_track2.inc new file mode 100644 index 00000000000..3dd94aa80a6 --- /dev/null +++ b/HBTP/common_sec_track2.inc @@ -0,0 +1,31 @@ +CCC common/sec_trk_map2/ +C +CCC Second Track-to-Sector Mapping data structure: +CCC (Used for building the reference spectrum from the +CCC input event text file.) +CCC (Converted to common block for ALICE application, 12/1/2000) + + Integer*4 max_trk_sec2 + Integer*4 sec_maxlen2 + Parameter (max_trk_sec2 = 150) + Parameter (sec_maxlen2 = 28000) + + common/sec_trk_map2/ + 1 stm2_sec_id(sec_maxlen2), + 2 stm2_n_trk_sec(sec_maxlen2), + 3 stm2_flag(sec_maxlen2), + 4 stm2_track_id(max_trk_sec2,sec_maxlen2) + +CCC Variable Type Declarations: + + Integer*4 stm2_sec_id ! unique sector ID number + Integer*4 stm2_n_trk_sec ! Number of tracks assigned to sector + Integer*4 stm2_flag ! normally=0, if = 1 then more than +CCC ! max_trk_sec tracks could have been +CCC ! assigned to this sector, however the +CCC ! maximum number that can be assigned is +CCC ! max_trk_sec. + Integer*4 stm2_track_id ! Foreign keys to tracks in /track/ that +CCC ! are assigned to this sector. + +CCC END common/sec_trk_map2/ diff --git a/HBTP/common_track.inc b/HBTP/common_track.inc new file mode 100644 index 00000000000..4c3093df054 --- /dev/null +++ b/HBTP/common_track.inc @@ -0,0 +1,56 @@ +CCC common/track/ +C +CCC Track Data Structure: +CCC (Converted to common block for ALICE application, 12/1/2000) + + Integer*4 trk_maxlen + Parameter (trk_maxlen = 25000) + + common/track1/ + 1 trk_id(trk_maxlen), + 2 trk_px_sec(trk_maxlen), + 3 trk_py_sec(trk_maxlen), + 4 trk_pz_sec(trk_maxlen), + 5 trk_sector(trk_maxlen), + 6 trk_flag(trk_maxlen), + 7 trk_out_flag(trk_maxlen), + 8 trk_merge_flag(trk_maxlen), + 9 trk_ge_pid(trk_maxlen), + 1 trk_start_vertex(trk_maxlen), + 2 trk_stop_vertex(trk_maxlen), + 3 trk_event_line(trk_maxlen), + 4 trk_px(trk_maxlen), + 5 trk_py(trk_maxlen), + 6 trk_pz(trk_maxlen), + 7 trk_E(trk_maxlen), + 8 trk_pt(trk_maxlen), + 9 trk_phi(trk_maxlen), + 1 trk_eta(trk_maxlen) + +CCC Variable Type Declarations: + + Integer*4 trk_id ! Track ID number + Integer*4 trk_px_sec ! px sector number + Integer*4 trk_py_sec ! py sector number + Integer*4 trk_pz_sec ! pz sector number + Integer*4 trk_sector ! unique sector ID number + Integer*4 trk_flag ! normally=0,if 1 indicates track assigned +CCC ! to sector with too many tracks, if = 1 +CCC ! then track is not used. See /sec_trk_map/ + Integer*4 trk_out_flag ! flag indicating track in/out of accept. +CCC ! non-zero for track pushed out of accept. + Integer*4 trk_merge_flag ! flag indicating track is merged (not used) + Integer*4 trk_ge_pid ! Geant particle ID code number + Integer*4 trk_start_vertex ! From input event file - track's start vrtx + Integer*4 trk_stop_vertex ! From input event file - track's stop vrtx + Integer*4 trk_event_line ! Line # of track in input event text file + + Real*4 trk_px ! x component of track momentum in GeV/c + Real*4 trk_py ! y component of track momentum in GeV/c + Real*4 trk_pz ! z component of track momentum in GeV/c + Real*4 trk_E ! Total energy of track in GeV + Real*4 trk_pt ! pt of track momentum in GeV/c + Real*4 trk_phi ! azimuthal angle of track in degrees + Real*4 trk_eta ! pseudorapidity of track + +CCC END common/track/ diff --git a/HBTP/common_track2.inc b/HBTP/common_track2.inc new file mode 100644 index 00000000000..7e1c1a77803 --- /dev/null +++ b/HBTP/common_track2.inc @@ -0,0 +1,58 @@ +CCC common/track2/ +C +CCC Second Track Data Structure: +CCC (This one is needed to build the reference spectrum from +CCC the event text input file.) +CCC (Converted to common block for ALICE application, 12/1/2000) + + Integer*4 trk2_maxlen + Parameter (trk2_maxlen = 25000) + + common/track2/ + 1 trk2_id(trk2_maxlen), + 2 trk2_px_sec(trk2_maxlen), + 3 trk2_py_sec(trk2_maxlen), + 4 trk2_pz_sec(trk2_maxlen), + 5 trk2_sector(trk2_maxlen), + 6 trk2_flag(trk2_maxlen), + 7 trk2_out_flag(trk2_maxlen), + 8 trk2_merge_flag(trk2_maxlen), + 9 trk2_ge_pid(trk2_maxlen), + 1 trk2_start_vertex(trk2_maxlen), + 2 trk2_stop_vertex(trk2_maxlen), + 3 trk2_event_line(trk2_maxlen), + 4 trk2_px(trk2_maxlen), + 5 trk2_py(trk2_maxlen), + 6 trk2_pz(trk2_maxlen), + 7 trk2_E(trk2_maxlen), + 8 trk2_pt(trk2_maxlen), + 9 trk2_phi(trk2_maxlen), + 1 trk2_eta(trk2_maxlen) + +CCC Variable Type Declarations: + + Integer*4 trk2_id ! Track ID number + Integer*4 trk2_px_sec ! px sector number + Integer*4 trk2_py_sec ! py sector number + Integer*4 trk2_pz_sec ! pz sector number + Integer*4 trk2_sector ! unique sector ID number + Integer*4 trk2_flag ! normally=0,if 1 indicates track assigned +CCC ! to sector with too many tracks, if = 1 +CCC ! then track is not used. See /sec_trk2_map/ + Integer*4 trk2_out_flag ! flag indicating track in/out of accept. +CCC ! non-zero for track pushed out of accept. + Integer*4 trk2_merge_flag ! flag indicating track is merged (not used) + Integer*4 trk2_ge_pid ! Geant particle ID code number + Integer*4 trk2_start_vertex ! From input event file - track's start vrtx + Integer*4 trk2_stop_vertex ! From input event file - track's stop vrtx + Integer*4 trk2_event_line ! Line # of track in input event text file + + Real*4 trk2_px ! x component of track momentum in GeV/c + Real*4 trk2_py ! y component of track momentum in GeV/c + Real*4 trk2_pz ! z component of track momentum in GeV/c + Real*4 trk2_E ! Total energy of track in GeV + Real*4 trk2_pt ! pt of track momentum in GeV/c + Real*4 trk2_phi ! azimuthal angle of track in degrees + Real*4 trk2_eta ! pseudorapidity of track + +CCC END common/track2/ diff --git a/HBTP/dummyhbtproc.f b/HBTP/dummyhbtproc.f new file mode 100644 index 00000000000..381a2c68134 --- /dev/null +++ b/HBTP/dummyhbtproc.f @@ -0,0 +1,49 @@ + subroutine dd() + + Include 'common_parameters.inc' + Include 'common_mesh.inc' + Include 'common_histograms.inc' + Include 'common_correlations.inc' + Include 'common_coulomb.inc' + Include 'common_event_summary.inc' + Include 'common_track.inc' + Include 'common_track2.inc' + Include 'common_sec_track.inc' + Include 'common_sec_track2.inc' + Include 'common_particle.inc' + + end + +C subroutine parameters() +C end + +C subroutine mesh() +C end + +C subroutine track1() +C end + +C subroutine track2() +C end + +C subroutine sec_trk_map() +C end + +C subroutine sec_trk_map2() +C end + +C subroutine particle() +C end + +C subroutine correlations() +C end + +C subroutine coulmb() +C end + +C subroutine event_summary() +C end + +C subroutine histograms() +C end + diff --git a/HBTP/hbt_event_processor.f b/HBTP/hbt_event_processor.f new file mode 100644 index 00000000000..258e1ea1d9f --- /dev/null +++ b/HBTP/hbt_event_processor.f @@ -0,0 +1,7391 @@ +CCC ******************************************************************** +CCC Modifications for ALICE-ROOT application at CERN - 12/15/2000 +CCC 1. Removed all Fortran Data Structures in favor of labelled +CCC common blocks. The syntax of the structure_variable to +CCC common variable name change is: +CCC In STAR code In ALICE code +CCC A(i).B ==> A_B(i) +CCC A(i).B(j) ==> A_B(j,i) +CCC 2. All remaining references in the comments and write statements +CCC to the data structures are interpreted as applying to the +CCC new common variables. +CCC 3. The UNIX random number generator, ran(), was replaced with +CCC a function which calls a modified version of the CERNLIB +CCC random number generator, ranlux, herein called ranlux2. The +CCC latter allows a user supplied seed value. +CCC 4. Increased the following array sizes for the LHC Pb+Pb design +CCC multiplicity criteria of dN_{ch}/dy = 8000 assuming 80% of +CCC this is pi(+) and pi(-), which are the largest populations +CCC that this code is required to process. +CCC +CCC The following are for the max number of tracks that can be +CCC stored in each sector without overflow: +CCC common_mesh.inc - increased max_trk_save from 30 to 150 +CCC common_sec_track.inc - inc. max_trk_sec from 30 to 150 +CCC common_sec_track2.inc - inc. max_trk_sec2 from 30 to 150 +CCC +CCC The following determine the maximum number of tracks that can +CCC be processed in an event: +CCC common_track.inc - increased trk_maxlen from 6500 to 25000 +CCC common_track2.inc - increased trk2_maxlen from 6500 to 25000 +CCC +C +C DESCRIPTION OF METHOD: +C ===================== +C +C This program produces relativistic heavy-ion collision +C events in which the particle momenta for selected particle ID +C types and for selected kinematic acceptance ranges are randomly +C adjusted such that specified one-body distributions and two-body +C correlation functions are reproduced. The input to the code may +C be a set of events from any STAR event generator, so long as the +C format is in the STAR Geant (GSTAR) text format standard (see +C STAR Note #235). The basic method is similar to that of Metropolis +C et al. and is fully described in Ray and Hoffmann, Phys. Rev. C 54, +C 2582 (1996). Briefly the steps in the algorithm include: +C +C (1) For an initial particle distribution of specified particle +C ID types (maximum of two types allowed) and momentum +C acceptance ranges [given in terms of transverse momentum +C (p_T), azimuthal angle (phi) and pseudorapidity (eta)] the +C momentum vector of one particle is randomly shifted within +C a specified range from its initial value. The shifts are +C done for px, py and pz independently. +C +C (2) New one-body and two-body histograms, as well as the two-body +C correlation function are calculated. +C +C (3) If the random momentum shift results in an improved overall +C chi-square, obtained by comparison with a specified reference +C for the one-body distribution and the two-body correlation +C model, then the new momentum vector is retained. If not, +C then the vector is restored to its starting value. +C +C (4) Steps 1-3 are repeated for each accepted particle in the +C event. +C +C (5) The entire process, steps 1-4, is repeated until either a +C satisfactory fit to the model distributions are obtained or +C the maximum number of iterations is reached. +C +C (6) Once the iterative process is complete, the input event file +C is copied directly to an output event file where the adjusted +C momentum values for the accepted tracks replace that in the +C input file. The event output file is in the GSTAR standard +C text format. This event output file may be processed again +C by this code in order to generate correlations for other +C particle types or for different kinematic ranges. The file +C is suitable for input into the STAR version of Geant-3, called +C GSTAR (STAR Note 235). +C +C In order to reduce cpu demand the particle momenta are sorted into +C momentum space cells or sectors. In forming particle pairs only those +C particles in the same, or adjacent cells are used. For large events +C this vastly reduces the required cpu time. The penalty is that the +C coding becomes more complicated. Much of the present code is devoted +C to the necessary bookeeping chores that must be done in order to +C determine which cell the tracks are in and if they move to new cells +C during the track adjustment procedure. Information about the +C momentum space cells are contained in the data structure /sec_trk_map/. +C +C The sector size must therefore be scaled with the specified correlation +C range. All particles will be paired with all possible partners out +C to Q's equal to the smallest dimension of the momentum space sectors. +C Particle pairs with Q greater than this sector dimension will suffer +C reduced acceptance, finally being completely cut-off for Q ~> 2 times +C the diagonal length thru a sector. +C +C In order to generate momentum correlations for particle types +C having low multiplicity it is necessary for the user to supply this +C code with an artificially enhanced multiplicity along with a track- +C write-output fractional acceptance factor (see input variable +C 'trk_accep'). For example, if the user wants to generate HBT +C correlations for K0-shorts but the assumed multiplicity is too +C low for the present algorithm to work, the user may increase the +C input K0-short multiplicity, for instance by a factor of 5, then +C run the code and set trk_accep = 1/5 = 0.2 in order to randomly +C reject about 80% of the K0-shorts. The track rejection is done +C after the track adjustment procedure is completed. This procedure +C should preserve the built-in correlations in the final output +C event file, although with reduced statistics. +C Another approach for handling low multiplicity events would +C be to combine particles from several events, carry out the track +C adjustment procedure, then separate the tracks into their original +C events. This method must insure that no bias is included due to +C the order of processing the tracks from the first, second, etc. +C events. This latter method, once proven, could be used for +C the low multiplicity particles from any event generator. For +C the present version of the code the low multiplicity HBT studies +C must utilize a Monte Carlo multiplicity generator. +C +C The code may also be used to read in a previously correlated +C set of events and either compute the reference histograms or read in +C the references, and then compute the correlations for each event and +C the inclusive correlations without doing the track momentum adjustment +C procedure. This feature may be used, for example, to study the +C correlations that result in one set of coordinates for events fitted +C to correlations with respect to a different set of coordinates. For +C example, fit the correlations to the Y-K-P form and then evaluate +C the side-out-long correlations, or vice-versa. +C +C TWO-BODY REFERENCE HISTOGRAMS: +C ============================= +C +C In order to calculate the correlations, an uncorrelated two-body +C reference spectrum is needed. The program will calculate this +C quantity by forming pairs of particles from different events in the +C input file. For the particle ID type(s) and momentum acceptance +C the code forms all possible pairs (given the cell substructure) by +C mixing particles from event#1 with those in event#2, then particles +C from event#2 are mixed with particles from event#3, then events 3 +C and 4 are mixed, and so on. In this way ample statistics may be +C achieved for the reference distributions. These reference distributions +C can be written out to file and re-used in subsequent runs. Since +C all events in the input event file are used in generating the +C reference distribution, it is imperative that these events be physically +C similar. +C +C ONE-BODY REFERENCE HISTOGRAMS: +C ============================= +C +C Inclusive sums of the accepted particles for all events in the +C input event file determine the one-body reference distributions. +C These are used to constrain the momentum vector shifts. Although +C the one-body distributions from realistic event generators are fully +C three-dimensional, the present code is restricted to only work with +C the one-dimensional projections onto p_T, phi and eta. In other words, +C the p_T distribution used in this code is formed by integrating +C the particle distributions over (phi,eta) over the momentum acceptance +C range. No particle distribution models are built into the code. +C The one-body reference distributions are either read-in or determined +C from the events in the input event text file. +C +C TWO-BODY CORRELATION MODELS: +C =========================== +C +C The code permits both 1-dimensional and 3-dimensional two-body +C correlation models. These may be fitted separately or simultaneously. +C The source may include a mixture of incoherent and coherent components; +C Coulomb corrections are also included. The general form assumed +C [see Cramer and Kadija, Phys. Rev. C 53, 908 (1996)] is: +C +C C2 = 1 + lambda*(b**2) + 2.0*sqrt(lambda)*[1 - sqrt(lambda)]*b +C +C where lambda is the usual chaoticity parameter. The third term in +C this equation may be turned on or off. Values of lambda < 1.0 may +C be used without the third term being included. For 1-dimensional +C functions b is given by: +C +C b = exp(- Q**2 * R**2 / 2) +C +C where Q is either the invariant 4-momentum difference, the total +C 4-momentum difference (i.e. time-like + space-like) or the +C 3-vector momentum difference. The 3-dimensional functions may be +C of the Bertsch-Pratt ``side-out-longitudinal'' form given by: +C +C b = exp[(- Qside**2 * Rside**2 - Qout**2 * Rout**2 +C - Qlong**2 * Rlong**2)/2] +C +C where the ``out-long'' cross term is omitted. The 3D function may +C also be in the Yano-Koonin-Podgoretski (YKP) form given by (for +C pairs in the A+A c.m. frame): +C +C b = exp[(- Qperp**2 * Rperp**2 - Qparallel**2 * Rparallel**2 +C - Qtime**2 * Rtime**2)/2] +C +C where +C Qperp = transverse momentum difference +C Qparallel = Qlong = p_{1z} - p_{2z} +C Qtime = E_1 - E_2 +C +C The Coulomb correction may be omitted, or included in one of 3 ways: +C +C (1) Point source Gamow factor +C (2) Finite source NA35 model (see Eq.(5) in Z. Phys. C73, 443 +C (1997)) where +C +C Coulomb correction = 1 + [G(q) - 1]*exp(-q/Q0) +C +C and G(q) is the Gamow factor and q is the 3-momentum +C vector difference. +C (3) Finite source, Pratt integrated Coulomb wave function +C integrals, interpolated for a specific source radius +C from John Cramer's tables for discrete source radii. +C +C These Coulomb correction factors multiply the above correlation +C function to give the total correlation function to be fitted for +C charged, like pairs. For charged, unlike pairs only the Coulomb +C (attractive) correlation function is used. +C +C BINNING: +C ======= +C +C Several types of binning are done in the code. The one-body +C distributions are binned in p_t, phi and eta. The full momentum +C space is subdivided into cells or sectors. The 1D and 3D two-body +C distributions are binned into fine and coarse bins, where the fine +C bins occur at the smaller momentum difference range and the coarse +C bins at the larger. For the 3D distributions the (1,1,1) coarse +C bin must coincide with the 3D fine bins. +C +C SUMMARY OF EXTERNAL FILES: +C ========================= +C +C File Unit# File Name Description +C ---------------------------------------------------------------------------- +C 1 hbt_parameters.in Input switches and controls +C 2 event_text.in Event generator output in GSTAR text +C 3 event_line.flags Generated tmp file, input line flags +C 4 event_tracks.select Generated tmp file, accep. tracks flg. +C 7 hbt_log.out Generated log file - error reports +C 8 hbt_simulation.out Generated main output file +C 9 hbt_pair_reference.hist Generated pair ref. histograms +C 10 event_hbt_text.out Gen. correlated event text file +C 11 hbt_singles_reference.hist Gen. one-body ref. histograms +C 12 event_text_aux.in Tmp copy of event_text.in per event +C 14 event_tracks_aux.select Tmp copy of event_tracks.select/event +C 21-27 cpp_*.dat (*=06,08...18) Like pair Pratt Coulomb corrections. +C 31-37 cpm_*.dat (*=06,08...18) Unlike pair Pratt Coulomb corrects. +C ---------------------------------------------------------------------------- +C +C Source of Data for ALICE Application: +C ==================================== +C +C File Unit# File Name For ALICE File or Struc? +C ---------------------------------------------------------------------------- +C 1 hbt_parameters.in Call AliHbtp_ function +C 2 event_text.in Call AliHbtp_ function +C 3 event_line.flags File not used +C 4 event_tracks.select File not used +C 7 hbt_log.out File used as is +C 8 hbt_simulation.out File used as is +C 9 hbt_pair_reference.hist File used as is +C 10 event_hbt_text.out Call AliHbtp_ function +C 11 hbt_singles_reference.hist File used as is +C 12 event_text_aux.in File not used +C 14 event_tracks_aux.select File not used +C 21-27 cpp_*.dat (*=06,08...18) Files are used as is +C 31-37 cpm_*.dat (*=06,08...18) Files are used as is +C ---------------------------------------------------------------------------- +C +C DESCRIPTION OF INPUT PARAMETERS AND SWITCHES (FILE: hbt_parameters.in): +C ====================================================================== +C +C Control Switches: +C ================ +C +C ref_control = 1 to read reference histograms from input files +C = 2 to compute reference histograms by track +C mixing from event pairs in the event input file. +C +C switch_1d = 0 to not compute the 1D two-body correlations. +C = 1 to compute this using Q-invariant +C = 2 to compute this using Q-total +C = 3 to compute this using Q-3-vector +C +C switch_3d = 0 to not compute the 3D two-body correlations. +C = 1 to compute this using the side-out-long form +C = 2 to compute this using the YKP form. +C +C switch_type = 1 to fit only the like pair correlations +C = 2 to fit only the unlike pair correlations +C = 3 to fit both the like and unlike pair correl. +C +C switch_coherence = 0 for purely incoherent source (but can have +C lambda < 1.0) +C = 1 for mixed incoherent and coherent source +C +C switch_coulomb = 0 no Coulomb correction +C = 1 Point source Gamow correction only +C = 2 NA35 finite source size correction +C = 3 Pratt/Cramer finite source size correction; +C interpolated from input tables. +C +C switch_fermi_bose = 1 Boson pairs +C = -1 Fermion pairs +C +C trk_accep = 1.0 all adjusted tracks are written out +C < 1.0 only this fraction, on average, of the +C adjusted tracks are written out. Used for +C low multiplicity events. +C +C print_full = 0 for standard, minimal output +C = 1 for full, comprehensive (large) output for +C each event. +C +C print_sector_data = 0 std. sector occupancy data printed out +C = 1 to print sector occupancy and overflow info. +C +C Particle ID and Search Parameters: +C ================================= +C +C n_pid_types = 1 or 2 only, # particle types to correlate +C +C pid(1), pid(2) = Geant-3 particle ID code numbers +C +C deltap = maximum range for random momentum shifts in +C GeV/c; px,py,pz independent; Def = 0.1 GeV/c. +C +C maxit = maximum # allowed iterations thru all the +C tracks for each event. Default = 50. +C If maxit=0, then calculate the correlations +C for the input set of events without doing the +C track adjustment procedure. +C +C delchi = min % change in total chi-square for which +C the track adjustment iterations may stop, +C Default = 0.1%. +C +C irand = initial random # seed, default = 12345 +C +C Source Function Parameters: +C ========================== +C +C lambda = Chaoticity +C +C R_1d = Spherical source model radius (fm) +C +C Rside,Rout,Rlong = Non-spherical Bertsch-Pratt source model (fm) +C +C Rperp,Rparallel,R0= Non-spherical Yano-Koonin-Podgoretski source +C model (fm). +C +C Q0 = NA35 Coulomb parameter for finite source size +C in (GeV/c) - iff switch_coulomb = 2 +C = Spherical Coulomb source radius in (fm) iff +C switch_coulomb = 3, used to interpolate the +C input Pratt/Cramer discrete Coulomb source +C radii tables. +C +C One-body pT, phi, eta Acceptance Bins: +C ===================================== +C +C n_pt_bins, pt_min, pt_max = # pt bins, min/max pt accept. (GeV/c) +C +C n_phi_bins,phi_min,phi_max = # phi bins, min/max phi accept. (deg.) +C +C n_eta_bins,eta_min,eta_max = # eta bins, min/max eta accept. +C +C [NOTE: For each the maximum # of bins +C must be .le. 100] +C +C Two-body 1D and 3D Correlation Bins: +C =================================== +C +C n_1d_fine, binsize_1d_fine = # and size (GeV/c), 1D - fine mesh +C +C n_1d_coarse,binsize_1d_coarse = # and size (GeV/c), 1D - coarse mesh +C +C n_3d_fine, binsize_3d_fine = # and size (GeV/c), 3D - fine mesh +C +C n_3d_coarse,binsize_3d_coarse = # and size (GeV/c), 3D - coarse mesh +C +C [NOTE: The maximum # of 1D bins (fine +C + coarse) must be .le. 100; +C The maximum # of 3D bins (either +C fine or coarse) must be .le.10). +C For both 1D and 3D there must be +C at least 1 fine bin and 1 coarse +C bin.] +C n_3d_fine_project = # of 3D-fine bins to integrate over +C to form 1D projections. This value +C must be .le. n_3d_fine. +C +C Momentum Space Track-Sector Cells: +C ================================= +C +C n_px_bins,px_min,px_max = #, min,max px bins (GeV/c) +C +C n_py_bins,py_min,py_max = #, min,max py bins (GeV/c) +C +C n_pz_bins,pz_min,pz_max = #, min,max pz bins (GeV/c) +C +C [NOTE: The maximum number of total sectors, +C equal to the product of the x-y-z +C number of cells must be .le. +C sec_maxlen which is defined in the +C /sec_trk_map/ data structure.] +C +C Relative Chi-Square Weights: +C =========================== +C +C chisq_wt_like_1d = 1D, like pairs +C chisq_wt_unlike_1d = 1D, unlike pairs +C chisq_wt_like_3d_fine = 3D, like pairs, fine mesh +C chisq_wt_unlike_3d_fine = 3D, unlike pairs, fine mesh +C chisq_wt_like_3d_coarse = 3D, like pairs, coarse mesh +C chisq_wt_unlike_3d_coarse = 3D, unlike pairs, coarse mesh +C chisq_wt_hist1_1 = summed pt, phi, eta 1-body dist., PID#1 +C chisq_wt_hist1_2 = summed pt, phi, eta 1-body dist., PID#2 +C +C +C FORMAT for hbt_singles_reference.hist: +C ===================================== +C +C The output content for the one-body reference histograms is: +C +C Line 1: n_pid_types,pid(1),pid(2) +C 2: n_pt_bins,pt_min,pt_max +C 3: n_phi_bins,phi_min,phi_max +C 4: n_eta_bins,eta_min,eta_max +C 5: n_part_used_1_ref,n_part_used_2_ref +C +C Then for PID #1: (href1_pt_1(i),i=1,n_pt_bins) +C (One entry per line) (href1_phi_1(i),i=1,n_phi_bins) +C (href1_eta_1(i),i=1,n_eta_bins) +C +C and for PID #2: (href1_pt_2(i),i=1,n_pt_bins) +C (One entry per line) (href1_phi_2(i),i=1,n_phi_bins) +C (href1_eta_2(i),i=1,n_eta_bins) +C +C +C FORMAT for hbt_pair_reference.hist: +C ================================== +C +C The output content for the two-body reference histograms is: +C +C Line 1: n_pid_types,pid(1),pid(2) +C 2: n_pt_bins,pt_min,pt_max +C 3: n_phi_bins,phi_min,phi_max +C 4: n_eta_bins,eta_min,eta_max +C 5: switch_1d,switch_3d,switch_type +C 6: n_1d_fine,n_1d_coarse,n_3d_fine,n_3d_coarse +C 7: binsize_1d_fine,binsize_1d_coarse, +C binsize_3d_fine,binsize_3d_coarse +C 8: num_pairs_like_ref,num_pairs_unlike_ref +C +C The pair distributions (with one entry per line) are: +C +C 1D, like pairs: (href_like_1d(i),i=1,n_1d_total) +C +C 1D, unlike pairs: (href_unlike_1d(i),i=1,n_1d_total) +C +C 3D, like pairs, fine mesh: href_like_3d_fine(i,j,k) ; (i,(j,(k,...))) +C +C 3D, like pairs, coarse mesh: href_like_3d_coarse(i,j,k) ; (i,(j,(k,...))) +C +C 3D, unlike, fine mesh: href_unlike_3d_fine(i,j,k) ; (i,(j,(k,...))) +C +C 3D, unlike, coarse mesh: href_unlike_3d_coarse(i,j,k) ; (i,(j,(k,...))) +C +C************************************************************************* +C************************************************************************* + + SUBROUTINE CTEST + implicit none + + Include 'common_parameters.inc' + Include 'common_mesh.inc' + Include 'common_histograms.inc' + Include 'common_correlations.inc' + Include 'common_coulomb.inc' + + Include 'common_track.inc' + Include 'common_track2.inc' + Include 'common_sec_track.inc' + Include 'common_sec_track2.inc' + Include 'common_particle.inc' + + write(*,*) ' ' + write(*,*) ' ' + write(*,*) ' ' + + write(*,*) 'Input data in Fort' + write(*,*) ' ' + write(*,*) ' ' + write(*,*) ' ' + write(*,*) ' PARAMETERS' + write(*,*) ' ' + write(*,*) 'ref_control',ref_control + write(*,*) 'switch_1d',switch_1d + write(*,*) 'switch_3d',switch_3d + write(*,*) 'switch_type',switch_type + write(*,*) 'switch_coherence',switch_coherence + write(*,*) 'switch_coulomb',switch_coulomb + write(*,*) 'switch_fermi_bose',switch_fermi_bose + write(*,*) 'trk_accep',trk_accep + write(*,*) 'print_full',print_full + write(*,*) 'print_sector_data',print_sector_data + write(*,*) 'n_pid_types',n_pid_types + write(*,*) 'pid(1)', pid(1) + write(*,*) 'pid(2)', pid(2) + write(*,*) 'maxit',maxit + write(*,*) 'irand',irand + write(*,*) 'n_part_1_trk', n_part_1_trk + write(*,*) 'n_part_2_trk ', n_part_2_trk + write(*,*) 'n_part_tot_trk ', n_part_tot_trk + write(*,*) 'n_part_used_1_trk ', n_part_used_1_trk + write(*,*) 'n_part_used_2_trk', n_part_used_2_trk + write(*,*) 'n_part_1_trk2', n_part_1_trk2 + write(*,*) 'n_part_2_trk2', n_part_2_trk2 + write(*,*) 'n_part_tot_trk2', n_part_tot_trk2 + write(*,*) 'n_part_used_1_trk2', n_part_used_1_trk2 + write(*,*) 'n_part_used_2_trk2', n_part_used_2_trk2 + write(*,*) 'n_part_used_1_ref', n_part_used_1_ref + write(*,*) 'n_part_used_2_ref ', n_part_used_2_ref + write(*,*) 'n_part_used_1_inc', n_part_used_1_inc + write(*,*) 'n_part_used_2_inc', n_part_used_2_inc + write(*,*) 'num_pairs_like', num_pairs_like + write(*,*) 'num_pairs_unlike', num_pairs_unlike + write(*,*) 'num_pairs_like_ref ', num_pairs_like_ref + write(*,*) 'num_pairs_like_inc ', num_pairs_like_inc + write(*,*) 'num_pairs_unlike_inc', num_pairs_unlike_inc + write(*,*) 'event_line_counter', event_line_counter + write(*,*) 'file10_line_counter ',file10_line_counter + write(*,*) 'lambda',lambda + write(*,*) 'R_1d ',R_1d + write(*,*) 'Rside',Rside + write(*,*) 'Rout ', Rout + write(*,*) 'Rlong ', Rlong + write(*,*) 'Rperp ', Rperp + write(*,*) 'Rparallel ', Rparallel + write(*,*) 'R0 ', R0 + write(*,*) 'Q0 ', Q0 + write(*,*) 'deltap',deltap + write(*,*) 'delchi',delchi + write(*,*) 'pi ', pi + write(*,*) 'rad ', rad + write(*,*) 'hbc ', hbc + write(*,*) 'chisq_wt_like_1d ', chisq_wt_like_1d + write(*,*) 'chisq_wt_unlike_1d ', chisq_wt_unlike_1d + write(*,*) 'chisq_wt_like_3d_fine ',chisq_wt_like_3d_fine + write(*,*) 'chisq_wt_unlike_3d_fine ', chisq_wt_unlike_3d_fine + write(*,*) 'chisq_wt_like_3d_coarse ', chisq_wt_like_3d_coarse + write(*,*) 'chisq_wt_unlike_3d_coarse',chisq_wt_unlike_3d_coarse + write(*,*) 'chisq_wt_hist1_1 ', chisq_wt_hist1_1 + write(*,*) 'chisq_wt_hist1_2 ', chisq_wt_hist1_2 + write(*,*) ' ' + write(*,*) ' ' + write(*,*) ' ' + write(*,*) ' MESH ' + write(*,*) ' ' + write(*,*) ' n_pt_bins ', n_pt_bins + write(*,*) ' pt_min ', pt_min + write(*,*) ' pt_max ', pt_max + write(*,*) ' n_phi_bins ', n_phi_bins + write(*,*) ' phi_min ', phi_min + write(*,*) ' phi_max ', phi_max + write(*,*) ' n_eta_bins ', n_eta_bins + write(*,*) ' eta_min', eta_min + write(*,*) ' eta_max', eta_max + write(*,*) ' n_1d_fine ', n_1d_fine + write(*,*) ' binsize_1d_fine ',binsize_1d_fine + write(*,*) ' n_1d_coarse ',n_1d_coarse + write(*,*) ' binsize_1d_coarse ', binsize_1d_coarse + write(*,*) ' n_3d_fine ',n_3d_fine + write(*,*) ' binsize_3d_fine ',binsize_3d_fine + write(*,*) ' n_3d_coarse ', n_3d_coarse + write(*,*) ' binsize_3d_coarse ', binsize_3d_coarse + write(*,*) ' n_3d_fine_project ',n_3d_fine_project + write(*,*) ' n_px_bins ',n_px_bins + write(*,*) ' px_min ',px_min + write(*,*) ' px_max ', px_max + write(*,*) ' n_py_bins ', n_py_bins + write(*,*) ' py_min ', py_min + write(*,*) ' py_max', py_max + write(*,*) ' n_pz_bins ',n_pz_bins + write(*,*) ' pz_min ', pz_min + write(*,*) ' pz_max ', pz_max + write(*,*) ' ' + + End + + + + SUBROUTINE HBTPROCESSOR + implicit none + + + Include 'common_parameters.inc' + Include 'common_mesh.inc' + Include 'common_histograms.inc' + Include 'common_correlations.inc' + Include 'common_coulomb.inc' + + Include 'common_track.inc' + Include 'common_track2.inc' + Include 'common_sec_track.inc' + Include 'common_sec_track2.inc' + Include 'common_particle.inc' + +CCC Set Data I/O control for ALICE or Standalone application +C ALICE = 1 ! This is for the ALICE AliRoot application +CCC ALICE = 0 ! This is for the standalone application + +CCC Initialize error code for ALICE application: + errorcode = 0 + +CCC Open Output Files: + + open(unit=7,status='unknown',access='sequential', + 1 name='hbt_log.out') + open(unit=8,status='unknown',access='sequential', + 1 name='hbt_simulation.out') + +CCC Initialize Arrays and Data Structures: + If(ALICE .eq. 1) then +C In fact we not need to call initialization, +C because we can easily assume that is already done + Call alihbtp_initialize + Else If (ALICE .eq. 0) Then + Call initialize + End If + + Write(6,100) +CCC Read Input Controls and Parameters: + Call read_data(1) + If(errorcode .eq. 1) Return + +CCC Setup values and check input parameter ranges and consistency: + Call set_values + If(errorcode .eq. 1) Return + +CCC Produce Basic Output File Header: + Call write_data(1,0) + If(errorcode .eq. 1) Return + + + Write(6,101) +CCC Read Event Input file and fill flag files: + Call read_data(2) + If(errorcode .eq. 1) Return + + Write(6,102) +CCC Get the Reference Histograms and write out if new calculation: + Call getref_hist + If(errorcode .eq. 1) Return + Call write_data(3,0) + If(errorcode .eq. 1) Return + Write(6,103) + + Write(6,104) +CCC Compute the correlation model and print out: + Call correl_model + Call write_data(4,0) + If(errorcode .eq. 1) Return + + Write(6,105) +CCC Carry out the Track Adjustment/Correlation Fitting Procedure: + Call correlation_fit + Write(6,106) + +CCC Final Output of Inclusive Quantities: + Call write_data(6,0) + If(errorcode .eq. 1) Return + +CCC Close Output Files: + close(unit=7) + close(unit=8) + +CCC Formats: +100 Format(5x,'Read Input Controls, Setup values, check input:') +101 Format(5x,'Read Event Input file and fill flag files:') +102 Format(5x,'Get the Reference Histograms:') +103 Format(5x,'Finished with Reference Histograms:') +104 Format(5x,'Compute the correlation model:') +105 Format(5x,'Start Track Adjustment/Correlation Fitting Procedure:') +106 Format(5x,'Finished with Track Fitting Procedure:') + + Return + END + +C------------------------------------------------------------------- + + + subroutine initialize + implicit none + +CCC This subroutine sets all arrays and structures to zero: + + Include 'common_mesh.inc' + Include 'common_histograms.inc' + Include 'common_correlations.inc' + Include 'common_coulomb.inc' + Include 'common_event_summary.inc' + + Include 'common_track.inc' + Include 'common_track2.inc' + Include 'common_sec_track.inc' + Include 'common_sec_track2.inc' + Include 'common_particle.inc' + +CCC Local Variable Type Declarations: + + integer*4 i,j,k + + do i = 1,trk_maxlen + trk_id(i) = 0 + trk_px_sec(i) = 0 + trk_py_sec(i) = 0 + trk_pz_sec(i) = 0 + trk_sector(i) = 0 + trk_flag(i) = 0 + trk_out_flag(i) = 0 + trk_merge_flag(i) = 0 + trk_ge_pid(i) = 0 + trk_start_vertex(i) = 0 + trk_stop_vertex(i) = 0 + trk_event_line(i) = 0 + trk_px(i) = 0.0 + trk_py(i) = 0.0 + trk_pz(i) = 0.0 + trk_E(i) = 0.0 + trk_pt(i) = 0.0 + trk_phi(i) = 0.0 + trk_eta(i) = 0.0 + end do + + do i = 1,trk2_maxlen + trk2_id(i) = 0 + trk2_px_sec(i) = 0 + trk2_py_sec(i) = 0 + trk2_pz_sec(i) = 0 + trk2_sector(i) = 0 + trk2_flag(i) = 0 + trk2_out_flag(i) = 0 + trk2_merge_flag(i) = 0 + trk2_ge_pid(i) = 0 + trk2_start_vertex(i) = 0 + trk2_stop_vertex(i) = 0 + trk2_event_line(i) = 0 + trk2_px(i) = 0.0 + trk2_py(i) = 0.0 + trk2_pz(i) = 0.0 + trk2_E(i) = 0.0 + trk2_pt(i) = 0.0 + trk2_phi(i) = 0.0 + trk2_eta(i) = 0.0 + end do + + do i = 1,sec_maxlen + stm_sec_id(i) = 0 + stm_n_trk_sec(i) = 0 + stm_flag(i) = 0 + do j = 1,max_trk_sec + stm_track_id(j,i) = 0 + end do + end do + + do i = 1,sec_maxlen2 + stm2_sec_id(i) = 0 + stm2_n_trk_sec(i) = 0 + stm2_flag(i) = 0 + do j = 1,max_trk_sec2 + stm2_track_id(j,i) = 0 + end do + end do + + do i = 1,part_maxlen + part_id(i) = 0 + part_charge(i) = 0 + part_mass(i) = 0.0 + part_lifetime(i) = 0.0 + end do + + do i = 1,max_trk_save + old_sec_trkid(i) = 0 + new_sec_trkid(i) = 0 + end do + + do i = 1,max_h_1d + hist_like_1d(i) = 0 + hist_unlike_1d(i) = 0 + htmp_like_1d(i) = 0 + htmp_unlike_1d(i) = 0 + href_like_1d(i) = 0 + href_unlike_1d(i) = 0 + hinc_like_1d(i) = 0 + hinc_unlike_1d(i) = 0 + hist1_pt_1(i) = 0 + hist1_pt_2(i) = 0 + hist1_phi_1(i) = 0 + hist1_phi_2(i) = 0 + hist1_eta_1(i) = 0 + hist1_eta_2(i) = 0 + htmp1_pt_1(i) = 0 + htmp1_pt_2(i) = 0 + htmp1_phi_1(i) = 0 + htmp1_phi_2(i) = 0 + htmp1_eta_1(i) = 0 + htmp1_eta_2(i) = 0 + href1_pt_1(i) = 0 + href1_pt_2(i) = 0 + href1_phi_1(i) = 0 + href1_phi_2(i) = 0 + href1_eta_1(i) = 0 + href1_eta_2(i) = 0 + hinc1_pt_1(i) = 0 + hinc1_pt_2(i) = 0 + hinc1_phi_1(i) = 0 + hinc1_phi_2(i) = 0 + hinc1_eta_1(i) = 0 + hinc1_eta_2(i) = 0 + end do + + do i = 1,max_h_3d + do j = 1,max_h_3d + do k = 1,max_h_3d + hist_like_3d_fine(i,j,k) = 0 + hist_unlike_3d_fine(i,j,k) = 0 + hist_like_3d_coarse(i,j,k) = 0 + hist_unlike_3d_coarse(i,j,k) = 0 + htmp_like_3d_fine(i,j,k) = 0 + htmp_unlike_3d_fine(i,j,k) = 0 + htmp_like_3d_coarse(i,j,k) = 0 + htmp_unlike_3d_coarse(i,j,k) = 0 + href_like_3d_fine(i,j,k) = 0 + href_unlike_3d_fine(i,j,k) = 0 + href_like_3d_coarse(i,j,k) = 0 + href_unlike_3d_coarse(i,j,k) = 0 + hinc_like_3d_fine(i,j,k) = 0 + hinc_unlike_3d_fine(i,j,k) = 0 + hinc_like_3d_coarse(i,j,k) = 0 + hinc_unlike_3d_coarse(i,j,k) = 0 + end do + end do + end do + + do i = 1,max_c2_1d + c2mod_like_1d(i) = 0.0 + c2mod_unlike_1d(i) = 0.0 + c2fit_like_1d(i) = 0.0 + c2fit_unlike_1d(i) = 0.0 + c2err_like_1d(i) = 0.0 + c2err_unlike_1d(i) = 0.0 + end do + + do i = 1,max_c2_3d + do j = 1,max_c2_3d + do k = 1,max_c2_3d + c2mod_like_3d_fine(i,j,k) = 0.0 + c2mod_unlike_3d_fine(i,j,k) = 0.0 + c2mod_like_3d_coarse(i,j,k) = 0.0 + c2mod_unlike_3d_coarse(i,j,k) = 0.0 + c2fit_like_3d_fine(i,j,k) = 0.0 + c2fit_unlike_3d_fine(i,j,k) = 0.0 + c2fit_like_3d_coarse(i,j,k) = 0.0 + c2fit_unlike_3d_coarse(i,j,k) = 0.0 + c2err_like_3d_fine(i,j,k) = 0.0 + c2err_unlike_3d_fine(i,j,k) = 0.0 + c2err_like_3d_coarse(i,j,k) = 0.0 + c2err_unlike_3d_coarse(i,j,k) = 0.0 + end do + end do + end do + + do i = 1,max_c2_coul + c2_coul_like(i) = 0.0 + c2_coul_unlike(i) = 0.0 + q_coul(i) = 0.0 + end do + + do i = 1,max_events + num_iter(i) = 0.0 + n_part_used_1_store(i) = 0.0 + n_part_used_2_store(i) = 0.0 + num_sec_flagged_store(i) = 0.0 + frac_trks_out(i) = 0.0 + frac_trks_flag(i) = 0.0 + chisq_like_1d_store(i) = 0.0 + chisq_unlike_1d_store(i) = 0.0 + chisq_like_3d_fine_store(i) = 0.0 + chisq_unlike_3d_fine_store(i) = 0.0 + chisq_like_3d_coarse_store(i) = 0.0 + chisq_unlike_3d_coarse_store(i) = 0.0 + chisq_hist1_1_store(i) = 0.0 + chisq_hist1_2_store(i) = 0.0 + chisq_total_store(i) = 0.0 + end do + + Return + END + +C--------------------------------------------------------------------- + + + subroutine set_values + implicit none + +CCC This subroutine sets parameters based on the main input. +CCC The consistency of the input parameters and controls is +CCC checked. Any problems are reported in the Log File, +CCC 'hbt_log.out'. Most inconsistencies or array size limit +CCC overflows will cause the code execution to STOP. + + Include 'common_parameters.inc' + Include 'common_mesh.inc' + Include 'common_histograms.inc' + Include 'common_correlations.inc' + Include 'common_coulomb.inc' + + Include 'common_track.inc' + Include 'common_track2.inc' + Include 'common_sec_track.inc' + Include 'common_sec_track2.inc' + Include 'common_particle.inc' + +CCC Local Variable Type Declarations: + + integer*4 iphistep, ptmaxsteps, iptstep + + real*4 px1,py1,pz1,E1, pt1,phi1 + real*4 px2,py2,pz2,E2 + real*4 pt_step,phi_step + real*4 pxstepmin, pxstepmax, pystepmin, pystepmax + +CCC Check Input Controls: + + if(ref_control .lt. 1 .or. ref_control .gt. 2) then + write(7,101) ref_control + errorcode = 1 + Return + end if + + if(switch_1d .lt. 0 .or. switch_1d .gt. 3) then + write(7,102) switch_1d + errorcode = 1 + Return + end if + + if(switch_3d .lt. 0 .or. switch_3d .gt. 2) then + write(7,103) switch_3d + errorcode = 1 + Return + end if + + if(switch_type .lt. 1 .or. switch_type .gt. 3) then + write(7,104) switch_type + errorcode = 1 + Return + end if + + if(switch_coherence .lt. 0 .or. switch_coherence .gt. 1) then + write(7,105) switch_coherence + errorcode = 1 + Return + end if + + if(switch_coulomb .lt. 0 .or. switch_coulomb .gt. 3) then + write(7,106) switch_coulomb + errorcode = 1 + Return + end if + + if(switch_fermi_bose.ne.-1 .and. switch_fermi_bose.ne.1) then + write(7,107) switch_fermi_bose + errorcode = 1 + Return + end if + + if(n_pid_types .lt. 1 .or. n_pid_types .gt. 2) then + write(7,108) n_pid_types + errorcode = 1 + Return + end if + + if(switch_type .ge. 2 .and. n_pid_types .eq. 1) then + write(7,109) switch_type, n_pid_types + errorcode = 1 + Return + end if + + if(n_pid_types .eq. 1) then + if(pid(1).gt.0 .and. pid(2).gt.0) then + write(7,1091) pid(1),pid(2) + errorcode = 1 + Return + end if + end if + + if(pid(1).eq.0 .and. pid(2).eq.0) then + write(7,1092) + errorcode = 1 + Return + end if + + if(n_pid_types .eq. 2) then + if(pid(1).gt.0.and.pid(2).gt.0.and.pid(1).ne.pid(2))then + continue + else + write(7,1093) pid(1), pid(2) + errorcode = 1 + Return + end if + end if + + if(pid(1).gt.0.and.pid(2).gt.0.and.pid(1).eq.pid(2))then + write(7,1094) pid(1), pid(2) + errorcode = 1 + Return + end if + + if(trk_accep .le. 0.0) then + write(7,10941) trk_accep + errorcode = 1 + Return + + end if + +CCC Check Input Parameters: + + if(deltap .le. 0.0) deltap = 0.1 + if(maxit .lt. 0 ) maxit = 50 + if(delchi .lt. 0.0) delchi = 0.1 + if(irand .le. 0 ) irand = 12345 + +CCC Check Coulomb source radius in range for Pratt type Coulomb correction. + + if(switch_coulomb .eq. 3 .and. (Q0 .lt. coulradmin .or. + 1 Q0 .gt. coulradmax)) then + write(7,132) Q0 + errorcode = 1 + Return + end if + +CCC Load the Pratt type Coulomb correction if this form is selected. + + if(switch_coulomb .eq. 3 .and. (Q0 .ge. coulradmin .and. + 1 Q0 .le. coulradmax)) then + Call read_data(6) + end if + +CCC Check and determine the one-body distribution's binning: + + if(n_pt_bins .lt. 1 .or. n_pt_bins .gt. max_h_1d) then + write(7,110) n_pt_bins + errorcode = 1 + Return + end if + + if(n_phi_bins .lt. 1 .or. n_phi_bins .gt. max_h_1d) then + write(7,111) n_phi_bins + errorcode = 1 + Return + end if + + if(n_eta_bins .lt. 1 .or. n_eta_bins .gt. max_h_1d) then + write(7,112) n_eta_bins + errorcode = 1 + Return + end if + + if(pt_min .gt. pt_max .or. pt_min .lt. 0.0) then + write(7,113) pt_min, pt_max + errorcode = 1 + Return + end if + + if(phi_min.gt.phi_max .or. phi_min.lt.0.0 .or. + 1 phi_max.gt.360.0) then + write(7,114) phi_min, phi_max + errorcode = 1 + Return + end if + + if(eta_min .gt. eta_max) then + write(7,115) eta_min, eta_max + errorcode = 1 + Return + end if + + pt_bin_size = (pt_max - pt_min )/float(n_pt_bins) + phi_bin_size = (phi_max - phi_min)/float(n_phi_bins) + eta_bin_size = (eta_max - eta_min)/float(n_eta_bins) + +CCC Check and determine the two-body distribution's binning: + + n_1d_total = n_1d_fine + n_1d_coarse + n_3d_total = n_3d_fine + n_3d_coarse - 1 + + if(switch_1d .gt. 0) then + if(n_1d_fine .lt. 1) then + write(7,116) n_1d_fine + errorcode = 1 + Return + end if + + if(n_1d_coarse .lt. 1) then + write(7,117) n_1d_coarse + errorcode = 1 + Return + end if + + if(n_1d_total .gt. max_h_1d) then + write(7,118) n_1d_total + errorcode = 1 + Return + end if + + qmid_1d = binsize_1d_fine *float(n_1d_fine) + qmax_1d = binsize_1d_coarse*float(n_1d_coarse) + qmid_1d + end if + + if(switch_3d .gt. 0) then + if(n_3d_fine .lt. 1 .or. n_3d_fine .gt. max_h_3d) then + write(7,119) n_3d_fine + errorcode = 1 + Return + end if + + if(n_3d_coarse .lt. 1 .or. n_3d_coarse .gt. max_h_3d) then + write(7,120) n_3d_coarse + errorcode = 1 + Return + end if + + qmid_3d = binsize_3d_fine *float(n_3d_fine) + qmax_3d = binsize_3d_coarse*float(n_3d_coarse) + + if(abs(qmid_3d - binsize_3d_coarse) .gt. 0.00001) then + write(7,121) qmid_3d, binsize_3d_coarse + errorcode = 1 + Return + end if + + if(n_3d_fine_project .gt. n_3d_fine) then + write(7,1211) n_3d_fine_project, n_3d_fine + n_3d_fine_project = n_3d_fine + end if + + if(n_3d_fine_project .lt. 1) then + write(7,1212) n_3d_fine_project + n_3d_fine_project = 1 + end if + end if + +CCC Check and determine Track-Sector Parameters: + + if(n_px_bins .lt. 1) then + write(7,122) n_px_bins + errorcode = 1 + Return + end if + + if(n_py_bins .lt. 1) then + write(7,123) n_py_bins + errorcode = 1 + Return + end if + + if(n_pz_bins .lt. 1) then + write(7,124) n_pz_bins + errorcode = 1 + Return + end if + + n_sectors = n_px_bins * n_py_bins * n_pz_bins + if(n_sectors .gt. sec_maxlen) then + write(7,125) n_sectors + errorcode = 1 + Return + end if + + if(n_sectors .gt. sec_maxlen2 .and. ref_control .eq. 2) then + write(7,1251) n_sectors + errorcode = 1 + Return + end if + + if(trk_maxlen .ne. trk2_maxlen .and. ref_control .eq. 2) then + write(7,1252) + errorcode = 1 + Return + end if + + if(max_trk_save .ne. max_trk_sec .or. + 1 max_trk_save .ne. max_trk_sec2 .or. + 2 max_trk_sec .ne. max_trk_sec2) then + write(7,12521) max_trk_save,max_trk_sec,max_trk_sec2 + errorcode = 1 + Return + end if + + delpx = (px_max - px_min)/float(n_px_bins) + delpy = (py_max - py_min)/float(n_py_bins) + delpz = (pz_max - pz_min)/float(n_pz_bins) + +CCC Check that the Track-Sector Grid includes the acceptance range: +CCC The Track-Sector Grid is a 3D {px,py,pz} box, while the acceptance +CCC is defined in cylindrical {pt,phi,eta} coordinates. +CCC +CCC Check the z-momentum components: + + if(eta_min .ge. 0.0) then + Call Hbtp_kin(px1,py1,pz1,E1,pt_min,0.0,eta_min,0.14,2) + Call Hbtp_kin(px2,py2,pz2,E2,pt_max,0.0,eta_max,0.14,2) + else if(eta_max .le. 0.0) then + Call Hbtp_kin(px1,py1,pz1,E1,pt_max,0.0,eta_min,0.14,2) + Call Hbtp_kin(px2,py2,pz2,E2,pt_min,0.0,eta_max,0.14,2) + else if(eta_min .le. 0.0 .and. eta_max .ge. 0.0) then + Call Hbtp_kin(px1,py1,pz1,E1,pt_max,0.0,eta_min,0.14,2) + Call Hbtp_kin(px2,py2,pz2,E2,pt_max,0.0,eta_max,0.14,2) + end if + + if(pz1 .lt. pz_min .or. pz2 .gt. pz_max) then + write(7,126) pz1,pz_min,pz2,pz_max + errorcode = 1 + Return + end if + +CCC Check the x,y-momentum components by scanning over the perimeter +CCC of the (pt,phi) acceptance domain space with 100 trial grid points. +CCC The overall required px_min, px_max, py_min and py_max to cover the +CCC acceptance by the track-sectors is determined. These values are +CCC then compared with the min/max px and py ranges for the track-sectors. +CCC +CCC Divide the pt and phi acceptance ranges into 24 equal steps: + + pt_step = (pt_max - pt_min)/24.0 + phi_step = (phi_max - phi_min)/24.0 + pxstepmax = -1000. + pxstepmin = 1000. + pystepmax = -1000. + pystepmin = 1000. + phi1 = phi_min - phi_step + do iphistep = 1,25 + phi1 = phi1 + phi_step + ptmaxsteps = 2 + if(iphistep.eq.1 .or. iphistep.eq.25) ptmaxsteps = 25 + pt1 = pt_min - pt_step + do iptstep = 1,ptmaxsteps + if(iphistep.eq.1 .or. iphistep.eq.25) then + pt1 = pt1 + pt_step + else if(iphistep.gt.1 .and. iphistep.lt.25) then + if(iptstep.eq.1) pt1 = pt_min + if(iptstep.eq.2) pt1 = pt_max + end if + Call Hbtp_kin(px1,py1,pz1,E1,pt1,phi1,0.0,0.14,2) + if(px1.gt.pxstepmax) pxstepmax = px1 + if(px1.lt.pxstepmin) pxstepmin = px1 + if(py1.gt.pystepmax) pystepmax = py1 + if(py1.lt.pystepmin) pystepmin = py1 + end do + end do + + if(pxstepmin .lt. px_min .or. pxstepmax .gt. px_max) then + write(7,127) pxstepmin,px_min,pxstepmax,px_max + errorcode = 1 + Return + end if + + if(pystepmin .lt. py_min .or. pystepmax .gt. py_max) then + write(7,128) pystepmin,py_min,pystepmax,py_max + errorcode = 1 + Return + end if + +CCC Load Geant Particle Data: + Call Hbtp_particle_prop + +CCC Check Requested Particle ID Numbers: + + if(n_pid_types.eq.1 .and. pid(1).le.0 .and. pid(2).le.0) then + write(7,131) pid(1),pid(2) + errorcode = 1 + Return + end if + +CCC Initialize Masses to 0.0 + + mass1 = 0.0 + mass2 = 0.0 + + if(n_pid_types .eq. 1 .and. pid(1) .ne. 0) then + if(pid(1) .lt. 1 .or. pid(1) .gt. part_maxlen) then + write(7,129) pid(1) + errorcode = 1 + Return + else + mass1 = part_mass(pid(1)) + end if + else if(n_pid_types .eq. 1 .and. pid(2) .ne. 0) then + if(pid(2) .lt. 1 .or. pid(2) .gt. part_maxlen) then + write(7,130) pid(2) + errorcode = 1 + Return + else + mass2 = part_mass(pid(2)) + end if + else if(n_pid_types .eq. 2) then + if(pid(1) .lt. 1 .or. pid(1) .gt. part_maxlen) then + write(7,129) pid(1) + errorcode = 1 + Return + else + mass1 = part_mass(pid(1)) + end if + if(pid(2) .lt. 1 .or. pid(2) .gt. part_maxlen) then + write(7,130) pid(2) + errorcode = 1 + Return + else + mass2 = part_mass(pid(2)) + end if + end if + +CCC Set Math Constants: + + pi = 3.141592654 + hbc = 0.19732891 + rad = 180.0/pi + +CCC FORMATS: + +101 Format(5x,'ref_control = ',I5,'Out of Range - STOP') +102 Format(5x,'switch_1d = ',I5,'Out of Range - STOP') +103 Format(5x,'switch_3d = ',I5,'Out of Range - STOP') +104 Format(5x,'switch_type = ',I5,'Out of Range - STOP') +105 Format(5x,'switch_coherence = ',I5,'Out of Range - STOP') +106 Format(5x,'switch_coulomb = ',I5,'Out of Range - STOP') +107 Format(5x,'switch_fermi_bose = ',I5,'Out of Range - STOP') +108 Format(5x,'n_pid_types = ',I5,'Out of Range - STOP') +109 Format(5x,'switch_type & n_pid_types = ',2I5, + 1 'Incompatible - STOP') +1091 Format(5x,'For n_pid_types=1, cannot have both PID#1,2 = ', + 1 2I5,' .ne.0 - STOP') +1092 Format(5x,'Both PID# 1 and 2 = 0, - STOP') +1093 Format(5x,'For n_pid_types=2, PID#1,2 = ',2I5, + 1 ' are incorrect - STOP') +1094 Format(5x,'Both PID# 1,2 = ',2I5,' are equal - STOP') +10941 Format(5x,'Track acceptance output frac .le. 0.0 - STOP') +132 Format(5x,'Coulomb source radius = ',E12.4,' - For Pratt ', + 1 'Correction, Out of Range - STOP') +110 Format(5x,'# pt bins = ',I5,'Out of Range - STOP') +111 Format(5x,'# phi bins = ',I5,'Out of Range - STOP') +112 Format(5x,'# eta bins = ',I5,'Out of Range - STOP') +113 Format(5x,'pt min/max accept. range = ',2E12.4,' is wrong-STOP') +114 Format(5x,'phi min/max accept. range = ',2E12.4,' is wrong-STOP') +115 Format(5x,'eta min/max accept. range = ',2E12.4,' is wrong-STOP') +116 Format(5x,'# 1d fine mesh for C2 = ',I5,' .lt.1 - STOP') +117 Format(5x,'# 1d coarse mesh for C2 = ',I5,' .lt.1 - STOP') +118 Format(5x,'Total # 1d mesh for C2 = ',I5,' .gt.max_h_1d - STOP') +119 Format(5x,'# 3d fine mesh for C2 = ',I5,'Out of Range - STOP') +120 Format(5x,'# 3d coarse mesh for C2 = ',I5,'Out of Range - STOP') +121 Format(5x,'3D C2 fine range & coarse grid = ',2E12.4, + 1 'Not Equal - STOP') +1211 Format(5x,'# 3D fine bins projected = ',I5, + 1 ' TOO BIG - reduce to n_3d_fine = ',I5) +1212 Format(5x,'# 3D fine bins projected = ',I5, + 1 ' Set to 1') +122 Format(5x,'#track-sector px bins = ',I5,' .lt.1 - STOP') +123 Format(5x,'#track-sector py bins = ',I5,' .lt.1 - STOP') +124 Format(5x,'#track-sector pz bins = ',I5,' .lt.1 - STOP') +125 Format(5x,'Total # trk-sec = ',I5,' .gt.sec_maxlen - STOP') +1251 Format(5x,'Total # trk-sec = ',I5,' .gt.sec_maxlen2 for ', + 1 'Reference calc. - STOP') +1252 Format(5x,'trk_maxlen .ne. trk2_maxlen for Ref. Calc. - STOP') +12521 Format(5x,'max_trk_save,max_trk_sec,max_trk_sec2 = ', + 1 3I5,' are not all equal - STOP') +126 Format(5x,'pz accept. not covered by sectors-STOP:',4E12.4) +127 Format(5x,'px accept. not covered by sectors-STOP:',4E12.4) +128 Format(5x,'py accept. not covered by sectors-STOP:',4E12.4) +131 Format(5x,'Particle ID values = ',2I5,' not valid - STOP') +129 Format(5x,'Particle ID value #1 = ',I5,' not valid - STOP') +130 Format(5x,'Particle ID value #2 = ',I5,' not valid - STOP') + + Return + END + +C---------------------------------------------------------------------- + + + subroutine read_data(mode) + implicit none + +CCC This subroutine does all the data input associated with all input +C files. Some diagnostic output is printed here if errors occur +C during the file reading. Two auxiliary output files, which tag +C the events input tracks are written out. +C +C The type of input is controlled by the value of 'mode' +C where: +C (The following mostly applies to the standalone application +C that reads from files and writes temporary scratch files. +C This is the ALICE=0 mode.) +C +C mode = 1, read the parameter and switches input file +C +C mode = 2, scan the event text file and write out two +C auxiliary output/tag files; select and mark +C accepted tracks to use. +C +C mode = 3, read the reference pair and one-body histograms +C +C mode = 4, read the next event from the event text file, +C 'event_text.in,' and load the accepted tracks +C into the 'trk' data structure. +C +C mode = 5, same as mode=4, except the accepted tracks are +C loaded into the 'trk2' data structure. +C +C mode = 6, read the input Coulomb correction tables and +C interpolate for the requested source radius, arrays +C in common/coulomb/ are filled for like and unlike +C charged pairs. +C +C mode = 7, read the next event from the event text file, +C 'event_text.in,' and load the accepted tracks +C into the 'trk' data structure. Then copy the event +C data in 'event_text.in' to 'event_text_aux.in' and +C from 'event_tracks.select' to 'event_tracks_aux.select' +C +C mode = 8, read contents of 'event_text_aux.in' using flag values +C in 'event_tracks_aux.select' and copy into +C 'event_hbt_text.out' (i.e. the main event output file) +C where the momentum values for accepted tracks are +C overwritten with the adjusted (correlated) parameters +C in the 'trk' data structure. +C +C If trk_accep .lt. 1.0, then only write this fraction +C of the final tracks, as determined by a random number +C throw. +C +C Summary of Files: +C ---------------- +C +C File Unit # Filename Description +C --------------------------------------------------------------------------- +C 1 hbt_parameters.in Input switches, parameters +C 2 event_text.in Event Gen output, GSTAR text format +C 3 event_line.flags Event file line flags +C 4 event_tracks.select Event file selected tracks +C 7 hbt_log.out Log and error messages +C 8 hbt_simulation.out Full Output +C 9 hbt_pair_reference.hist Reference pair histograms +C 10 event_hbt_text.out Updated/correlated event text file +C 11 hbt_singles_reference.hist Reference one-body histograms +C 12 event_text_aux.in Tmp. copy of 'event_text.in'/event +C 14 event_tracks_aux.select Tmp. copy 'event_tracks.select'/event +C 21-27 cpp_*.dat (*=06,08,...18) Like pair Pratt Coul. Correct +C 31-37 cpm_*.dat (*=06,08,...18) Unlike pair Pratt Coul. Correct +C --------------------------------------------------------------------------- +C + + Include 'common_parameters.inc' + Include 'common_mesh.inc' + Include 'common_histograms.inc' + Include 'common_correlations.inc' + Include 'common_coulomb.inc' + + Include 'common_track.inc' + Include 'common_track2.inc' + Include 'common_particle.inc' + + integer LNBLNK + +CCC Local Variable Type Declarations: + + real*4 px,py,pz,E,pt,phi,eta,mass + real*4 acheck(10), function(20) + real*4 hbtpran + + integer*4 i,j,k,mode,flag,flag4,flag0,ntracks + integer*4 ge_pid,tid,start_v,stop_v,eg_pid + integer*4 ref_check,pidok,accepok,check(13) + integer*4 event_counter,track_counter + integer*4 track_counter_1,track_counter_2 + + character*5 evg_label,event_line,vertex_line,track_line,dummy + character*5 gener_line + character*80 comment_event_label + character*87 vertex_label + character*93 gener_label + + parameter (event_line = 'EVENT') + parameter (vertex_line = 'VERTE') + parameter (track_line = 'TRACK') + parameter (gener_line = 'GENER') + parameter (flag4 = 4) + parameter (flag0 = 0) +C ALICE USE ONLY + CHARACTER*100 CHROOT + CHARACTER*100 FILNAM + INTEGER*4 LNROOT + LOGICAL EXISTS + CHROOT=' ' +C + +CCC Begin Data Input Options: + +C------------------------ + IF (mode.eq.1) THEN ! Read Input parameters from File#1 +C------------------------ + +CCC For standalone version (ALICE = 0), read parameters from +CCC File Unit=1, 'hbt_parameters.in' +CCC For ALICE-ROOT version (ALICE=1) load parameters from Call to C++ funct + If(ALICE .eq. 1) then + Call AliHbtp_SetParameters + Else If(ALICE .eq. 0) Then + + open(unit=1,type='old',access='sequential', + 1 name='hbt_parameters.in') + +CCC Read Control Switches: (See Main program listing for complete +CCC description of input parameters) + + read(1,*) ref_control + read(1,*) switch_1d + read(1,*) switch_3d + read(1,*) switch_type + read(1,*) switch_coherence + read(1,*) switch_coulomb + read(1,*) switch_fermi_bose + read(1,*) trk_accep + read(1,*) print_full + read(1,*) print_sector_data + +CCC Read Parameters: + + read(1,*) n_pid_types + read(1,*) pid(1),pid(2) + read(1,*) deltap + read(1,*) maxit + read(1,*) delchi + read(1,*) irand + +CCC Read Source Parameters: + + read(1,*) lambda + read(1,*) R_1d + read(1,*) Rside, Rout, Rlong + read(1,*) Rperp, Rparallel, R0 + read(1,*) Q0 + +CCC Read one-body {pt,phi,eta} bins: + + read(1,*) n_pt_bins ,pt_min ,pt_max + read(1,*) n_phi_bins,phi_min,phi_max + read(1,*) n_eta_bins,eta_min,eta_max + +CCC Read two-body 1D and 3D bins: + + read(1,*) n_1d_fine, binsize_1d_fine + read(1,*) n_1d_coarse, binsize_1d_coarse + read(1,*) n_3d_fine, binsize_3d_fine + read(1,*) n_3d_coarse, binsize_3d_coarse + read(1,*) n_3d_fine_project + +CCC Read momentum space track sector bins in {px,py,pz}: + + read(1,*) n_px_bins,px_min,px_max + read(1,*) n_py_bins,py_min,py_max + read(1,*) n_pz_bins,pz_min,pz_max + +CCC Relative Chi-Square weights for track adjustment fitting: + + read(1,*) chisq_wt_like_1d + read(1,*) chisq_wt_unlike_1d + read(1,*) chisq_wt_like_3d_fine + read(1,*) chisq_wt_unlike_3d_fine + read(1,*) chisq_wt_like_3d_coarse + read(1,*) chisq_wt_unlike_3d_coarse + read(1,*) chisq_wt_hist1_1 + read(1,*) chisq_wt_hist1_2 + + Close(unit=1) + End If ! ALICE Data I/O Option + +C----------------------------- + ELSE IF (mode.eq.2) THEN +C----------------------------- + +C Open event generator text file, 'event_text.in,' and read it, +C noting each type of line input. Write out a file called +C 'event_line.flags' which identifies the type of information on +C each line where: +C +C 'EVENT:' lines are assigned flag = 1 +C 'VERTEX:' lines are assigned flag = 2 +C 'TRACK:' lines are assigned flag = 3 +C 'GENER:' lines are assigned flag = 5 +C All other lines are assigned flag = 0 + + If(ALICE .eq. 0) Then + open(unit=2,type='old',access='sequential', + 1 name='event_text.in') + open(unit=3,status='unknown',access='sequential', + 1 name='event_line.flags') + +CCC Set Event Counter: + + event_counter = 0 +30 read(2,10,err=20,end=25) evg_label +10 Format(A) + if(evg_label .eq. event_line) then + event_counter = event_counter + 1 + flag = 1 + else if(evg_label .eq. vertex_line) then + flag = 2 + else if(evg_label .eq. track_line) then + flag = 3 + else if(evg_label .eq. gener_line) then + flag = 5 + else + flag = 0 + end if + + write(3,11) flag +11 Format(1x,I1) + go to 30 ! Return to S.N. 30 and read next line in file +20 write(7,12) event_counter +12 Format(5x,'Read error in event_text.in at event# ',I5,' - STOP') + Stop +25 Continue + Close(unit=2) + Close(unit=3) + End If ! ALICE Data I/O Option + +C Next, re-open the 'event_text.in' and 'event_line.flags' files +C again and read thru the entire files. For each track, check its' +C particle ID and kinematics (pt,phi,eta) with respect to the +C selected particle ID type(s) for the run and the acceptances. +C Fill another file called, 'event_tracks.select,' which is the same +C as 'event_line.flags' except that the accepted tracks are marked +C with flag = 4. +C +C NOTE: Assume all vertices in 'event_text.in' are at microscopic +C distances (fermis) such that all particles in the event +C file are considered as primaries. Also for each event +C the code will only accept tracks up to the limit imposed +C by trk_maxlen in the 'trk' table. + + If(ALICE .eq. 1) Then +CCC For ALICE application do the following: +CCC Store number of events in 'n_events' +CCC Count number accepted tracks in each event, check wrt trk_maxlen +CCC Mark accepted tracks in all events + + Call AliHbtp_GetNumberEvents(n_events) + do i = 1,n_events + Call AliHbtp_SetActiveEventNumber(i) + track_counter = 0 + Call AliHbtp_GetNumberTracks(ntracks) + do j = 1,ntracks + Call AliHbtp_GetTrack(j,flag,px,py,pz,ge_pid) + eg_pid = ge_pid +CCC Check if this track's particle ID is one to be used + + pidok = 0 + accepok = 0 + if(pid(1).gt.0 .and. eg_pid.eq.pid(1)) pidok = 1 + if(pid(2).gt.0 .and. eg_pid.eq.pid(2)) pidok = 1 + if(pidok.eq.1 .and. eg_pid.le.part_maxlen) then + mass = part_mass(eg_pid) + Call Hbtp_kin(px,py,pz,E,pt,phi,eta,mass,1) + if(pt.ge.pt_min .and. pt.le.pt_max .and. + 1 phi.ge.phi_min .and. phi.le.phi_max .and. + 2 eta.ge.eta_min .and. eta.le.eta_max) then + if(track_counter .lt. trk_maxlen) then + accepok = 1 + else + write(7,62) trk_maxlen, event_counter +62 Format(5x,'#tracks exceeds trk_maxlen = ', + 1 I6,' for event#',I4) + end if + end if + end if + + if(pidok.eq.1 .and. accepok.eq.1) then + track_counter = track_counter + 1 +C write(*,*) ' FFF: 1 calling PutTrack j = ',j + Call AliHbtp_PutTrack(j,flag4,px,py,pz,ge_pid) + else +C write(*,*) ' FFF: 2 calling PutTrack j = ',j + Call AliHbtp_PutTrack(j,flag0,px,py,pz,ge_pid) + end if + end do + end do + + Else If(ALICE .eq. 0) Then + + open(unit=2,type='old',access='sequential', + 1 name='event_text.in') + open(unit=3,type='old',access='sequential', + 1 name='event_line.flags') + open(unit=4,status='unknown',access='sequential', + 1 name='event_tracks.select') + +CCC Set Event Counter: + + event_counter = 0 +40 read(3,11,err=45,end=50) flag + if(flag.eq.1) then + event_counter = event_counter + 1 + track_counter = 0 + end if + + if(flag.ne.3) then + read(2,10) dummy + write(4,11) flag + else if(flag.eq.3) then + read(2,41,err=46,end=50) ge_pid,px,py,pz,tid,start_v, + 1 stop_v,eg_pid +41 Format(7x,I6,3(1x,G12.5),4(1x,I6)) + +CCC Check if the 'event_text.in' file includes non-zero PID +CCC values for the variable 'eg_pid'. If this is zero, then +CCC use the ge_pid value. + if(eg_pid.eq.0 .and. ge_pid.ne.0) eg_pid = ge_pid + +CCC Check if this track's particle ID is one to be used + + pidok = 0 + accepok = 0 + if(pid(1).gt.0 .and. eg_pid.eq.pid(1)) pidok = 1 + if(pid(2).gt.0 .and. eg_pid.eq.pid(2)) pidok = 1 + if(pidok.eq.1 .and. eg_pid.le.part_maxlen) then + mass = part_mass(eg_pid) + Call Hbtp_kin(px,py,pz,E,pt,phi,eta,mass,1) + if(pt.ge.pt_min .and. pt.le.pt_max .and. + 1 phi.ge.phi_min .and. phi.le.phi_max .and. + 2 eta.ge.eta_min .and. eta.le.eta_max) then + if(track_counter .lt. trk_maxlen) then + accepok = 1 + else + write(7,621) trk_maxlen, event_counter +621 Format(5x,'#tracks exceeds trk_maxlen = ', + 1 I6,' for event#',I4) + end if + end if + end if + + if(pidok.eq.1 .and. accepok.eq.1) then + track_counter = track_counter + 1 + write(4,11) flag4 + else + write(4,11) flag + end if + + end if ! End Flag=3 options + + go to 40 ! Return to S.N. 40 and read next record +45 write(7,60) event_counter +60 Format(5x,'Read error in event_line.flags at event#',I5, + 1 ' - STOP') + Stop +46 write(7,61) event_counter +61 Format(5x,'Read error in event_text.in (2nd pass) at event#',I5, + 1 ' - STOP') + Stop +50 Continue + + n_events = event_counter - 1 ! Set # events in event_text.in file +C ! This is one less than the counter +C ! value since the last 'EVENT:' line is +C ! used to mark the End-of-File. + + Close(unit=2) + Close(unit=3) + Close(unit=4) + + End If ! ALICE Data I/O Option + +C----------------------------- + ELSE IF(mode.eq.3) THEN +C----------------------------- + +C Read the reference histograms for pairs, then for singles for one +C or two particle ID types. Check switches, bins and mesh information +C to be sure the input reference histograms are compatible with the +C present run conditions. + + open(unit=9,type='old',access='sequential', + 1 name='hbt_pair_reference.hist') + + read(9,*) (check(i),i=1,3) + read(9,*) check(4),acheck(1),acheck(2) + read(9,*) check(5),acheck(3),acheck(4) + read(9,*) check(6),acheck(5),acheck(6) + read(9,*) (check(i),i=7,9) + read(9,*) (check(i),i=10,13) + read(9,*) (acheck(i),i=7,10) + read(9,*) num_pairs_like_ref, num_pairs_unlike_ref + +CCC Determine if the Input Reference pair histograms are compatible +CCC with the present run parameters: + + ref_check = 1 + if(check(1) .ne. n_pid_types ) ref_check = 0 + if(check(2) .ne. pid(1) ) ref_check = 0 + if(check(3) .ne. pid(2) ) ref_check = 0 + if(check(4) .ne. n_pt_bins ) ref_check = 0 + if(check(5) .ne. n_phi_bins ) ref_check = 0 + if(check(6) .ne. n_eta_bins ) ref_check = 0 + if(check(7) .ne. switch_1d ) ref_check = 0 + if(check(8) .ne. switch_3d ) ref_check = 0 + if(check(9) .ne. switch_type ) ref_check = 0 + if(check(10) .ne. n_1d_fine ) ref_check = 0 + if(check(11) .ne. n_1d_coarse ) ref_check = 0 + if(check(12) .ne. n_3d_fine ) ref_check = 0 + if(check(13) .ne. n_3d_coarse ) ref_check = 0 + + if(abs(acheck( 1) - pt_min ) .gt. 0.000001) ref_check = 0 + if(abs(acheck( 2) - pt_max ) .gt. 0.000001) ref_check = 0 + if(abs(acheck( 3) - phi_min ) .gt. 0.000001) ref_check = 0 + if(abs(acheck( 4) - phi_max ) .gt. 0.000001) ref_check = 0 + if(abs(acheck( 5) - eta_min ) .gt. 0.000001) ref_check = 0 + if(abs(acheck( 6) - eta_max ) .gt. 0.000001) ref_check = 0 + if(abs(acheck( 7) - binsize_1d_fine) .gt. 0.000001) ref_check = 0 + if(abs(acheck( 8) - binsize_1d_coarse).gt.0.000001) ref_check = 0 + if(abs(acheck( 9) - binsize_3d_fine) .gt. 0.000001) ref_check = 0 + if(abs(acheck(10) - binsize_3d_coarse).gt.0.000001) ref_check = 0 + + if(ref_check .eq. 0) then + write(7,70) +70 Format(5x,'Reference Pair Histogram Parameters not consistent', + 1 ' with present run conditions - STOP') + errorcode = 1 + Return + else if(ref_check .eq. 1) then + + if(switch_1d.gt.0 .and. n_1d_total.gt.0) then + if(switch_type.eq.1 .or. switch_type.eq.3) then + read(9,*) (href_like_1d(i),i=1,n_1d_total) + end if + if(switch_type.eq.2 .or. switch_type.eq.3) then + read(9,*) (href_unlike_1d(i),i=1,n_1d_total) + end if + end if ! End 1D input option + + if(switch_3d.gt.0) then + if(switch_type.eq.1 .or. switch_type.eq.3) then + + if(n_3d_fine.gt.0) then + do i = 1,n_3d_fine + do j = 1,n_3d_fine + do k = 1,n_3d_fine + read(9,*) href_like_3d_fine(i,j,k) + end do + end do + end do + end if + + if(n_3d_coarse.gt.0) then + do i = 1,n_3d_coarse + do j = 1,n_3d_coarse + do k = 1,n_3d_coarse + read(9,*) href_like_3d_coarse(i,j,k) + end do + end do + end do + end if + + end if + + if(switch_type.eq.2 .or. switch_type.eq.3) then + + if(n_3d_fine.gt.0) then + do i = 1,n_3d_fine + do j = 1,n_3d_fine + do k = 1,n_3d_fine + read(9,*) href_unlike_3d_fine(i,j,k) + end do + end do + end do + end if + + if(n_3d_coarse.gt.0) then + do i = 1,n_3d_coarse + do j = 1,n_3d_coarse + do k = 1,n_3d_coarse + read(9,*) href_unlike_3d_coarse(i,j,k) + end do + end do + end do + end if + + end if + + end if ! End 3D input option + end if ! End Reference Check OK/Not OK Option + + Close(unit=9) + +CCC Next read the one-body histograms for 1 or 2 particle ID types: + + open(unit=11,type='old',access='sequential', + 1 name='hbt_singles_reference.hist') + + read(11,*) (check(i),i=1,3) + read(11,*) check(4),acheck(1),acheck(2) + read(11,*) check(5),acheck(3),acheck(4) + read(11,*) check(6),acheck(5),acheck(6) + read(11,*) n_part_used_1_ref, n_part_used_2_ref + +CCC Determine if Reference one-body histograms are compatible with +CCC the present run conditions. + + ref_check = 1 + if(check(1) .ne. n_pid_types) ref_check = 0 + if(check(2) .ne. pid(1) ) ref_check = 0 + if(check(3) .ne. pid(2) ) ref_check = 0 + if(check(4) .ne. n_pt_bins ) ref_check = 0 + if(check(5) .ne. n_phi_bins ) ref_check = 0 + if(check(6) .ne. n_eta_bins ) ref_check = 0 + + if(abs(acheck(1) - pt_min ).gt.0.000001) ref_check = 0 + if(abs(acheck(2) - pt_max ).gt.0.000001) ref_check = 0 + if(abs(acheck(3) - phi_min ).gt.0.000001) ref_check = 0 + if(abs(acheck(4) - phi_max ).gt.0.000001) ref_check = 0 + if(abs(acheck(5) - eta_min ).gt.0.000001) ref_check = 0 + if(abs(acheck(6) - eta_max ).gt.0.000001) ref_check = 0 + + if(ref_check .eq. 0) then + write(7,71) +71 Format(5x,'Reference One-Body Histogram parameters not ', + 1 'consistent with current run - STOP') + errorcode = 1 + Return + else if(ref_check .eq. 1) then + + if(pid(1).gt.0) then + read(11,*) (href1_pt_1(i) ,i=1,n_pt_bins) + read(11,*) (href1_phi_1(i),i=1,n_phi_bins) + read(11,*) (href1_eta_1(i),i=1,n_eta_bins) + end if + + if(pid(2).gt.0) then + read(11,*) (href1_pt_2(i) ,i=1,n_pt_bins) + read(11,*) (href1_phi_2(i),i=1,n_phi_bins) + read(11,*) (href1_eta_2(i),i=1,n_eta_bins) + end if + + end if ! End one-body reference histogram input + + Close(unit=11) + +C----------------------------- + ELSE IF(mode.eq.4) THEN +C----------------------------- + +CCC Read the next event from 'event_text.in' and load accepted tracks +C into the 'trk' data structure using the flag information about each +C line type in the file 'event_tracks.select'. +C +C For this mode to run successfully the calling program must: +C (1) initially set the event_line_counter = 0 +C (2) open the 'event_text.in' and 'event_tracks.select' files +C as units 2 and 4, respectively. +C (3) Close units 2 and 4 when finished. + +CCC Initialize accepted track counters for this new event: + + track_counter = 0 ! Counts all accepted tracks + track_counter_1 = 0 ! Counts all accepted tracks of type pid(1) + track_counter_2 = 0 ! Counts all accepted tracks of type pid(2) + + If(ALICE .eq. 1) Then + Call AliHbtp_GetNumberTracks(ntracks) + do i = 1,ntracks + Call AliHbtp_GetTrack(i,flag,px,py,pz,ge_pid) + eg_pid = ge_pid + if(flag.eq.flag4) then + track_counter = track_counter + 1 + + if(eg_pid.eq.pid(1) .and. pid(1).gt.0) then + track_counter_1 = track_counter_1 + 1 + end if + + if(eg_pid.eq.pid(2) .and. pid(2).gt.0) then + track_counter_2 = track_counter_2 + 1 + end if + + mass = part_mass(eg_pid) + Call Hbtp_kin(px,py,pz,E,pt,phi,eta,mass,1) + trk_ge_pid(track_counter) = eg_pid + trk_px(track_counter) = px + trk_py(track_counter) = py + trk_pz(track_counter) = pz + trk_id(track_counter) = track_counter + trk_start_vertex(track_counter) = 0 + trk_stop_vertex(track_counter) = 0 + trk_event_line(track_counter) = 0 + trk_flag(track_counter) = 0 + trk_px_sec(track_counter) = 0 + trk_py_sec(track_counter) = 0 + trk_pz_sec(track_counter) = 0 + trk_sector(track_counter) = 0 + trk_out_flag(track_counter) = 0 + trk_merge_flag(track_counter) = 0 + trk_E(track_counter) = E + trk_pt(track_counter) = pt + trk_phi(track_counter) = phi + trk_eta(track_counter) = eta + end if + end do + n_part_1_trk = track_counter_1 + n_part_2_trk = track_counter_2 + n_part_tot_trk = track_counter + + Else If(ALICE .eq. 0) Then + +80 read(4,11,err=81,end=82) flag + event_line_counter = event_line_counter + 1 + + if(flag .ne. 4) then + read(2,10,err=83,end=82) dummy + else if(flag .eq. 4) then + read(2,41) ge_pid,px,py,pz,tid,start_v,stop_v,eg_pid + +CCC Check if the 'event_text.in' file includes non-zero PID +CCC values for the variable 'eg_pid'. If this is zero, then +CCC use the ge_pid value. + if(eg_pid.eq.0 .and. ge_pid.ne.0) eg_pid = ge_pid + + track_counter = track_counter + 1 + + if(eg_pid.eq.pid(1) .and. pid(1).gt.0) then + track_counter_1 = track_counter_1 + 1 + end if + + if(eg_pid.eq.pid(2) .and. pid(2).gt.0) then + track_counter_2 = track_counter_2 + 1 + end if + + mass = part_mass(eg_pid) + Call Hbtp_kin(px,py,pz,E,pt,phi,eta,mass,1) + trk_ge_pid(track_counter) = eg_pid + trk_px(track_counter) = px + trk_py(track_counter) = py + trk_pz(track_counter) = pz + trk_id(track_counter) = track_counter + trk_start_vertex(track_counter) = start_v + trk_stop_vertex(track_counter) = stop_v + trk_event_line(track_counter) = event_line_counter + trk_flag(track_counter) = 0 + trk_px_sec(track_counter) = 0 + trk_py_sec(track_counter) = 0 + trk_pz_sec(track_counter) = 0 + trk_sector(track_counter) = 0 + trk_out_flag(track_counter) = 0 + trk_merge_flag(track_counter) = 0 + trk_E(track_counter) = E + trk_pt(track_counter) = pt + trk_phi(track_counter) = phi + trk_eta(track_counter) = eta + end if + + if(flag.ne.1) then + go to 80 ! Return to S.N. 80 and read next record in file + else if(flag.eq.1) then + n_part_1_trk = track_counter_1 + n_part_2_trk = track_counter_2 + n_part_tot_trk = track_counter + end if + +82 Return +81 write(7,84) +84 Format(5x,'Read error from file event_tracks.select for mode=4', + 1 ' - STOP') + Stop +83 write(7,85) +85 Format(5x,'Read error from file event_text.in for mode=4', + 1 ' - STOP') + Stop + End If ! ALICE Data I/O Option + +C----------------------------- + ELSE IF(mode.eq.5) THEN +C----------------------------- + +CCC Read the next event from 'event_text.in' and load accepted tracks +C into the 'trk2' data structure using the flag information about each +C line type in the file 'event_tracks.select'. +C +C For this mode to run successfully the calling program must: +C (1) initially set the event_line_counter = 0 +C (2) open the 'event_text.in' and 'event_tracks.select' files +C as units 2 and 4, respectively. +C (3) Close units 2 and 4 when finished. + +CCC Initialize accepted track counters for this new event: + + track_counter = 0 ! Counts all accepted tracks + track_counter_1 = 0 ! Counts all accepted tracks of type pid(1) + track_counter_2 = 0 ! Counts all accepted tracks of type pid(2) + + If(ALICE .eq. 1) Then + Call AliHbtp_GetNumberTracks(ntracks) + do i = 1,ntracks + Call AliHbtp_GetTrack(i,flag,px,py,pz,ge_pid) + eg_pid = ge_pid + if(flag.eq.flag4) then + track_counter = track_counter + 1 + + if(eg_pid.eq.pid(1) .and. pid(1).gt.0) then + track_counter_1 = track_counter_1 + 1 + end if + + if(eg_pid.eq.pid(2) .and. pid(2).gt.0) then + track_counter_2 = track_counter_2 + 1 + end if + + mass = part_mass(eg_pid) + Call Hbtp_kin(px,py,pz,E,pt,phi,eta,mass,1) + trk2_ge_pid(track_counter) = eg_pid + trk2_px(track_counter) = px + trk2_py(track_counter) = py + trk2_pz(track_counter) = pz + trk2_id(track_counter) = track_counter + trk2_start_vertex(track_counter) = 0 + trk2_stop_vertex(track_counter) = 0 + trk2_event_line(track_counter) = 0 + trk2_flag(track_counter) = 0 + trk2_px_sec(track_counter) = 0 + trk2_py_sec(track_counter) = 0 + trk2_pz_sec(track_counter) = 0 + trk2_sector(track_counter) = 0 + trk2_out_flag(track_counter) = 0 + trk2_merge_flag(track_counter) = 0 + trk2_E(track_counter) = E + trk2_pt(track_counter) = pt + trk2_phi(track_counter) = phi + trk2_eta(track_counter) = eta + end if + end do + n_part_1_trk2 = track_counter_1 + n_part_2_trk2 = track_counter_2 + n_part_tot_trk2 = track_counter + + Else If(ALICE.eq.0) Then + +90 read(4,11,err=91,end=92) flag + event_line_counter = event_line_counter + 1 + + if(flag .ne. 4) then + read(2,10,err=93,end=92) dummy + else if(flag .eq. 4) then + read(2,41) ge_pid,px,py,pz,tid,start_v,stop_v,eg_pid + +CCC Check if the 'event_text.in' file includes non-zero PID +CCC values for the variable 'eg_pid'. If this is zero, then +CCC use the ge_pid value. + if(eg_pid.eq.0 .and. ge_pid.ne.0) eg_pid = ge_pid + + track_counter = track_counter + 1 + + if(eg_pid.eq.pid(1) .and. pid(1).gt.0) then + track_counter_1 = track_counter_1 + 1 + end if + + if(eg_pid.eq.pid(2) .and. pid(2).gt.0) then + track_counter_2 = track_counter_2 + 1 + end if + + mass = part_mass(eg_pid) + Call Hbtp_kin(px,py,pz,E,pt,phi,eta,mass,1) + trk2_ge_pid(track_counter) = eg_pid + trk2_px(track_counter) = px + trk2_py(track_counter) = py + trk2_pz(track_counter) = pz + trk2_id(track_counter) = track_counter + trk2_start_vertex(track_counter) = start_v + trk2_stop_vertex(track_counter) = stop_v + trk2_event_line(track_counter) = event_line_counter + trk2_flag(track_counter) = 0 + trk2_px_sec(track_counter) = 0 + trk2_py_sec(track_counter) = 0 + trk2_pz_sec(track_counter) = 0 + trk2_sector(track_counter) = 0 + trk2_out_flag(track_counter) = 0 + trk2_merge_flag(track_counter) = 0 + trk2_E(track_counter) = E + trk2_pt(track_counter) = pt + trk2_phi(track_counter) = phi + trk2_eta(track_counter) = eta + end if + + if(flag.ne.1) then + go to 90 ! Return to S.N. 90 and read next record in file + else if(flag.eq.1) then + n_part_1_trk2 = track_counter_1 + n_part_2_trk2 = track_counter_2 + n_part_tot_trk2 = track_counter + end if + +92 Return +91 write(7,94) +94 Format(5x,'Read error from file event_tracks.select for mode=5', + 1 ' - STOP') + Stop +93 write(7,95) +95 Format(5x,'Read error from file event_text.in for mode=5', + 1 ' - STOP') + Stop + + End If ! ALICE Data I/O Option + +C----------------------------- + ELSE IF(mode.eq.6) THEN +C----------------------------- + +CCC Read finite source size Coulomb pair correlation corrections and +CCC interpolate to requested source radius and save the results for q, +CCC like and unlike pairs in common/coulomb/. + + if(switch_coulomb.eq.3 .and. Q0.ge.coulradmin .and. + 1 Q0.le.coulradmax) then + +CCC Initially, read and interpolate like pair Coulomb corrections: +C ALICE + + If(ALICE .eq. 1) then + + CALL GETENVF('ALICE_ROOT',CHROOT) + LNROOT = LNBLNK(CHROOT) + + IF(LNROOT.LE.0) THEN + PRINT*,'**********************************' + PRINT*,'* HBT PROCESSOR *' + PRINT*,'* ----------- *' + PRINT*,'* DATA File not found *' + PRINT*,'* Program STOP *' + PRINT*,'* Check ALICE_ROOT environment *' + PRINT*,'* variable *' + PRINT*,'**********************************' + errorcode = 1 + return + ENDIF + + FILNAM=CHROOT(1:LNROOT)//'/data/cpp_06.dat' + open(unit=21,type='old',access='sequential', + 1 name=FILNAM) + + FILNAM=CHROOT(1:LNROOT)//'/data/cpp_08.dat' + open(unit=22,type='old',access='sequential', + 1 name=FILNAM) + + FILNAM=CHROOT(1:LNROOT)//'/data/cpp_10.dat' + open(unit=23,type='old',access='sequential', + 1 name=FILNAM) + + FILNAM=CHROOT(1:LNROOT)//'/data/cpp_12.dat' + open(unit=24,type='old',access='sequential', + 1 name=FILNAM) + + FILNAM=CHROOT(1:LNROOT)//'/data/cpp_14.dat' + open(unit=25,type='old',access='sequential', + 1 name=FILNAM) + + FILNAM=CHROOT(1:LNROOT)//'/data/cpp_16.dat' + open(unit=26,type='old',access='sequential', + 1 name=FILNAM) + + FILNAM=CHROOT(1:LNROOT)//'/data/cpp_18.dat' + open(unit=27,type='old',access='sequential', + 1 name=FILNAM) + + ELSE + open(unit=21,type='old',access='sequential', + 1 name='cpp_06.dat') + open(unit=22,type='old',access='sequential', + 1 name='cpp_08.dat') + open(unit=23,type='old',access='sequential', + 1 name='cpp_10.dat') + open(unit=24,type='old',access='sequential', + 1 name='cpp_12.dat') + open(unit=25,type='old',access='sequential', + 1 name='cpp_14.dat') + open(unit=26,type='old',access='sequential', + 1 name='cpp_16.dat') + open(unit=27,type='old',access='sequential', + 1 name='cpp_18.dat') + ENDIF + + + do i = 1,max_c2_coul + do j = 1,ncoulradsteps + read(20+j,*) q_coul(i), function(j) + end do + Call AliHbtp_interp(coulradmin,coulradmax,coulradstep, + 1 ncoulradsteps,function,20,Q0,c2_coul_like(i)) + end do + + close(unit=21) + close(unit=22) + close(unit=23) + close(unit=24) + close(unit=25) + close(unit=26) + close(unit=27) + +CCC Next read and interpolate the unlike pair Coulomb corrections: + + If(ALICE .eq. 1) then + FILNAM=CHROOT(1:LNROOT)//'/data/cpm_06.dat' + open(unit=31,type='old',access='sequential', + 1 name=FILNAM) + + FILNAM=CHROOT(1:LNROOT)//'/data/cpm_08.dat' + open(unit=32,type='old',access='sequential', + 1 name=FILNAM) + + FILNAM=CHROOT(1:LNROOT)//'/data/cpm_10.dat' + open(unit=33,type='old',access='sequential', + 1 name=FILNAM) + + FILNAM=CHROOT(1:LNROOT)//'/data/cpm_12.dat' + open(unit=34,type='old',access='sequential', + 1 name=FILNAM) + + FILNAM=CHROOT(1:LNROOT)//'/data/cpm_14.dat' + open(unit=35,type='old',access='sequential', + 1 name=FILNAM) + + FILNAM=CHROOT(1:LNROOT)//'/data/cpm_16.dat' + open(unit=36,type='old',access='sequential', + 1 name=FILNAM) + + FILNAM=CHROOT(1:LNROOT)//'/data/cpm_18.dat' + open(unit=37,type='old',access='sequential', + 1 name=FILNAM) + + else + open(unit=31,type='old',access='sequential', + 1 name='cpm_06.dat') + open(unit=32,type='old',access='sequential', + 1 name='cpm_08.dat') + open(unit=33,type='old',access='sequential', + 1 name='cpm_10.dat') + open(unit=34,type='old',access='sequential', + 1 name='cpm_12.dat') + open(unit=35,type='old',access='sequential', + 1 name='cpm_14.dat') + open(unit=36,type='old',access='sequential', + 1 name='cpm_16.dat') + open(unit=37,type='old',access='sequential', + 1 name='cpm_18.dat') + EndIf + + do i = 1,max_c2_coul + do j = 1,ncoulradsteps + read(30+j,*) q_coul(i), function(j) + end do + Call AliHbtp_interp(coulradmin,coulradmax,coulradstep, + 1 ncoulradsteps,function,20,Q0,c2_coul_unlike(i)) + end do + + close(unit=31) + close(unit=32) + close(unit=33) + close(unit=34) + close(unit=35) + close(unit=36) + close(unit=37) + +CCC Convert the input q values which are in MeV/c, to GeV/c: + + do i = 1,max_c2_coul + q_coul(i) = 0.001*q_coul(i) + end do + + end if + + +C---------------------------- + ELSE IF(mode.eq.7) THEN +C---------------------------- + +CCC Read next event from 'event_text.in', load accepted tracks into 'trk' +CCC data structure using the flag information in the file +CCC 'event_tracks.select', copy contents of 'event_text.in' and +CCC 'event_tracks.select', for this one event only, into temporary files +CCC 'event_text_aux.in' and 'event_tracks_aux.select', respectively. +C +C For this mode to run successfully the calling program must: +C (1) initially set the event_line_counter = 0 +C (2) open the 'event_text.in' and 'event_tracks.select' files +C as units 2 and 4, respectively. +C (3) Close units 2 and 4 when finished. + +CCC Initialize accepted track counters for this new event: + + track_counter = 0 ! Counts all accepted tracks + track_counter_1 = 0 ! Counts all accepted tracks of type pid(1) + track_counter_2 = 0 ! Counts all accepted tracks of type pid(2) + + If(ALICE .eq. 1) Then + Call AliHbtp_GetNumberTracks(ntracks) + do i = 1,ntracks + Call AliHbtp_GetTrack(i,flag,px,py,pz,ge_pid) + eg_pid = ge_pid + if(flag.eq.flag4) then + track_counter = track_counter + 1 + + if(eg_pid.eq.pid(1) .and. pid(1).gt.0) then + track_counter_1 = track_counter_1 + 1 + end if + + if(eg_pid.eq.pid(2) .and. pid(2).gt.0) then + track_counter_2 = track_counter_2 + 1 + end if + + mass = part_mass(eg_pid) + Call Hbtp_kin(px,py,pz,E,pt,phi,eta,mass,1) + trk_ge_pid(track_counter) = eg_pid + trk_px(track_counter) = px + trk_py(track_counter) = py + trk_pz(track_counter) = pz + trk_id(track_counter) = track_counter + trk_start_vertex(track_counter) = 0 + trk_stop_vertex(track_counter) = 0 + trk_event_line(track_counter) = 0 + trk_flag(track_counter) = 0 + trk_px_sec(track_counter) = 0 + trk_py_sec(track_counter) = 0 + trk_pz_sec(track_counter) = 0 + trk_sector(track_counter) = 0 + trk_out_flag(track_counter) = 0 + trk_merge_flag(track_counter) = 0 + trk_E(track_counter) = E + trk_pt(track_counter) = pt + trk_phi(track_counter) = phi + trk_eta(track_counter) = eta + end if + end do + n_part_1_trk = track_counter_1 + n_part_2_trk = track_counter_2 + n_part_tot_trk = track_counter + + Else If(ALICE .eq. 0) Then + +CCC Open temporary files: + + open(unit=12,status='unknown',access='sequential', + 1 name='event_text_aux.in') + open(unit=14,status='unknown',access='sequential', + 1 name='event_tracks_aux.select') + +100 read(4,11,err=101,end=102) flag + event_line_counter = event_line_counter + 1 + write(14,11) flag + if(flag.eq.1) then + read(2,10,err=103,end=102) comment_event_label + write(12,10) comment_event_label + else if(flag .eq. 2) then + read(2,10,err=103,end=102) vertex_label + write(12,10) vertex_label + else if(flag .eq. 3) then + read(2,10,err=103,end=102) comment_event_label + write(12,10) comment_event_label + else if(flag .eq. 5) then + read(2,10,err=103,end=102) gener_label + write(12,10) gener_label + else if(flag .eq. 4) then + read(2,41) ge_pid,px,py,pz,tid,start_v,stop_v,eg_pid + write(12,41) ge_pid,px,py,pz,tid,start_v,stop_v,eg_pid + +CCC Check if the 'event_text.in' file includes non-zero PID +CCC values for the variable 'eg_pid'. If this is zero, then +CCC use the ge_pid value. + if(eg_pid.eq.0 .and. ge_pid.ne.0) eg_pid = ge_pid + + track_counter = track_counter + 1 + + if(eg_pid.eq.pid(1) .and. pid(1).gt.0) then + track_counter_1 = track_counter_1 + 1 + end if + + if(eg_pid.eq.pid(2) .and. pid(2).gt.0) then + track_counter_2 = track_counter_2 + 1 + end if + + mass = part_mass(eg_pid) + Call Hbtp_kin(px,py,pz,E,pt,phi,eta,mass,1) + trk_ge_pid(track_counter) = eg_pid + trk_px(track_counter) = px + trk_py(track_counter) = py + trk_pz(track_counter) = pz + trk_id(track_counter) = track_counter + trk_start_vertex(track_counter) = start_v + trk_stop_vertex(track_counter) = stop_v + trk_event_line(track_counter) = event_line_counter + trk_flag(track_counter) = 0 + trk_px_sec(track_counter) = 0 + trk_py_sec(track_counter) = 0 + trk_pz_sec(track_counter) = 0 + trk_sector(track_counter) = 0 + trk_out_flag(track_counter) = 0 + trk_merge_flag(track_counter) = 0 + trk_E(track_counter) = E + trk_pt(track_counter) = pt + trk_phi(track_counter) = phi + trk_eta(track_counter) = eta + else + read(2,10,err=103,end=102) comment_event_label + write(12,10) comment_event_label + end if + + if(flag.ne.1) then + go to 100 ! Return to S.N. 100 and read next record in file + else if(flag.eq.1) then + n_part_1_trk = track_counter_1 + n_part_2_trk = track_counter_2 + n_part_tot_trk = track_counter + end if + +102 Close(unit=12) + Close(unit=14) + Return +101 write(7,104) +104 Format(5x,'Read error from file event_tracks.select for mode=7', + 1 ' - STOP') + Stop +103 write(7,105) +105 Format(5x,'Read error from file event_text.in for mode=7', + 1 ' - STOP') + Stop + + End If ! ALICE Data I/O Option + +C---------------------------- + ELSE IF(mode.eq.8) THEN +C---------------------------- + +CCC Read contents of 'event_text_aux.in' using the flag values in +CCC tmp. file 'event_tracks_aux.select' and copy this into the final +CCC output event file, 'event_hbt_text.out', where the momentum values +CCC of the accepted tracks in the initial input event file are replaced +CCC with the adjusted/correlated values obtained from the 'trk' table. +C +C For this to work successfully the calling program must: +C (1) initially set the event_line_counter = 0 +C (2) open the 'event_hbt_text.out' file as unit = 10 +C (3) Close unit 10 when finished + +CCC Initialize accepted track counters: + + track_counter = 0 + + If(ALICE .eq. 1) Then + Call AliHbtp_GetNumberTracks(ntracks) + do i = 1,ntracks + Call AliHbtp_GetTrack(i,flag,px,py,pz,ge_pid) + if(flag.eq.flag4) then + track_counter = track_counter + 1 + if(trk_accep .ge. 1.000 .or. (trk_accep .lt. 1.00 + 1 .and. hbtpran(irand) .le. trk_accep)) then +C write(*,*) ' FFF: 3 calling PutTrack i = ',i + Call AliHbtp_PutTrack(i,flag, + 1 trk_px(track_counter), + 2 trk_py(track_counter), + 3 trk_pz(track_counter), + 4 ge_pid) + end if + end if + end do + + Else If(ALICE .eq. 0) Then + +CCC Open temporary, auxiliary files: + + open(unit=12,type='old',access='sequential', + 1 name='event_text_aux.in') + open(unit=14,type='old',access='sequential', + 1 name='event_tracks_aux.select') + +120 read(14,11,err=121,end=122) flag + file10_line_counter = file10_line_counter + 1 + if(flag.eq.1) then + read(12,10,err=123,end=122) comment_event_label + write(10,10) comment_event_label + else if(flag .eq. 2) then + read(12,10,err=123,end=122) vertex_label + write(10,10) vertex_label + else if(flag .eq. 3) then + read(12,10,err=123,end=122) comment_event_label + write(10,10) comment_event_label + else if(flag .eq. 5) then + read(12,10,err=123,end=122) gener_label + write(10,10) gener_label + else if(flag .eq. 4) then + read(12,41,err=123,end=122) + 1 ge_pid,px,py,pz,tid,start_v,stop_v,eg_pid + track_counter = track_counter + 1 + if(tid.eq.0) tid = trk_id(track_counter) + if(trk_event_line(track_counter).eq.file10_line_counter)then + if(trk_accep .ge. 1.000 .or. (trk_accep .lt. 1.00 + 1 .and. hbtpran(irand) .le. trk_accep)) then + write(10,841)ge_pid , + 1 trk_px(track_counter) , + 2 trk_py(track_counter) , + 3 trk_pz(track_counter) , + 4 tid , + 5 start_v , + 6 stop_v , + 7 trk_ge_pid(track_counter) +841 Format('TRACK:',1x,I6,3(1x,G12.5),4(1x,I6)) + end if + else + write(7,127) + write(7,126) track_counter, trk_event_line(track_counter), + 1 file10_line_counter +127 Format(5x,'Track table rows and Event file line count ', + 1 'out-of-synch. - STOP') +126 Format(5x,'track_counter, trk().event_line,', + 1 'file10_line_counter = ',3I10) + Stop + end if + else + read(12,10,err=123,end=122) comment_event_label + write(10,10) comment_event_label + end if + + if(flag .ne. 1) go to 120 ! Return to S.N. 120 and read next record + +122 Close(unit=12,status='delete') + Close(unit=14,status='delete') + Return +121 write(7,124) +124 Format(5x,'Read error from file event_tracks_aux.select', + 1 ' for mode = 8 - STOP') + Stop +123 write(7,125) +125 Format(5x,'Read error from file event_text_aux.in', + 1 ' for mode = 8 - STOP') + Stop + + End If ! ALICE Data I/O Option + +C----------------- + END IF ! End of read_data mode selection options +C----------------- + + Return + END + +C----------------------------------------------------------------------- + + + subroutine getref_hist + implicit none + +CCC This subroutine controls the reading or calculation and output +CCC of the several reference histograms. These include: +CCC (a) the one-body {pt,phi,eta} 1D distributions for 1 or 2 +CCC particle ID types. +CCC (b) the two-body pair-wise histograms for like and unlike +CCC pairs; for 1D and/or 3D fine mesh and 3D coarse mesh +CCC distributions. + + Include 'common_parameters.inc' + Include 'common_mesh.inc' + Include 'common_histograms.inc' + + Include 'common_track.inc' + Include 'common_track2.inc' + Include 'common_sec_track.inc' + Include 'common_sec_track2.inc' + Include 'common_particle.inc' + +CCC Local Variable Type Declarations: + + integer*4 i,ipt,iphi,ieta,sign_toggle + + if(ref_control .eq. 1) then + +CCC read pair and one-body reference histograms: + Call read_data(3) + else if(ref_control .eq. 2) then + +CCC calculate the pair and one-body histograms: +CCC Open event and flag files: + + If(ALICE .eq. 0) Then + open(unit=2,type='old',access='sequential', + 1 name='event_text.in') + open(unit=4,type='old',access='sequential', + 1 name='event_tracks.select') + End If + +CCC Initialize counters: + + n_part_used_1_ref = 0 + n_part_used_2_ref = 0 + num_pairs_like_ref = 0 + num_pairs_unlike_ref = 0 + event_line_counter = 0 + +CCC Read event header lines (no tracks are in this part): + If(ALICE .eq. 0) Then + Call read_data(4) + End If + +CCC Set toggle switch to alternate between loading event tracks into +CCC table 'trk' and table 'trk2': + sign_toggle = 1 + +CCC Start Event Loop: + + do i = 1,n_events + If(ALICE .eq. 1) Then + Call AliHbtp_SetActiveEventNumber(i) + End If + if(sign_toggle .eq. 1) then ! Put tracks into 'trk' + Call read_data(4) + Call tindex(1,0) + Call stm_build(1,0,0) + if(pid(1) .gt. 0) then + Call histog1(1,0,1,pid(1),0.0,0.0,0.0) + n_part_used_1_ref = n_part_used_1_ref + n_part_used_1_trk + + do ipt = 1,n_pt_bins + href1_pt_1(ipt) = href1_pt_1(ipt) + hist1_pt_1(ipt) + end do + + do iphi = 1,n_phi_bins + href1_phi_1(iphi) = href1_phi_1(iphi) + hist1_phi_1(iphi) + end do + + do ieta = 1,n_eta_bins + href1_eta_1(ieta) = href1_eta_1(ieta) + hist1_eta_1(ieta) + end do + end if + + if(pid(2) .gt. 0) then + Call histog1(1,0,2,pid(2),0.0,0.0,0.0) + n_part_used_2_ref = n_part_used_2_ref + n_part_used_2_trk + + do ipt = 1,n_pt_bins + href1_pt_2(ipt) = href1_pt_2(ipt) + hist1_pt_2(ipt) + end do + + do iphi = 1,n_phi_bins + href1_phi_2(iphi) = href1_phi_2(iphi) + hist1_phi_2(iphi) + end do + + do ieta = 1,n_eta_bins + href1_eta_2(ieta) = href1_eta_2(ieta) + hist1_eta_2(ieta) + end do + end if + + else if(sign_toggle .eq. (-1)) then ! Put tracks into 'trk2' + Call read_data(5) + Call tindex(2,0) + Call stm_build(2,0,0) + if(pid(1) .gt. 0) then + Call histog1(4,0,1,pid(1),0.0,0.0,0.0) + n_part_used_1_ref = n_part_used_1_ref +n_part_used_1_trk2 + + do ipt = 1,n_pt_bins + href1_pt_1(ipt) = href1_pt_1(ipt) + hist1_pt_1(ipt) + end do + + do iphi = 1,n_phi_bins + href1_phi_1(iphi) = href1_phi_1(iphi) + hist1_phi_1(iphi) + end do + + do ieta = 1,n_eta_bins + href1_eta_1(ieta) = href1_eta_1(ieta) + hist1_eta_1(ieta) + end do + end if + + if(pid(2) .gt. 0) then + Call histog1(4,0,2,pid(2),0.0,0.0,0.0) + n_part_used_2_ref = n_part_used_2_ref +n_part_used_2_trk2 + + do ipt = 1,n_pt_bins + href1_pt_2(ipt) = href1_pt_2(ipt) + hist1_pt_2(ipt) + end do + + do iphi = 1,n_phi_bins + href1_phi_2(iphi) = href1_phi_2(iphi) + hist1_phi_2(iphi) + end do + + do ieta = 1,n_eta_bins + href1_eta_2(ieta) = href1_eta_2(ieta) + hist1_eta_2(ieta) + end do + end if + + end if ! End read and load to trk or trk2 option + + sign_toggle = -sign_toggle + + if(i .gt. 1) then ! Compute 2-body reference histograms + Call histog2(4,0,0,0,0,0.0,0.0,0.0,0.0) + num_pairs_like_ref = num_pairs_like_ref + 1 + n_part_used_1_trk * n_part_used_1_trk2 + 2 + n_part_used_2_trk * n_part_used_2_trk2 + num_pairs_unlike_ref = num_pairs_unlike_ref + 1 + n_part_used_1_trk * n_part_used_2_trk2 + 2 + n_part_used_2_trk * n_part_used_1_trk2 + end if + + end do ! End of Event Loop + +CCC Write out the pair and one-body reference Histograms: + Call write_data(2,0) + + If(ALICE .eq. 0) Then + Close(unit=2) + Close(unit=4) + End If + + end if ! End Reference Histogram read/calculate option + + Return + END + +C---------------------------------------------------------------------- + + + subroutine AliHbtp_interp(rmin,rmax,rstep,nrsteps,function, + 1 ndim,r,answer) + implicit none + +CCC This routine interpolates the function values and puts the result +CCC into 'answer'. It uses 2,3 or 4 mesh points which must be equally +CCC spaced. The method uses the Lagrange interpolation formulas given +CCC in Abramowitz and Stegun, ``Handbook of Mathematical Functions,'' +CCC (Dover Publications, New York, 1970); pages 878-879. + +CCC Definition of Variables in the Argument List: + +CCC rmin = lower limit of independent variable for input function +CCC rmax = upper limit of independent variable for input function +CCC rstep = step size of independent variable +CCC nrsteps = (redundant) # of input steps +CCC function(ndim) = Array of function values to be interpolated +CCC ndim = array dimension size in calling program +CCC r = coordinate value of independent variable where interpolation +CCC is needed. +CCC answer = interpolated value + +CCC The algorithm will use the maximum number of points in the +CCC interpolation, up to a maximum of 4 + +CCC If the requested coordinate value, r, is out-of-range, then +CCC 'answer' is returned with a 0.0 value. + +CCC Local Variable Type Declarations: + + integer*4 ndim, nrsteps, ik + + real*4 rmin,rmax,rstep,r,answer,rshift,p + real*4 function(ndim),w1,w2,w3,w4 + +CCC Check Mesh: + + if(abs(((rmax-rmin)/float(nrsteps-1))-rstep).gt.0.00001) then + write(7,10) rmin,rmax,rstep,nrsteps +10 Format(5x,'Interp mesh inconsistent:',3E12.5,I5, + 1 ' - STOP') + Return + end if + +CCC Check range: + + if(r .lt. rmin .or. r .gt. rmax) then + write(7,11) rmin,rmax,r +11 Format(5x,'Interp called with r out-of-range =',3E12.5) + answer = 0.0 + Return + end if + +CCC Begin interpolation: + + if(nrsteps .eq. 2) then + p = (r - rmin)/rstep + answer = (1.0 - p)*function(1) + p*function(2) + else if(nrsteps .eq. 3) then + p = (r - (rmin + rstep))/rstep + answer = 0.5*p*(p-1.0)*function(1) + (1.0 - p*p) + 1 *function(2) + 0.5*p*(p+1.0)*function(3) + else if(nrsteps .ge. 4) then + rshift = r - rmin + + if(rshift .le. rstep) then + ik = 2 + p = (rshift - rstep)/rstep + else if(rshift .ge. (rmax - rstep - rmin)) then + ik = nrsteps - 2 + p = (rshift - (rmax - rmin - 2.0*rstep))/rstep + else + ik = int(rshift/rstep + 1.000001) + if(ik .le. 1) ik = 2 + if(ik .ge. (nrsteps-1)) ik = nrsteps - 2 + p = (rshift - float(ik-1)*rstep)/rstep + end if + + w1 = -p*(p-1.0)*(p-2.0)/6.0 + w2 = (p*p-1.0)*(p-2.0)/2.0 + w3 = -p*(p+1.0)*(p-2.0)/2.0 + w4 = p*(p*p-1.0)/6.0 + + answer = w1*function(ik-1) + w2*function(ik) + 1 + w3*function(ik+1) + w4*function(ik+2) + end if ! End # interplation points option + + Return + END + +C-------------------------------------------------------------------- + + + subroutine Hbtp_particle_prop + implicit none + +CCC Fill particle properties table /particle/ with Geant 3 particle ID +CCC numbers, charge (in units of |e|), mass in GeV/c**2 and lifetime +CCC in seconds. See the Geant 3.15 Manual User's Guide, pages: CONS +CCC 300-1 and -2. + + Include 'common_particle.inc' + +CCC Local Variable Type Declarations: + + integer*4 i + + do i = 1,part_maxlen + part_id(i) = i + end do + +CCC Set Particle Masses: + + part_mass( 1) = 0.0 ! Gamma + part_mass( 2) = 0.00051099906 ! Positron + part_mass( 3) = 0.00051099906 ! Electron + part_mass( 4) = 0.0 ! Neutrino + part_mass( 5) = 0.105658389 ! Muon+ + part_mass( 6) = 0.105658389 ! Muon- + part_mass( 7) = 0.1349743 ! Pion0 + part_mass( 8) = 0.1395679 ! Pion+ + part_mass( 9) = 0.1395679 ! Pion- + part_mass(10) = 0.497671 ! Kaon 0 long + part_mass(11) = 0.493646 ! Kaon+ + part_mass(12) = 0.493646 ! Kaon- + part_mass(13) = 0.93956563 ! Neutron + part_mass(14) = 0.93827231 ! Proton + part_mass(15) = 0.93827231 ! Antiproton + part_mass(16) = 0.497671 ! Kaon 0 short + part_mass(17) = 0.54745 ! Eta + part_mass(18) = 1.11563 ! Lambda + part_mass(19) = 1.18937 ! Sigma+ + part_mass(20) = 1.19255 ! Sigma0 + part_mass(21) = 1.197465 ! Sigma- + part_mass(22) = 1.31485 ! Xi 0 + part_mass(23) = 1.32133 ! Xi - + part_mass(24) = 1.67243 ! Omega + part_mass(25) = 0.93956563 ! Antineutron + part_mass(26) = 1.11563 ! Antilambda + part_mass(27) = 1.18937 ! Anti-Sigma - + part_mass(28) = 1.19255 ! Anti-Sigma 0 + part_mass(29) = 1.197465 ! Anti-Sigma + + part_mass(30) = 1.31485 ! AntiXi 0 + part_mass(31) = 1.32133 ! AntiXi + + part_mass(32) = 1.67243 ! Anti-Omega + + part_mass(33) = 0.0 + part_mass(34) = 0.0 + part_mass(35) = 0.0 + part_mass(36) = 0.0 + part_mass(37) = 0.0 + part_mass(38) = 0.0 + part_mass(39) = 0.0 + part_mass(40) = 0.0 + part_mass(41) = 0.0 + part_mass(42) = 0.0 + part_mass(43) = 0.0 + part_mass(44) = 0.0 + part_mass(45) = 1.875613 ! Deuteron + part_mass(46) = 2.80925 ! Triton + part_mass(47) = 3.727417 ! Alpha + part_mass(48) = 0.0 ! Geantino (Fake particle) + part_mass(49) = 2.80923 ! He3 + part_mass(50) = 0.0 ! Cerenkov (Fake particle) + +CCC Set Particle Charge: + + part_charge( 1) = 0 ! Gamma + part_charge( 2) = 1 ! Positron + part_charge( 3) = -1 ! Electron + part_charge( 4) = 0 ! Neutrino + part_charge( 5) = 1 ! Muon+ + part_charge( 6) = -1 ! Muon- + part_charge( 7) = 0 ! Pion0 + part_charge( 8) = 1 ! Pion+ + part_charge( 9) = -1 ! Pion- + part_charge(10) = 0 ! Kaon 0 long + part_charge(11) = 1 ! Kaon+ + part_charge(12) = -1 ! Kaon- + part_charge(13) = 0 ! Neutron + part_charge(14) = 1 ! Proton + part_charge(15) = -1 ! Antiproton + part_charge(16) = 0 ! Kaon 0 short + part_charge(17) = 0 ! Eta + part_charge(18) = 0 ! Lambda + part_charge(19) = 1 ! Sigma+ + part_charge(20) = 0 ! Sigma0 + part_charge(21) = -1 ! Sigma- + part_charge(22) = 0 ! Xi 0 + part_charge(23) = -1 ! Xi - + part_charge(24) = -1 ! Omega + part_charge(25) = 0 ! Antineutron + part_charge(26) = 0 ! Antilambda + part_charge(27) = -1 ! Anti-Sigma - + part_charge(28) = 0 ! Anti-Sigma 0 + part_charge(29) = 1 ! Anti-Sigma + + part_charge(30) = 0 ! AntiXi 0 + part_charge(31) = 1 ! AntiXi + + part_charge(32) = 1 ! Anti-Omega + + part_charge(33) = 0 + part_charge(34) = 0 + part_charge(35) = 0 + part_charge(36) = 0 + part_charge(37) = 0 + part_charge(38) = 0 + part_charge(39) = 0 + part_charge(40) = 0 + part_charge(41) = 0 + part_charge(42) = 0 + part_charge(43) = 0 + part_charge(44) = 0 + part_charge(45) = 1 ! Deuteron + part_charge(46) = 1 ! Triton + part_charge(47) = 2 ! Alpha + part_charge(48) = 0 ! Geantino (Fake particle) + part_charge(49) = 2 ! He3 + part_charge(50) = 0 ! Cerenkov (Fake particle) + +CCC Set Particle Lifetimes: + + part_lifetime( 1) = 1.0E+30 ! Gamma + part_lifetime( 2) = 1.0E+30 ! Positron + part_lifetime( 3) = 1.0E+30 ! Electron + part_lifetime( 4) = 1.0E+30 ! Neutrino + part_lifetime( 5) = 2.19703E-06 ! Muon+ + part_lifetime( 6) = 2.19703E-06 ! Muon- + part_lifetime( 7) = 8.4E-17 ! Pion0 + part_lifetime( 8) = 2.603E-08 ! Pion+ + part_lifetime( 9) = 2.603E-08 ! Pion- + part_lifetime(10) = 5.16E-08 ! Kaon 0 long + part_lifetime(11) = 1.237E-08 ! Kaon+ + part_lifetime(12) = 1.237E-08 ! Kaon- + part_lifetime(13) = 889.1 ! Neutron + part_lifetime(14) = 1.0E+30 ! Proton + part_lifetime(15) = 1.0E+30 ! Antiproton + part_lifetime(16) = 8.922E-11 ! Kaon 0 short + part_lifetime(17) = 5.53085E-19 ! Eta + part_lifetime(18) = 2.632E-10 ! Lambda + part_lifetime(19) = 7.99E-11 ! Sigma+ + part_lifetime(20) = 7.40E-20 ! Sigma0 + part_lifetime(21) = 1.479E-10 ! Sigma- + part_lifetime(22) = 2.90E-10 ! Xi 0 + part_lifetime(23) = 1.639E-10 ! Xi - + part_lifetime(24) = 8.22E-11 ! Omega + part_lifetime(25) = 889.1 ! Antineutron + part_lifetime(26) = 2.632E-10 ! Antilambda + part_lifetime(27) = 7.99E-11 ! Anti-Sigma - + part_lifetime(28) = 7.40E-20 ! Anti-Sigma 0 + part_lifetime(29) = 1.479E-10 ! Anti-Sigma + + part_lifetime(30) = 2.90E-10 ! AntiXi 0 + part_lifetime(31) = 1.639E-10 ! AntiXi + + part_lifetime(32) = 8.22E-11 ! Anti-Omega + + part_lifetime(33) = 0.0 + part_lifetime(34) = 0.0 + part_lifetime(35) = 0.0 + part_lifetime(36) = 0.0 + part_lifetime(37) = 0.0 + part_lifetime(38) = 0.0 + part_lifetime(39) = 0.0 + part_lifetime(40) = 0.0 + part_lifetime(41) = 0.0 + part_lifetime(42) = 0.0 + part_lifetime(43) = 0.0 + part_lifetime(44) = 0.0 + part_lifetime(45) = 1.0E+30 ! Deuteron + part_lifetime(46) = 1.0E+30 ! Triton + part_lifetime(47) = 1.0E+30 ! Alpha + part_lifetime(48) = 1.0E+30 ! Geantino (Fake particle) + part_lifetime(49) = 1.0E+30 ! He3 + part_lifetime(50) = 1.0E+30 ! Cerenkov (Fake particle) + + Return + END + +C---------------------------------------------------------------- + + + subroutine correl_model + implicit none + +CCC This subroutine computes the requested 2-body model correlation +CCC function which is to be fitted by the track adjustment procedure. +CCC The model values are calculated on the requested fine and coarse +CCC mesh grid in momentum space. The model values are computed at the +CCC mid point of each 1D bin or at the center of each 3D cell. This +CCC could be refined at a later date to correspond to the integral of +CCC the model function over the bin width (cell volume) divided by the +CCC the bin width (cell volume). + +C The model includes the following options which are selected by the +C 'switch*' parameters in common/parameters/: +C +C switch_1d: 1D model as function of either Qinvar, Qtotal +C or Q-vector +C switch_3d: 3D model as function of either the Bertsch-Pratt +C side-out-long kinematics (but no cross term) or +C the Yano-Koonin-Podgoretski perp-parallel-time +C kinematics. +C switch_type: Like and/or Unlike particles +C switch_coherence: Purely incoherent source or a mixed incoherent- +C coherent source. +C switch_coulomb: Either (a) no Coulomb correction, (b) Gamow +C factor, (c) NA35 parametrization, or (d) Pratt +C Coulomb wave function integration for finite +C size, spherical source. +C switch_fermi_bose: Fermion or boson identical pairs. + + Include 'common_parameters.inc' + Include 'common_mesh.inc' + Include 'common_correlations.inc' + +CCC Local Variable Type Declarations: + + integer*4 i,j,k + + real*4 R_1dsq, Rsidesq, Routsq, Rlongsq + real*4 Rperpsq, Rparallelsq, R0sq + real*4 sqrtlambda,fermi_bose_sign,coulomb_factor,coherence_fac + real*4 q,q1,q2,q3 + real*4 b,b1,b2,b3 + real*4 massavg + +CCC Set Constants: + + sqrtlambda = sqrt(abs(lambda)) + R_1dsq = ((R_1d /hbc)**2)/2.0 + Rsidesq = ((Rside /hbc)**2)/2.0 + Routsq = ((Rout /hbc)**2)/2.0 + Rlongsq = ((Rlong /hbc)**2)/2.0 + Rperpsq = ((Rperp /hbc)**2)/2.0 + Rparallelsq = ((Rparallel/hbc)**2)/2.0 + R0sq = ((R0 /hbc)**2)/2.0 + + fermi_bose_sign = float(switch_fermi_bose) + coherence_fac = switch_coherence*2.0*sqrtlambda* + 1 (1.0 - sqrtlambda) + +CCC Determine average particle pair mass for Coulomb correction: + + massavg = 0.14 + if(mass1.eq.0.0 .and. mass2.gt.0.0) massavg = mass2 + if(mass1.gt.0.0 .and. mass2.eq.0.0) massavg = mass1 + if(mass1.gt.0.0 .and. mass2.gt.0.0) massavg = 0.5*(mass1+mass2) + +CCC Compute 1D correlation model arrays: + + If(switch_1d .ge. 1) then + If(n_1d_fine .gt. 0) then ! Fill the 1D fine mesh bins + q = -0.5*binsize_1d_fine + do i = 1,n_1d_fine + q = q + binsize_1d_fine + b = exp(-q*q*R_1dsq) + + if(switch_type.eq.1 .or. switch_type.eq.3) then + c2mod_like_1d(i) = 1.0 + fermi_bose_sign*(lambda + 1 *b*b + coherence_fac*b) + if(switch_coulomb.eq.0) then + coulomb_factor = 1.0 + else if(switch_coulomb.gt.0) then + Call coulomb(switch_coulomb,q,1,massavg,Q0, + 1 coulomb_factor) + end if + c2mod_like_1d(i) = coulomb_factor*c2mod_like_1d(i) + end if + + if(switch_type.eq.2 .or. switch_type.eq.3) then + c2mod_unlike_1d(i) = 1.0 + if(switch_coulomb.eq.0) then + coulomb_factor = 1.0 + else if(switch_coulomb.gt.0) then + Call coulomb(switch_coulomb,q,-1,massavg,Q0, + 1 coulomb_factor) + end if + c2mod_unlike_1d(i) = coulomb_factor*c2mod_unlike_1d(i) + end if + + end do ! End of 1D fine mesh filling do-loop + end if ! End of 1D fine mesh option + + If(n_1d_coarse .gt. 0) then ! Fill the 1D coarse mesh bins + q = qmid_1d -0.5*binsize_1d_coarse + do i = n_1d_fine + 1, n_1d_total + q = q + binsize_1d_coarse + b = exp(-q*q*R_1dsq) + + if(switch_type.eq.1 .or. switch_type.eq.3) then + c2mod_like_1d(i) = 1.0 + fermi_bose_sign*(lambda + 1 *b*b + coherence_fac*b) + if(switch_coulomb.eq.0) then + coulomb_factor = 1.0 + else if(switch_coulomb.gt.0) then + Call coulomb(switch_coulomb,q,1,massavg,Q0, + 1 coulomb_factor) + end if + c2mod_like_1d(i) = coulomb_factor*c2mod_like_1d(i) + end if + + if(switch_type.eq.2 .or. switch_type.eq.3) then + c2mod_unlike_1d(i) = 1.0 + if(switch_coulomb.eq.0) then + coulomb_factor = 1.0 + else if(switch_coulomb.gt.0) then + Call coulomb(switch_coulomb,q,-1,massavg,Q0, + 1 coulomb_factor) + end if + c2mod_unlike_1d(i) = coulomb_factor*c2mod_unlike_1d(i) + end if + + end do ! End of 1D coarse mesh filling do-loop + end if ! End of 1D coarse mesh option + end if ! End of 1D option + +CCC Compute 3D correlation model arrays: + + If(switch_3d .ge. 1) Then + If(n_3d_fine .gt. 0) then ! Fill the 3D fine mesh bins + q1 = -0.5*binsize_3d_fine + do i = 1,n_3d_fine + q1 = q1 + binsize_3d_fine + if(switch_3d.eq.1) b1=exp(-q1*q1*Rsidesq) + if(switch_3d.eq.2) b1=exp(-q1*q1*Rperpsq) + + q2 = -0.5*binsize_3d_fine + do j = 1,n_3d_fine + q2 = q2 + binsize_3d_fine + if(switch_3d.eq.1) b2=exp(-q2*q2*Routsq) + if(switch_3d.eq.2) b2=exp(-q2*q2*Rparallelsq) + + q3 = -0.5*binsize_3d_fine + do k = 1,n_3d_fine + q3 = q3 + binsize_3d_fine + if(switch_3d.eq.1) b3=exp(-q3*q3*Rlongsq) + if(switch_3d.eq.2) b3=exp(-q3*q3*R0sq) + + b = b1*b2*b3 + if(switch_3d.eq.1) q = sqrt(q1*q1+q2*q2+q3*q3) + if(switch_3d.eq.2) q = sqrt(q1*q1+q2*q2) + + if(switch_type.eq.1 .or. switch_type.eq.3) then + c2mod_like_3d_fine(i,j,k) = 1.0 + fermi_bose_sign*(lambda + 1 *b*b + coherence_fac*b) + if(switch_coulomb.eq.0) then + coulomb_factor = 1.0 + else if(switch_coulomb.gt.0) then + Call coulomb(switch_coulomb,q,1,massavg,Q0, + 1 coulomb_factor) + end if + c2mod_like_3d_fine(i,j,k) = + 1 coulomb_factor*c2mod_like_3d_fine(i,j,k) + end if + + if(switch_type.eq.2 .or. switch_type.eq.3) then + c2mod_unlike_3d_fine(i,j,k) = 1.0 + if(switch_coulomb.eq.0) then + coulomb_factor = 1.0 + else if(switch_coulomb.gt.0) then + Call coulomb(switch_coulomb,q,-1,massavg,Q0, + 1 coulomb_factor) + end if + c2mod_unlike_3d_fine(i,j,k) = + 1 coulomb_factor*c2mod_unlike_3d_fine(i,j,k) + end if + + end do + end do + end do ! End of 3D Fine Mesh Filling do-loops + end if ! End 3D fine mesh option + + If(n_3d_coarse .gt. 0) then ! Fill the 3D coarse mesh bins + q1 = -0.5*binsize_3d_coarse + do i = 1,n_3d_coarse + q1 = q1 + binsize_3d_coarse + if(switch_3d.eq.1) b1=exp(-q1*q1*Rsidesq) + if(switch_3d.eq.2) b1=exp(-q1*q1*Rperpsq) + + q2 = -0.5*binsize_3d_coarse + do j = 1,n_3d_coarse + q2 = q2 + binsize_3d_coarse + if(switch_3d.eq.1) b2=exp(-q2*q2*Routsq) + if(switch_3d.eq.2) b2=exp(-q2*q2*Rparallelsq) + + q3 = -0.5*binsize_3d_coarse + do k = 1,n_3d_coarse + q3 = q3 + binsize_3d_coarse + if(switch_3d.eq.1) b3=exp(-q3*q3*Rlongsq) + if(switch_3d.eq.2) b3=exp(-q3*q3*R0sq) + + b = b1*b2*b3 + if(switch_3d.eq.1) q = sqrt(q1*q1+q2*q2+q3*q3) + if(switch_3d.eq.2) q = sqrt(q1*q1+q2*q2) + + if(switch_type.eq.1 .or. switch_type.eq.3) then + c2mod_like_3d_coarse(i,j,k) = 1.0+fermi_bose_sign*(lambda + 1 *b*b + coherence_fac*b) + if(switch_coulomb.eq.0) then + coulomb_factor = 1.0 + else if(switch_coulomb.gt.0) then + Call coulomb(switch_coulomb,q,1,massavg,Q0, + 1 coulomb_factor) + end if + c2mod_like_3d_coarse(i,j,k) = + 1 coulomb_factor*c2mod_like_3d_coarse(i,j,k) + end if + + if(switch_type.eq.2 .or. switch_type.eq.3) then + c2mod_unlike_3d_coarse(i,j,k) = 1.0 + if(switch_coulomb.eq.0) then + coulomb_factor = 1.0 + else if(switch_coulomb.gt.0) then + Call coulomb(switch_coulomb,q,-1,massavg,Q0, + 1 coulomb_factor) + end if + c2mod_unlike_3d_coarse(i,j,k) = + 1 coulomb_factor*c2mod_unlike_3d_coarse(i,j,k) + end if + + end do + end do + end do ! End of 3D Coarse Mesh Filling do-loops + c2mod_like_3d_coarse(1,1,1) = 0.0 + c2mod_unlike_3d_coarse(1,1,1) = 0.0 + end if ! End of 3D Coarse Mesh Option + + End If ! End of 3D Option + + Return + END + +C---------------------------------------------------------------------- + + + subroutine coulomb(control,q,sign,mass,Q0,factor) + implicit none + +CCC Compute Coulomb correction to the two-body correlation functions +C for like and unlike charges for particles of the same mass. +C Three methods are allowed: +C +C If control = 1, Then use the gamow factor for point sources +C If control = 2, Then use the NA35 finite source size empirical +C correction factor from eq.(5) in Z. Phys. C73, +C 443 (1997). +C If control = 3, Then use the Pratt finite source size, numerically +C integrated Coulomb correction factor with inter- +C polated tables. +C +C Other parameters in the argument list are: +C +C q = 3-vector momentum difference for track pair, in GeV/c. +C sign = algebraic sign of the charge product for the track pair. +C mass = particle mass in GeV, it is assumed that both particles +C have the same mass, e.g. pi+ and pi-, but not K+ and pi-. +C Q0 = NA35 parameter in GeV/c if control = 2 +C = Source radius in fm if control = 3 +C factor = Multiplicative Coulomb correction result which is +C calculated here and returned to the calling program. +C + + Include 'common_coulomb.inc' + +CCC Local Variable Type Declarations: + + integer*4 control, sign + + real*4 pi,q,mass,Q0,factor,alpha,eta,eta2pi + real*4 gamow + parameter (pi = 3.141592654) + parameter (alpha = 0.00729735) + +CCC Compute Gamow factor for control options 1 and 2: + + if(control.eq.1 .or. control.eq.2) then + if(q .le. 0.001) then + if(sign .gt. 0) gamow = 0.0 + if(sign .lt. 0) gamow = 86.0 + else + eta = sign*mass*alpha/q + eta2pi = 2.0*pi*eta + gamow = eta2pi/(exp(eta2pi) - 1.0) + end if + end if + +CCC Compute Coulomb Correction factor for options 1, 2 and 3: + + if(control .eq. 1) then + factor = gamow + else if(control .eq. 2) then + factor = 1.0 + (gamow - 1.0)*exp(-q/Q0) + else if(control .eq. 3) then + + if(q .le. q_coul(1)) then + if(sign .gt. 0) factor = c2_coul_like(1) + if(sign .lt. 0) factor = c2_coul_unlike(1) + else if(q .ge. q_coul(max_c2_coul - 1)) then + if(sign .gt. 0) factor = c2_coul_like(max_c2_coul - 1) + if(sign .lt. 0) factor = c2_coul_unlike(max_c2_coul - 1) + else + if(sign .gt. 0) then + Call LAGRNG(q,q_coul,factor,c2_coul_like, + 1 max_c2_coul,1,5,max_c2_coul,1) + else if(sign .lt. 0) then + Call LAGRNG(q,q_coul,factor,c2_coul_unlike, + 1 max_c2_coul,1,5,max_c2_coul,1) + end if + end if + end if ! END Coulomb correction evaluation, control selection opt. + + Return + END + +C--------------------------------------------------------------------- + + + SUBROUTINE LAGRNG (X,ARG,Y,VAL,NDIM,NFS,NPTS,MAXARG,MAXFS) + IMPLICIT REAL*4(A-H,O-Z) +C +C LAGRANGE INTERPOLATION,UNEQUALLY SPACED POINTS +C ROUTINE OBTAINED FROM R. LANDAU, UNIV. OF OREGON. +C ARG=VECTOR OF INDEPENDENT VARIABLE CONTAINING MAXARG VALUES. +C VAL=MATRIX OF FUNCTION VALUES CORRESPONDING TO ARG. (MAXFS +C FUNCTIONS AT MAXARG VALUES.) +C X =VALUE OF INDEP. VARIABLE FOR WHICH INTERPOLATION IS DESIRED. +C Y =VECTOR OF MAXFS FUNCTION VALUES RESULTING FROM SIMUL. INTERP. +C NDIM=NUMBER OF ARG VALUES TO BE USED. (NDIM.LE.MAXARG) +C NFS=NUMBER OF FUNCTIONS SIMUL. INTERP (NFS.LE.MAXFS) +C NPTS=NUMBER OF POINTS USED IN INTERPOLATION. (NPTS=2,3,4,5,6) +C + DIMENSION ARG(MAXARG), VAL(MAXFS,MAXARG), Y(MAXFS) +C +C -----FIND X0, THE CLOSEST POINT TO X. +C + NI=1 + NF=NDIM + 10 IF ((X.LE.ARG(NI)).OR.(X.GE.ARG(NF))) GO TO 30 + IF ((NF-NI+1).EQ.2) GO TO 70 + NMID=(NF+NI)/2 + IF (X.GT.ARG(NMID)) GO TO 20 + NF=NMID + GO TO 10 + 20 NI=NMID + GO TO 10 +C +C ------ X IS ONE OF THE TABLULATED VALUES. +C + 30 IF (X.LE.ARG(NI)) GO TO 60 + NN=NF + 40 NUSED=0 + DO 50 N=1,NFS + 50 Y(N)=VAL(N,NN) + RETURN + 60 NN=NI + GO TO 40 +C +C ------- 2 PTS LEFT, CHOOSE SMALLER ONE. +C + 70 N0=NI + NN=NPTS-2 + GO TO (110,100,90,80), NN + 80 CONTINUE + IF (((N0+3).GT.NDIM).OR.((N0-2).LT.1)) GO TO 90 + NUSED=6 + GO TO 130 + 90 CONTINUE + IF ((N0+2).GT.NDIM) GO TO 110 + IF ((N0-2).LT.1) GO TO 100 + NUSED=5 + GO TO 130 + 100 CONTINUE + IF (((N0+2).GT.NDIM).OR.((N0-1).LT.1)) GO TO 110 + NUSED=4 + GO TO 130 + 110 IF ((N0+1).LT.NDIM) GO TO 120 +C +C ------N0=NDIM, SPECIAL CASE. +C + NN=NDIM + GO TO 40 + 120 NUSED=3 + IF ((N0-1).LT.1) NUSED=2 + 130 CONTINUE +C +C ------AT LEAST 2 PTS LEFT. +C + Y0=X-ARG(N0) + Y1=X-ARG(N0+1) + Y01=Y1-Y0 + C0=Y1/Y01 + C1=-Y0/Y01 + IF (NUSED.EQ.2) GO TO 140 +C +C ------AT LEAST 3 PTS. +C + YM1=X-ARG(N0-1) + Y0M1=YM1-Y0 + YM11=Y1-YM1 + CM1=-Y0*Y1/Y0M1/YM11 + C0=C0*YM1/Y0M1 + C1=-C1*YM1/YM11 + IF (NUSED.EQ.3) GO TO 160 +C +C ------AT LEAST 4 PTS +C + Y2=X-ARG(N0+2) + YM12=Y2-YM1 + Y02=Y2-Y0 + Y12=Y2-Y1 + CM1=CM1*Y2/YM12 + C0=C0*Y2/Y02 + C1=C1*Y2/Y12 + C2=-YM1*Y0*Y1/YM12/Y02/Y12 + IF (NUSED.EQ.4) GO TO 180 +C +C ------AT LEAST 5 PTS. +C + YM2=X-ARG(N0-2) + YM2M1=YM1-YM2 + YM20=Y0-YM2 + YM21=Y1-YM2 + YM22=Y2-YM2 + CM2=YM1*Y0*Y1*Y2/YM2M1/YM20/YM21/YM22 + CM1=-CM1*YM2/YM2M1 + C0=-C0*YM2/YM20 + C1=-C1*YM2/YM21 + C2=-C2*YM2/YM22 + IF (NUSED.EQ.5) GO TO 200 +C +C ------AT LEAST 6 PTS. +C + Y3=X-ARG(N0+3) + YM23=Y3-YM2 + YM13=Y3-YM1 + Y03=Y3-Y0 + Y13=Y3-Y1 + Y23=Y3-Y2 + CM2=CM2*Y3/YM23 + CM1=CM1*Y3/YM13 + C0=C0*Y3/Y03 + C1=C1*Y3/Y13 + C2=C2*Y3/Y23 + C3=YM2*YM1*Y0*Y1*Y2/YM23/YM13/Y03/Y13/Y23 + GO TO 220 + 140 CONTINUE + DO 150 N=1,NFS + 150 Y(N)=C0*VAL(N,N0)+C1*VAL(N,N0+1) + GO TO 240 + 160 CONTINUE + DO 170 N=1,NFS + 170 Y(N)=CM1*VAL(N,N0-1)+C0*VAL(N,N0)+C1*VAL(N,N0+1) + GO TO 240 + 180 CONTINUE + DO 190 N=1,NFS + 190 Y(N)=CM1*VAL(N,N0-1)+C0*VAL(N,N0)+C1*VAL(N,N0+1)+C2*VAL(N,N0+2) + GO TO 240 + 200 CONTINUE + DO 210 N=1,NFS + 210 Y(N)=CM2*VAL(N,N0-2)+CM1*VAL(N,N0-1)+C0*VAL(N,N0)+C1*VAL(N,N0+1)+C + 12*VAL(N,N0+2) + GO TO 240 + 220 CONTINUE + DO 230 N=1,NFS + 230 Y(N)=CM2*VAL(N,N0-2)+CM1*VAL(N,N0-1)+C0*VAL(N,N0)+C1*VAL(N,N0+1)+C + 12*VAL(N,N0+2)+C3*VAL(N,N0+3) + 240 RETURN +C + END + +C------------------------------------------------------------------- + + + subroutine Hbtp_kin(px,py,pz,E,pt,phi,eta,mass,control) + implicit none + +CCC Four-momentum kinematics conversion: +C +C If control = 1, use input {px,py,pz,mass} to calculate +C {E,pt,phi,eta} +C If control = 2, use input {pt,phi,eta,mass} to calculate +C {px,py,pz,E} +C +C Units: Momentum are in GeV/c +C Energy and mass are in GeV +C Angles are in degrees + +CCC Local Variable Type Declarations: + + integer*4 control + + real*4 px,py,pz,E,pt,phi,eta,mass + real*4 theta,pi,rad,pcut + parameter (pi = 3.141592654) + parameter (pcut = 0.000001) + + rad = 180.0/pi + + If(control .eq. 1) Then ! Use {px,py,pz,mass} --> {E,pt,phi,eta} + pt = sqrt(px*px + py*py) + E = sqrt(pt*pt + pz*pz + mass*mass) + +CCC Compute azimuthal angle phi; treat pt = 0.0 and py = 0.0 cases +CCC separate. + + if(pt .le. pcut) then + phi = 0.0 + else if(pt.gt.pcut.and.abs(py).le.pcut.and.px.lt.0.0) then + phi = pi + else + phi = atan2(py,px) + end if + if(phi .lt. 0.0) phi = phi + 2.0*pi + phi = phi*rad + +CCC Compute pseudorapidity: + + if(pt.le.pcut .and. abs(pz).le.pcut) then + eta = 0.0 + else if(pt.le.pcut .and. abs(pz).gt.pcut) then + eta = 0.5*log((E+pz)/(E-pz)) ! Use beam rapidity + else + theta = atan2(pt,pz) + eta = -log(tan(theta/2.0)) + end if + + Else If(control .eq. 2) Then ! Use {pt,phi,eta,mass} --> {E,px,py,pz} + + px = pt*cos(phi/rad) + py = pt*sin(phi/rad) + if(abs(eta) .le. pcut) then + pz = 0.0 + else + theta = 2.0*atan(exp(-eta)) + pz = pt/tan(theta) + end if + + E = sqrt(pt*pt + pz*pz + mass*mass) + + End If ! End control options + + Return + END + +C---------------------------------------------------------------------- + + + subroutine qdiff(px1,py1,pz1,E1,px2,py2,pz2,E2,qinvar2,qtotal2, + 1 qvector2,qside2,qout2,qlong2,qperp2,qtime2) + implicit none + +CCC This subroutine computes the various relative momenta for given +CCC input 4-momentum for particles 1 and 2. The subr: returns the +CCC square of the momentum. All energy and momenta are in GeV. +C +C Input 4-momentum for particle 1: {px1,py1,pz1,E1} +C Input 4-momentum for particle 2: {px2,py2,pz2,E2} +C +CCC Computed Momentum Differences are the following: +C +C qinvar2 = Q-invariant**2 +C qtotal2 = Q-Total**2 (space**2 + time**2) +C qvector2 = 3-momentum vector difference squared +C qside2 = q-side**2 of Bertsch-Pratt 3D source models +C qout2 = q-out**2 of Bertsch-Pratt 3D source models +C qlong2 = q-long**2 of Bertsch-Pratt 3D source models +C qperp2 = q-perpendicular**2 of YKP 3D source models +C qparallel2= q-parallel**2 of YKP 3D source models +C = qlong2 (not assigned a separate variable name) +C qtime2 = q-time-like**2 of YKP 3D source models + +CCC Local Variable Type Declarations: + + real*4 px1,py1,pz1,E1,px2,py2,pz2,E2 + real*4 qinvar2,qtotal2,qvector2 + real*4 qside2,qout2,qlong2 + real*4 qperp2,qtime2 + real*4 px12sq,py12sq,pz12sq,E12sq + + px12sq = (px1 - px2)**2 + py12sq = (py1 - py2)**2 + pz12sq = (pz1 - pz2)**2 + E12sq = (E1 - E2)**2 + + qvector2 = px12sq + py12sq + pz12sq + qinvar2 = qvector2 - E12sq + qtotal2 = qvector2 + E12sq + + qlong2 = pz12sq + qout2 = (px1*px1 - px2*px2 + py1*py1 - py2*py2) + qout2 = qout2*qout2/((px1+px2)**2 + (py1+py2)**2) + qperp2 = px12sq + py12sq + qside2 = qperp2 - qout2 + qtime2 = E12sq + if (qside2 .lt. 0) then +C write(*,*) 'qside2 is less then 0', qside2 +C write(*,*) ' qperp2, qout2', qperp2, qout2 +C write(*,*) ' px1,py1,pz1,E1 ',px1,py1,pz1,E1 +C write(*,*) ' px2,py2,pz2,E2 ',px2,py2,pz2,E2 + qside2 = 0.0 + end if + Return + END + +C----------------------------------------------------------------------- + + + subroutine mean_rms(a,ndim,npts,mean,rms) + implicit none + +CCC Calculate the mean and standard deviation (rms) for input +C distribution a() for npts number of values. +C ndim = dimension of array a() in calling program. + +CCC Local Variable Type Declarations: + + integer*4 ndim, npts, i + real*4 a(ndim), mean, rms, sum_mean, sum_rms + + if(npts .le. 0) then + mean = 0.0 + rms = 0.0 + return + else if(npts .eq. 1) then + mean = a(1) + rms = 0.0 + return + else + sum_mean = 0.0 + sum_rms = 0.0 + do i = 1,npts + sum_mean = sum_mean + a(i) + end do + mean = sum_mean/float(npts) + + do i = 1,npts + sum_rms = sum_rms + (a(i) - mean)**2 + end do + rms = sqrt((sum_rms)/float(npts - 1)) + return + end if + + END + +C----------------------------------------------------------------------- + + + subroutine tindex(mode,track_id) + implicit none + +CCC This subroutine locates tracks in {px,py,pz} sectors +C and sets the sector index numbers +C in track table 'trk' and/or 'trk2', depending on the value of 'mode'. +C If a track's momentum is out of the sector ranges, then the track +C will be assigned to, and counted in the nearest sector cell on the +C edge or corner. +C +C If mode = 1, apply to tracks in table 'trk' +C If mode = 2, apply to tracks in table 'trk2' +C +C If track_id = 0, then do this for all tracks +C If track_id = i (where i.gt.0) then do this for track row i only + + Include 'common_parameters.inc' + Include 'common_mesh.inc' + + Include 'common_track.inc' + Include 'common_track2.inc' + +CCC Local Variable Type Declarations: + + integer*4 i,track_id,mode + +C----------------------- + If(mode.eq.1) Then +C----------------------- + + If(track_id .eq. 0) Then + do i = 1,n_part_tot_trk + trk_px_sec(i) = int(((trk_px(i) - px_min)/delpx)+1.00001) + if(trk_px_sec(i) .lt.1) trk_px_sec(i) = 1 + if(trk_px_sec(i) .gt. n_px_bins) trk_px_sec(i) = n_px_bins + trk_py_sec(i) = int(((trk_py(i) - py_min)/delpy)+1.00001) + if(trk_py_sec(i) .lt.1) trk_py_sec(i) = 1 + if(trk_py_sec(i) .gt. n_py_bins) trk_py_sec(i) = n_py_bins + trk_pz_sec(i) = int(((trk_pz(i) - pz_min)/delpz)+1.00001) + if(trk_pz_sec(i) .lt.1) trk_pz_sec(i) = 1 + if(trk_pz_sec(i) .gt. n_pz_bins) trk_pz_sec(i) = n_pz_bins + trk_sector(i) = trk_px_sec(i) + (trk_py_sec(i) - 1)* + 1 n_px_bins + (trk_pz_sec(i) - 1)*n_px_bins*n_py_bins + end do + + Else If(track_id .gt. 0) Then + i = track_id + trk_px_sec(i) = int(((trk_px(i) - px_min)/delpx)+1.00001) + if(trk_px_sec(i) .lt.1) trk_px_sec(i) = 1 + if(trk_px_sec(i) .gt. n_px_bins) trk_px_sec(i) = n_px_bins + trk_py_sec(i) = int(((trk_py(i) - py_min)/delpy)+1.00001) + if(trk_py_sec(i) .lt.1) trk_py_sec(i) = 1 + if(trk_py_sec(i) .gt. n_py_bins) trk_py_sec(i) = n_py_bins + trk_pz_sec(i) = int(((trk_pz(i) - pz_min)/delpz)+1.00001) + if(trk_pz_sec(i) .lt.1) trk_pz_sec(i) = 1 + if(trk_pz_sec(i) .gt. n_pz_bins) trk_pz_sec(i) = n_pz_bins + trk_sector(i) = trk_px_sec(i) + (trk_py_sec(i) - 1)* + 1 n_px_bins + (trk_pz_sec(i) - 1)*n_px_bins*n_py_bins + End If + +C----------------------------- + Else If (mode.eq.2) Then +C----------------------------- + + If(track_id .eq. 0) Then + do i = 1,n_part_tot_trk2 + trk2_px_sec(i) = int(((trk2_px(i) - px_min)/delpx)+1.00001) + if(trk2_px_sec(i) .lt.1) trk2_px_sec(i) = 1 + if(trk2_px_sec(i) .gt. n_px_bins) trk2_px_sec(i) = n_px_bins + trk2_py_sec(i) = int(((trk2_py(i) - py_min)/delpy)+1.00001) + if(trk2_py_sec(i) .lt.1) trk2_py_sec(i) = 1 + if(trk2_py_sec(i) .gt. n_py_bins) trk2_py_sec(i) = n_py_bins + trk2_pz_sec(i) = int(((trk2_pz(i) - pz_min)/delpz)+1.00001) + if(trk2_pz_sec(i) .lt.1) trk2_pz_sec(i) = 1 + if(trk2_pz_sec(i) .gt. n_pz_bins) trk2_pz_sec(i) = n_pz_bins + trk2_sector(i) = trk2_px_sec(i) + (trk2_py_sec(i) - 1)* + 1 n_px_bins + (trk2_pz_sec(i) - 1)*n_px_bins*n_py_bins + end do + + Else If(track_id .gt. 0) Then + i = track_id + trk2_px_sec(i) = int(((trk2_px(i) - px_min)/delpx)+1.00001) + if(trk2_px_sec(i) .lt.1) trk2_px_sec(i) = 1 + if(trk2_px_sec(i) .gt. n_px_bins) trk2_px_sec(i) = n_px_bins + trk2_py_sec(i) = int(((trk2_py(i) - py_min)/delpy)+1.00001) + if(trk2_py_sec(i) .lt.1) trk2_py_sec(i) = 1 + if(trk2_py_sec(i) .gt. n_py_bins) trk2_py_sec(i) = n_py_bins + trk2_pz_sec(i) = int(((trk2_pz(i) - pz_min)/delpz)+1.00001) + if(trk2_pz_sec(i) .lt.1) trk2_pz_sec(i) = 1 + if(trk2_pz_sec(i) .gt. n_pz_bins) trk2_pz_sec(i) = n_pz_bins + trk2_sector(i) = trk2_px_sec(i) + (trk2_py_sec(i) - 1)* + 1 n_px_bins + (trk2_pz_sec(i) - 1)*n_px_bins*n_py_bins + End If + +C------------ + End If +C------------ + + Return + END + +C------------------------------------------------------------------------ + + + subroutine stm_build(mode,track_index,old_sector) + implicit none + +CCC This subroutine fills or updates the track-sector information +C table sec_trk_map or, for the reference calculations, it fills +C sec_trk_map2. These track-sector tables contain the information +C about the track occupancy, status, etc. for all of the {px,py,pz} +C sectors. +C +C For Mode = 1: +C +C If track_index = 0, then fill information for all tracks in 'trk', +C into table 'stm' +C If track_index = i (where i.gt.0) then fill only the track-sector +C information for track i in 'trk', into table 'stm' +C Also for this case, if old_sector .ne. 0, then +C remove the track # and ID information for this +C old sector # from table stm +C +C For Mode = 2: Fill information for all tracks in 'trk2' into table 'stm2' + + Include 'common_parameters.inc' + Include 'common_mesh.inc' + + Include 'common_track.inc' + Include 'common_track2.inc' + Include 'common_sec_track.inc' + Include 'common_sec_track2.inc' + +CCC Local Variable Type Declarations: + + integer*4 i,j,mode,track_index,old_sector,row + integer*4 temp(max_trk_sec) + +C------------------------ + IF (mode.eq.1) Then +C------------------------ + + If (track_index .eq. 0) Then + do i = 1,sec_maxlen + stm_sec_id(i) = 0 + stm_n_trk_sec(i) = 0 + do j = 1,max_trk_sec + stm_track_id(j,i) = 0 + end do + stm_flag(i) = 0 + end do + do i = 1,n_sectors + stm_sec_id(i) = i + end do + do i = 1,n_part_tot_trk + if(trk_flag(i) .eq. 0) then + row = trk_sector(i) + stm_n_trk_sec(row) = stm_n_trk_sec(row) + 1 + if(stm_n_trk_sec(row) .le. max_trk_sec) then + stm_track_id(stm_n_trk_sec(row),row) = trk_id(i) + stm_flag(row) = 0 + trk_flag(i) = 0 + else + stm_n_trk_sec(row) = stm_n_trk_sec(row) - 1 + stm_flag(row) = 1 + trk_flag(i) = 1 + trk_sector(i) = 0 + end if + end if + end do + + Else If (track_index .gt. 0) Then + + if(old_sector .ne. 0) then +CCC Remove track from old sector: + j = 0 + do i = 1,stm_n_trk_sec(old_sector) + if(stm_track_id(i,old_sector) .ne. track_index) then + j = j + 1 + temp(j) = stm_track_id(i,old_sector) + end if + end do + stm_n_trk_sec(old_sector) = j + do i = 1,max_trk_sec + stm_track_id(i,old_sector) = 0 + end do + do i = 1,stm_n_trk_sec(old_sector) + stm_track_id(i,old_sector) = temp(i) + end do + end if +CCC Update with new sector location of track: + i = track_index + if(trk_flag(i) .eq. 0) then + row = trk_sector(i) + stm_n_trk_sec(row) = stm_n_trk_sec(row) + 1 + if(stm_n_trk_sec(row) .le. max_trk_sec) then + stm_track_id(stm_n_trk_sec(row),row) = trk_id(i) + stm_flag(row) = 0 + trk_flag(i) = 0 + else + stm_n_trk_sec(row) = stm_n_trk_sec(row) - 1 + stm_flag(row) = 1 + trk_flag(i) = 1 + trk_sector(i) = 0 + end if + end if + End If + +C----------------------------- + Else If (mode.eq.2) Then +C----------------------------- + + If (track_index .eq. 0) Then + do i = 1,sec_maxlen2 + stm2_sec_id(i) = 0 + stm2_n_trk_sec(i) = 0 + do j = 1,max_trk_sec2 + stm2_track_id(j,i) = 0 + end do + stm2_flag(i) = 0 + end do + do i = 1,n_sectors + stm2_sec_id(i) = i + end do + do i = 1,n_part_tot_trk2 + if(trk2_flag(i) .eq. 0) then + row = trk2_sector(i) + stm2_n_trk_sec(row) = stm2_n_trk_sec(row) + 1 + if(stm2_n_trk_sec(row) .le. max_trk_sec2) then + stm2_track_id(stm2_n_trk_sec(row),row) = trk2_id(i) + stm2_flag(row) = 0 + trk2_flag(i) = 0 + else + stm2_n_trk_sec(row) = stm2_n_trk_sec(row) - 1 + stm2_flag(row) = 1 + trk2_flag(i) = 1 + trk2_sector(i) = 0 + end if + end if + end do + end if + +C------------ + End If ! End mode = 1,2 selection options +C------------ + + Return + END + +C----------------------------------------------------------------------- + + + subroutine sec_index(index,nbins,index_min,index_max) + implicit none + +CCC Calculate track-sector neighboring bins and min->max range: + +CCC Local Variable Type Declarations: + + integer*4 index,nbins,index_min,index_max + + index_min = index - 1 + if(index_min .lt. 1) index_min = 1 + index_max = index + 1 + if(index_max .gt. nbins) index_max = nbins + + Return + END + +C----------------------------------------------------------------------- + + + subroutine dist_range(mode,ntracks_out,ntracks_flagged) + implicit none + +CCC Determine if tracks are out of acceptance range in pt, phi and eta, +C and, if so, then set the 'out_flag' variable in the track table 'trk' + +CCC For Mode = 1, use track table 'trk' +CCC For Mode = 2, use track table 'trk2' + +CCC Count the number of flagged tracks, i.e. trk(i).flag = 1, and "out +C of acceptance range" tracks, i.e. trk(i).out_flag = 1, for both +C particle ID types. Determine the number of tracks to use in the +C correlation fit for each particle ID type. + + Include 'common_parameters.inc' + Include 'common_mesh.inc' + + Include 'common_track.inc' + Include 'common_track2.inc' + +CCC Local Variable Type Declarations: + + integer*4 i,mode,ntracks_out,ntracks_flagged + +C------------------------ + If (mode.eq.1) Then +C------------------------ + + do i = 1,trk_maxlen + trk_out_flag(i) = 0 + end do + + ntracks_flagged = 0 + + do i = 1,n_part_tot_trk + if(trk_flag(i) .eq. 0) then + if(trk_pt(i) .lt. pt_min .or. trk_pt(i) .gt. pt_max) + 1 trk_out_flag(i)=1 + if(trk_phi(i).lt.phi_min .or. trk_phi(i).gt.phi_max) + 1 trk_out_flag(i)=1 + if(trk_eta(i).lt.eta_min .or. trk_eta(i).gt.eta_max) + 1 trk_out_flag(i)=1 + else if(trk_flag(i) .eq. 1) then + ntracks_flagged = ntracks_flagged + 1 + end if + end do + + ntracks_out = 0 + do i = 1,n_part_tot_trk + if(trk_out_flag(i) .eq. 1) ntracks_out = ntracks_out + 1 + end do + + n_part_used_1_trk = 0 + n_part_used_2_trk = 0 + do i = 1,n_part_tot_trk + if(trk_flag(i) .eq. 0) then + if(trk_ge_pid(i) .eq. pid(1)) then + n_part_used_1_trk = n_part_used_1_trk + 1 + else if(trk_ge_pid(i) .eq. pid(2)) then + n_part_used_2_trk = n_part_used_2_trk + 1 + end if + end if + end do + +C----------------------------- + Else If (mode.eq.2) Then +C----------------------------- + + do i = 1,trk2_maxlen + trk2_out_flag(i) = 0 + end do + + ntracks_flagged = 0 + + do i = 1,n_part_tot_trk2 + if(trk2_flag(i) .eq. 0) then + if(trk2_pt(i) .lt. pt_min .or. trk2_pt(i) .gt. pt_max) + 1 trk2_out_flag(i)=1 + if(trk2_phi(i).lt.phi_min .or. trk2_phi(i).gt.phi_max) + 1 trk2_out_flag(i)=1 + if(trk2_eta(i).lt.eta_min .or. trk2_eta(i).gt.eta_max) + 1 trk2_out_flag(i)=1 + else if(trk2_flag(i) .eq. 1) then + ntracks_flagged = ntracks_flagged + 1 + end if + end do + + ntracks_out = 0 + do i = 1,n_part_tot_trk2 + if(trk2_out_flag(i) .eq. 1) ntracks_out = ntracks_out + 1 + end do + + n_part_used_1_trk2 = 0 + n_part_used_2_trk2 = 0 + do i = 1,n_part_tot_trk2 + if(trk2_flag(i) .eq. 0) then + if(trk2_ge_pid(i) .eq. pid(1)) then + n_part_used_1_trk2 = n_part_used_1_trk2 + 1 + else if(trk2_ge_pid(i) .eq. pid(2)) then + n_part_used_2_trk2 = n_part_used_2_trk2 + 1 + end if + end if + end do + +C------------ + End If ! End mode = 1,2 selection option +C------------ + + Return + END + +C-------------------------------------------------------------------- + + + subroutine histog1(mode,itrack,pid_index,pidnum,pt_save, + 1 phi_save,eta_save) + implicit none + +CCC This subroutine computes and/or updates the one-body histograms +C according to the selected 'mode' and for the requested particle +C ID type. + +C Note: If the track momentum is out-of-range in {pt,phi,eta}, +C then it is ignored. The {pt,phi,eta} dependences for +C the 1-dimensional histogramming are treated independently. +C It is therefore possible for the sum of the number of +C particles in the pt, phi and eta one-body, 1D histograms +C to be unequal. + +CCC Mode = 1, Fill the one-body histograms (hist1*) for selected +C particle ID type, for the initial input distribution, +C using the momenta in 'trk' +C +C Mode = 2, Remove particle 'itrack' from temporary one-body hist- +C ogram (htmp1*) for selected particle ID type, using +C momentum values given by pt_save, phi_save, eta_save. +C +C Mode = 3, Add particle 'itrack' to the temporary one-body hist- +C ogram (htmp1*) for selected particle ID type, using +C momentum values in track table 'trk'. +C +C Mode = 4, Fill the one-body histograms (hist1*) for selected +C particle ID type, for the initial input distribution, +C using the momenta in 'trk2' +C +C itrack = track index # for the removed or added track for mode = +C 2 or 3, respectively. +C +C pid_index = 1 or 2 for the first or second particle ID type, and +C for filling/update either hist1*1 or hist1*2, and +C similarly for htmp1*1 or htmp1*2 +C +C pidnum = Geant particle ID # for the track(s) to be filled or +C updated. +C +C pt_save = Removed track's pt value. +C +C phi_save = Removed track's phi value. +C +C eta_save = Removed track's eta value. + + Include 'common_parameters.inc' + Include 'common_mesh.inc' + Include 'common_histograms.inc' + + Include 'common_track.inc' + Include 'common_track2.inc' + +CCC Local Variable Type Declarations: + + integer*4 mode,itrack,i,pid_index,pidnum,index + integer*4 trk_counter,trk2_counter + + real*4 pt_save,phi_save,eta_save + real*4 delpt,delphi,deleta + +C------------------------- + If (mode.eq.1) Then +C------------------------- + +CCC Fill one-body histograms for requested particle ID from table 'trk' +CCC Initialize necessary arrays to zero: + + if(pid_index .eq. 1) then + do i = 1,max_h_1d + hist1_pt_1(i) = 0 + hist1_phi_1(i) = 0 + hist1_eta_1(i) = 0 + end do + else if(pid_index .eq. 2) then + do i = 1,max_h_1d + hist1_pt_2(i) = 0 + hist1_phi_2(i) = 0 + hist1_eta_2(i) = 0 + end do + end if + + trk_counter = 0 + + do i = 1,n_part_tot_trk + if(trk_ge_pid(i).eq.pidnum .and. trk_flag(i).eq.0) then + trk_counter = trk_counter + 1 + delpt = trk_pt(i) - pt_min + delphi = trk_phi(i) - phi_min + deleta = trk_eta(i) - eta_min + + index = int((delpt/pt_bin_size) + 0.99999) + if(index.ge.1 .and. index.le.max_h_1d) then + if(pid_index.eq.1) hist1_pt_1(index) = + 1 hist1_pt_1(index) + 1 + if(pid_index.eq.2) hist1_pt_2(index) = + 1 hist1_pt_2(index) + 1 + end if + + index = int((delphi/phi_bin_size) + 0.99999) + if(index.ge.1 .and. index.le.max_h_1d) then + if(pid_index.eq.1) hist1_phi_1(index) = + 1 hist1_phi_1(index) + 1 + if(pid_index.eq.2) hist1_phi_2(index) = + 1 hist1_phi_2(index) + 1 + end if + + index = int((deleta/eta_bin_size) + 0.99999) + if(index.ge.1 .and. index.le.max_h_1d) then + if(pid_index.eq.1) hist1_eta_1(index) = + 1 hist1_eta_1(index) + 1 + if(pid_index.eq.2) hist1_eta_2(index) = + 1 hist1_eta_2(index) + 1 + end if + + end if + end do + + if(pid_index .eq. 1) n_part_used_1_trk = trk_counter + if(pid_index .eq. 2) n_part_used_2_trk = trk_counter + +C-------------------------------- + Else If (mode .eq. 2) Then +C-------------------------------- + +CCC Remove track # 'itrack' from fitting histograms in htmp1*, +CCC use pt_save, phi_save, eta_save for the old momentum values +CCC in order to determine which bins to decrement. + + if(trk_ge_pid(itrack).eq.pidnum.and.trk_flag(itrack).eq.0)then + delpt = pt_save - pt_min + delphi = phi_save - phi_min + deleta = eta_save - eta_min + + index = int((delpt/pt_bin_size) + 0.99999) + if(index.ge.1 .and. index.le.max_h_1d) then + if(pid_index.eq.1) htmp1_pt_1(index) = + 1 htmp1_pt_1(index) - 1 + if(pid_index.eq.2) htmp1_pt_2(index) = + 1 htmp1_pt_2(index) - 1 + end if + + index = int((delphi/phi_bin_size) + 0.99999) + if(index.ge.1 .and. index.le.max_h_1d) then + if(pid_index.eq.1) htmp1_phi_1(index) = + 1 htmp1_phi_1(index) - 1 + if(pid_index.eq.2) htmp1_phi_2(index) = + 1 htmp1_phi_2(index) - 1 + end if + + index = int((deleta/eta_bin_size) + 0.99999) + if(index.ge.1 .and. index.le.max_h_1d) then + if(pid_index.eq.1) htmp1_eta_1(index) = + 1 htmp1_eta_1(index) - 1 + if(pid_index.eq.2) htmp1_eta_2(index) = + 1 htmp1_eta_2(index) - 1 + end if + + end if + +C-------------------------------- + Else If (mode .eq. 3) Then +C-------------------------------- + +CCC Add track # 'itrack' to fitting histograms in htmp1*, +CCC use pt, phi and eta values in track table 'trk(itrack)' +CCC for the new/added track position. + + if(trk_ge_pid(itrack).eq.pidnum.and.trk_flag(itrack).eq.0)then + delpt = trk_pt(itrack) - pt_min + delphi = trk_phi(itrack) - phi_min + deleta = trk_eta(itrack) - eta_min + + index = int((delpt/pt_bin_size) + 0.99999) + if(index.ge.1 .and. index.le.max_h_1d) then + if(pid_index.eq.1) htmp1_pt_1(index) = + 1 htmp1_pt_1(index) + 1 + if(pid_index.eq.2) htmp1_pt_2(index) = + 1 htmp1_pt_2(index) + 1 + end if + + index = int((delphi/phi_bin_size) + 0.99999) + if(index.ge.1 .and. index.le.max_h_1d) then + if(pid_index.eq.1) htmp1_phi_1(index) = + 1 htmp1_phi_1(index) + 1 + if(pid_index.eq.2) htmp1_phi_2(index) = + 1 htmp1_phi_2(index) + 1 + end if + + index = int((deleta/eta_bin_size) + 0.99999) + if(index.ge.1 .and. index.le.max_h_1d) then + if(pid_index.eq.1) htmp1_eta_1(index) = + 1 htmp1_eta_1(index) + 1 + if(pid_index.eq.2) htmp1_eta_2(index) = + 1 htmp1_eta_2(index) + 1 + end if + + end if + +C------------------------------ + Else If (mode.eq.4) Then +C------------------------------ + +CCC Fill one-body histograms for requested particle ID from table 'trk2' +CCC Initialize necessary arrays to zero: + + if(pid_index .eq. 1) then + do i = 1,max_h_1d + hist1_pt_1(i) = 0 + hist1_phi_1(i) = 0 + hist1_eta_1(i) = 0 + end do + else if(pid_index .eq. 2) then + do i = 1,max_h_1d + hist1_pt_2(i) = 0 + hist1_phi_2(i) = 0 + hist1_eta_2(i) = 0 + end do + end if + + trk2_counter = 0 + + do i = 1,n_part_tot_trk2 + if(trk2_ge_pid(i).eq.pidnum .and. trk2_flag(i).eq.0) then + trk2_counter = trk2_counter + 1 + delpt = trk2_pt(i) - pt_min + delphi = trk2_phi(i) - phi_min + deleta = trk2_eta(i) - eta_min + + index = int((delpt/pt_bin_size) + 0.99999) + if(index.ge.1 .and. index.le.max_h_1d) then + if(pid_index.eq.1) hist1_pt_1(index) = + 1 hist1_pt_1(index) + 1 + if(pid_index.eq.2) hist1_pt_2(index) = + 1 hist1_pt_2(index) + 1 + end if + + index = int((delphi/phi_bin_size) + 0.99999) + if(index.ge.1 .and. index.le.max_h_1d) then + if(pid_index.eq.1) hist1_phi_1(index) = + 1 hist1_phi_1(index) + 1 + if(pid_index.eq.2) hist1_phi_2(index) = + 1 hist1_phi_2(index) + 1 + end if + + index = int((deleta/eta_bin_size) + 0.99999) + if(index.ge.1 .and. index.le.max_h_1d) then + if(pid_index.eq.1) hist1_eta_1(index) = + 1 hist1_eta_1(index) + 1 + if(pid_index.eq.2) hist1_eta_2(index) = + 1 hist1_eta_2(index) + 1 + end if + + end if + end do + + if(pid_index .eq. 1) n_part_used_1_trk2 = trk2_counter + if(pid_index .eq. 2) n_part_used_2_trk2 = trk2_counter + +C------------ + End If ! End Mode = 1,2,3,4 Selection Options +C------------ + + Return + END + +C----------------------------------------------------------------------- + + subroutine histog2(mode,itrack,px_sec_save,py_sec_save, + 1 pz_sec_save,px_save,py_save,pz_save,E_save) + implicit none + +CCC This subroutine computes and/or updates the two-body histograms +C according to the selected 'mode' and for the necessary particle +C ID type(s). + +C Mode = 1, Fill the two-body histograms (hist*) for all particles +C in table 'trk' for like and unlike pairs, for 1D and/or +C 3D fine and 3D coarse mesh bins. +C +C Mode = 2, Remove all old track pairs for 'itrack' particle from +C all htmp* histograms, for particles in table 'trk', for +C like and unlike pairs, for 1D and/or 3D fine and 3D coarse +C mesh bins; using the saved momentum and track values. +C +C Mode = 3, Add all new track pairs for 'itrack' particle to +C all htmp* histograms, for particles in table 'trk', for +C like and unlike pairs, for 1D and/or 3D fine and 3D coarse +C mesh bins; using the values in table 'trk(itrack).*' +C +C Mode = 4, Fill and accumulate reference histograms (href*) for all +C particle pairs from tables 'trk' and 'trk2', for like and +C unlike pairs, for 1D and/or 3D fine and 3D coarse +C mesh bins. +C +C itrack = single track index in table 'trk' for pairs to be removed +C (mode = 2) or added (mode = 3). + + Include 'common_parameters.inc' + Include 'common_mesh.inc' + Include 'common_histograms.inc' + + Include 'common_track.inc' + Include 'common_track2.inc' + Include 'common_sec_track.inc' + Include 'common_sec_track2.inc' + +CCC Local Variable Type Declarations: + + integer*4 mode,itrack,i,j,k,jx,jy,jz + integer*4 jsec,trkj_sector,imin,imax,njtrks + integer*4 index1,index2,index3 + integer*4 findex1,findex2,findex3 + integer*4 ipxmin,ipymin,ipzmin + integer*4 ipxmax,ipymax,ipzmax + integer*4 trki_pid,trkj_pid + integer*4 px_sec_save,py_sec_save,pz_sec_save + + real*4 qinvar2,qtotal2,qvector2 + real*4 qside2, qout2, qlong2 + real*4 qperp2, qtime2 + real*4 qdiff1, qdiff2, qdiff3 + real*4 px_save,py_save,pz_save,E_save + + If (mode .eq. 1) Then ! Full hist* filling; initialize arrays to zero. + + do i = 1,max_h_1d + hist_like_1d(i) = 0 + hist_unlike_1d(i) = 0 + end do + + do i = 1,max_h_3d + do j = 1,max_h_3d + do k = 1,max_h_3d + hist_like_3d_fine(i,j,k) = 0 + hist_unlike_3d_fine(i,j,k) = 0 + hist_like_3d_coarse(i,j,k) = 0 + hist_unlike_3d_coarse(i,j,k) = 0 + end do + end do + end do + + End If + +CCC Select # of particles to loop over for each 'mode': + + If (mode .eq. 1) Then + imin = 2 + imax = n_part_tot_trk + Else If (mode .eq. 2 .or. mode .eq. 3) Then + imin = itrack + imax = itrack + Else If (mode .eq. 4) Then + imin = 1 + imax = n_part_tot_trk + End If + +C------------------------------------------------------ +CCC Begin Primary Loop over particles in Table 'trk': +C------------------------------------------------------ + + do i = imin,imax + if(trk_flag(i) .eq. 0) then + trki_pid = trk_ge_pid(i) + if(mode.eq.2) then + Call sec_index(px_sec_save,n_px_bins,ipxmin,ipxmax) + Call sec_index(py_sec_save,n_py_bins,ipymin,ipymax) + Call sec_index(pz_sec_save,n_pz_bins,ipzmin,ipzmax) + else + Call sec_index(trk_px_sec(i),n_px_bins,ipxmin,ipxmax) + Call sec_index(trk_py_sec(i),n_py_bins,ipymin,ipymax) + Call sec_index(trk_pz_sec(i),n_pz_bins,ipzmin,ipzmax) + end if + +CCC Begin Loop over neighboring sectors for track # 'i': + + do jx = ipxmin,ipxmax + do jy = ipymin,ipymax + do jz = ipzmin,ipzmax + trkj_sector = jx + (jy-1)*n_px_bins + 1 + (jz-1)*n_px_bins*n_py_bins + njtrks = 0 + if(mode.le.3) njtrks = stm_n_trk_sec(trkj_sector) + if(mode.eq.4) njtrks = stm2_n_trk_sec(trkj_sector) + if(njtrks .gt. 0) then + +CCC Begin Secondary Loop over particles in selected sectors in tables +CCC 'trk' or 'trk2': + do jsec = 1,njtrks + if(mode.le.3) j = stm_track_id(jsec,trkj_sector) + if(mode.eq.4) j = stm2_track_id(jsec,trkj_sector) + if((mode.eq.1 .and. j.lt.i .and. trk_flag(j).eq.0) + 1 .or.(mode.eq.2 .and. j.ne.i .and. trk_flag(j).eq.0) + 2 .or.(mode.eq.3 .and. j.ne.i .and. trk_flag(j).eq.0) + 3 .or.(mode.eq.4 .and. trk2_flag(j).eq.0)) then + +CCC Obtain 1D and 3D relative momenta: + + if(mode.eq.1 .or. mode.eq.3) then + trkj_pid = trk_ge_pid(j) + Call qdiff(trk_px(i),trk_py(i),trk_pz(i),trk_E(i), + 1 trk_px(j),trk_py(j),trk_pz(j),trk_E(j), + 2 qinvar2,qtotal2,qvector2,qside2,qout2,qlong2, + 3 qperp2,qtime2) + else if(mode.eq.2) then + trkj_pid = trk_ge_pid(j) + Call qdiff(px_save,py_save,pz_save,E_save, + 1 trk_px(j),trk_py(j),trk_pz(j),trk_E(j), + 2 qinvar2,qtotal2,qvector2,qside2,qout2,qlong2, + 3 qperp2,qtime2) + else if(mode.eq.4) then + trkj_pid = trk2_ge_pid(j) + Call qdiff(trk_px(i),trk_py(i),trk_pz(i),trk_E(i), + 1 trk2_px(j),trk2_py(j),trk2_pz(j),trk2_E(j), + 2 qinvar2,qtotal2,qvector2,qside2,qout2,qlong2, + 3 qperp2,qtime2) + end if + +C----------------------------------------------- +CCC Fill and/or Update 1D two-body Histograms: +C----------------------------------------------- + + if(switch_1d .gt. 0) then + + if(switch_1d .eq. 1) then + qdiff1 = sqrt(qinvar2) + else if(switch_1d .eq. 2) then + qdiff1 = sqrt(qtotal2) + else if(switch_1d .eq. 3) then + qdiff1 = sqrt(qvector2) + else + qdiff1 = sqrt(qvector2) + end if + + if(qdiff1 .le. qmid_1d) then + index1 = int((qdiff1/binsize_1d_fine)+0.99999) + if(index1 .eq. 0) index1 = 1 + else if(qdiff1.gt.qmid_1d.and.qdiff1.le.qmax_1d) then + index1 = int(((qdiff1-qmid_1d)/binsize_1d_coarse) + 1 + 0.99999) + if(index1.eq.0) index1 = 1 + index1 = index1 + n_1d_fine + else + index1 = -86 + end if + + if(index1.ge.1.and.index1.le.n_1d_total) then + if((trki_pid.eq.trkj_pid).and.(switch_type.eq.1 + 1 .or. switch_type.eq.3)) then + if(mode.eq.1) then + hist_like_1d(index1) = hist_like_1d(index1) + 1 + else if(mode.eq.2) then + htmp_like_1d(index1) = htmp_like_1d(index1) - 1 + else if(mode.eq.3) then + htmp_like_1d(index1) = htmp_like_1d(index1) + 1 + else if(mode.eq.4) then + href_like_1d(index1) = href_like_1d(index1) + 1 + end if + + else if((trki_pid.ne.trkj_pid).and.(switch_type.eq.2 + 1 .or. switch_type.eq.3)) then + if(mode.eq.1) then + hist_unlike_1d(index1) = hist_unlike_1d(index1)+1 + else if(mode.eq.2) then + htmp_unlike_1d(index1) = htmp_unlike_1d(index1)-1 + else if(mode.eq.3) then + htmp_unlike_1d(index1) = htmp_unlike_1d(index1)+1 + else if(mode.eq.4) then + href_unlike_1d(index1) = href_unlike_1d(index1)+1 + end if + + end if + end if + end if ! End 1D Histogram Fill and/or Update. + +C----------------------------------------------- +CCC Fill and/or Update 3D Two-Body Histograms: +C----------------------------------------------- + + if(switch_3d .gt. 0) then + if(switch_3d .eq. 1) then + qdiff1 = sqrt(qside2) + qdiff2 = sqrt(qout2) + qdiff3 = sqrt(qlong2) + else if(switch_3d .eq. 2) then + qdiff1 = sqrt(qperp2) + qdiff2 = sqrt(qtime2) + qdiff3 = sqrt(qlong2) + else + qdiff1 = sqrt(qperp2) + qdiff2 = sqrt(qtime2) + qdiff3 = sqrt(qlong2) + end if + + if(qdiff1 .le. qmid_3d) then + findex1 = int((qdiff1/binsize_3d_fine)+0.99999) + if(findex1 .eq. 0) findex1 = 1 + index1 = 1 + else if(qdiff1.gt.qmid_3d.and.qdiff1.le.qmax_3d) then + index1 = int((qdiff1/binsize_3d_coarse)+0.99999) + if(index1.eq.1) index1 = 2 + findex1 = 0 + else + index1 = -86 + findex1 = -86 + end if + + if(qdiff2 .le. qmid_3d) then + findex2 = int((qdiff2/binsize_3d_fine)+0.99999) + if(findex2 .eq. 0) findex2 = 1 + index2 = 1 + else if(qdiff2.gt.qmid_3d.and.qdiff2.le.qmax_3d) then + index2 = int((qdiff2/binsize_3d_coarse)+0.99999) + if(index2.eq.1) index2 = 2 + findex2 = 0 + else + index2 = -86 + findex2 = -86 + end if + + if(qdiff3 .le. qmid_3d) then + findex3 = int((qdiff3/binsize_3d_fine)+0.99999) + if(findex3 .eq. 0) findex3 = 1 + index3 = 1 + else if(qdiff3.gt.qmid_3d.and.qdiff3.le.qmax_3d) then + index3 = int((qdiff3/binsize_3d_coarse)+0.99999) + if(index3.eq.1) index3 = 2 + findex3 = 0 + else + index3 = -86 + findex3 = -86 + end if + + if((index1.ge.1.and.index1.le.n_3d_coarse).and. + 1 (index2.ge.1.and.index2.le.n_3d_coarse).and. + 2 (index3.ge.1.and.index3.le.n_3d_coarse)) then + + if((index1+index2+index3).eq.3) then + + if(findex1.ge.1.and.findex1.le.n_3d_fine.and. + 1 findex2.ge.1.and.findex2.le.n_3d_fine.and. + 2 findex3.ge.1.and.findex3.le.n_3d_fine) then + + if((trki_pid.eq.trkj_pid).and.(switch_type.eq.1 + 1 .or. switch_type.eq.3)) then + + if(mode.eq.1) then + hist_like_3d_fine(findex1,findex2,findex3) = + 1 hist_like_3d_fine(findex1,findex2,findex3) +1 + else if(mode.eq.2) then + htmp_like_3d_fine(findex1,findex2,findex3) = + 1 htmp_like_3d_fine(findex1,findex2,findex3) -1 + else if(mode.eq.3) then + htmp_like_3d_fine(findex1,findex2,findex3) = + 1 htmp_like_3d_fine(findex1,findex2,findex3) +1 + else if(mode.eq.4) then + href_like_3d_fine(findex1,findex2,findex3) = + 1 href_like_3d_fine(findex1,findex2,findex3) +1 + end if + + else if((trki_pid.ne.trkj_pid).and.(switch_type + 1 .eq.2 .or. switch_type.eq.3)) then + + if(mode.eq.1) then + hist_unlike_3d_fine(findex1,findex2,findex3) = + 1 hist_unlike_3d_fine(findex1,findex2,findex3) +1 + else if(mode.eq.2) then + htmp_unlike_3d_fine(findex1,findex2,findex3) = + 1 htmp_unlike_3d_fine(findex1,findex2,findex3) -1 + else if(mode.eq.3) then + htmp_unlike_3d_fine(findex1,findex2,findex3) = + 1 htmp_unlike_3d_fine(findex1,findex2,findex3) +1 + else if(mode.eq.4) then + href_unlike_3d_fine(findex1,findex2,findex3) = + 1 href_unlike_3d_fine(findex1,findex2,findex3) +1 + end if + + end if + end if + + else if((index1+index2+index3).gt.3) then + + if((trki_pid.eq.trkj_pid).and.(switch_type.eq.1 + 1 .or. switch_type.eq.3)) then + + if(mode.eq.1) then + hist_like_3d_coarse(index1,index2,index3) = + 1 hist_like_3d_coarse(index1,index2,index3) +1 + else if(mode.eq.2) then + htmp_like_3d_coarse(index1,index2,index3) = + 1 htmp_like_3d_coarse(index1,index2,index3) -1 + else if(mode.eq.3) then + htmp_like_3d_coarse(index1,index2,index3) = + 1 htmp_like_3d_coarse(index1,index2,index3) +1 + else if(mode.eq.4) then + href_like_3d_coarse(index1,index2,index3) = + 1 href_like_3d_coarse(index1,index2,index3) +1 + end if + + else if((trki_pid.ne.trkj_pid).and.(switch_type + 1 .eq.2 .or. switch_type.eq.3)) then + + if(mode.eq.1) then + hist_unlike_3d_coarse(index1,index2,index3) = + 1 hist_unlike_3d_coarse(index1,index2,index3) +1 + else if(mode.eq.2) then + htmp_unlike_3d_coarse(index1,index2,index3) = + 1 htmp_unlike_3d_coarse(index1,index2,index3) -1 + else if(mode.eq.3) then + htmp_unlike_3d_coarse(index1,index2,index3) = + 1 htmp_unlike_3d_coarse(index1,index2,index3) +1 + else if(mode.eq.4) then + href_unlike_3d_coarse(index1,index2,index3) = + 1 href_unlike_3d_coarse(index1,index2,index3) +1 + end if + + end if + end if ! End 3D Fine/Coarse Grid + end if + end if ! End 3D Histogram Filling and/or Update + + end if + end do ! End Secondary Track Loop + + end if + end do + end do + end do ! End Neighboring Sector Loop + + end if + end do ! End Primary Track Loop + + Return + END + +C----------------------------------------------------------------------- + + + subroutine correlation_fit + implicit none + +CCC This subroutine carries out the track momentum adjustment +CCC procedure in order to fit the requested model correlation +CCC function and the input one-body {pt,phi,eta} distributions. + +CCC The method used is similar to the Metropolis method. Briefly: +C +C 1. The accepted tracks for each event in the 'event_text.in' +C input file are loaded into the 'trk' data structure table. +C 2. The sector information, histograms, C2 and initial chi-square +C are computed. +C 3. Each track momentum is randomly shifted within a specified +C range, one track at a time, the histograms are updated, and +C a new C2 and chi-square are computed. +C 4. If the new track momentum is acceptable and if it results in a +C smaller value of chi-square, then this shifted momentum is +C retained, if not then the original momentum value is restored. +C 5. This is done for all particles in the track table for the event. +C 6. The entire process is repeated either until the maximum # of +C iterations is reached, or until the chi-square improvement with +C each iteration diminishes sufficiently. +C 7. After completing the event loop, summary information is gathered +C and inclusive correlation functions and one-body distributions +C are calculated. + + Include 'common_parameters.inc' + Include 'common_mesh.inc' + Include 'common_histograms.inc' + Include 'common_correlations.inc' + Include 'common_event_summary.inc' + + Include 'common_track.inc' + Include 'common_track2.inc' + Include 'common_sec_track.inc' + Include 'common_sec_track2.inc' + Include 'common_particle.inc' + +CCC Local Variable Type Declarations: + + integer*4 i,j,k,ievent,niter,ntracks_out,nev + integer*4 ntracks_flagged,track_status,pid_index + integer*4 px_sec_save,py_sec_save,pz_sec_save + + real*4 px_save,py_save,pz_save,E_save + real*4 pt_save,phi_save,eta_save,mass + real*4 chisq_like_1d,chisq_unlike_1d + real*4 chisq_like_3d_fine,chisq_unlike_3d_fine + real*4 chisq_like_3d_coarse,chisq_unlike_3d_coarse + real*4 chisq_hist1_1,chisq_hist1_2 + real*4 chisq_total,chisq_total_oldvalue,chisq_total_newvalue + real*4 hbtpran + +CCC Initialize counters: + + n_part_used_1_inc = 0 + n_part_used_2_inc = 0 + num_pairs_like_inc = 0 + num_pairs_unlike_inc = 0 + event_line_counter = 0 + file10_line_counter = 0 + +CCC Open event input, track selection flags and event output files: + + If(ALICE .eq. 0) Then + open(unit=2,type='old',access='sequential', + 1 name='event_text.in') + open(unit=4,type='old',access='sequential', + 1 name='event_tracks.select') + open(unit=10,status='unknown',access='sequential', + 1 name='event_hbt_text.out') +CCC Read/Write event header from/to I/O event text files + Call read_data(7) + Call read_data(8) + End If + +C------------------------------------- +C Begin Event Loop, +C + do ievent = 2, n_events + 1 +C------------------------------------- + + If(ALICE .eq. 1) Then + Call AliHbtp_SetActiveEventNumber(ievent-1) + write(*,*) 'NEXT EVENT:', ievent + End If + Call read_data(7) + if(n_part_tot_trk .gt. 0) then + + write(6,98) + Call tindex(1,0) ! Fill initial track-sector info. + Call stm_build(1,0,0) ! Fill initial sector info. + Call dist_range(1,ntracks_out,ntracks_flagged) + num_pairs_like = (n_part_used_1_trk*(n_part_used_1_trk-1))/2 + 1 + (n_part_used_2_trk*(n_part_used_2_trk-1))/2 + num_pairs_unlike = n_part_used_1_trk*n_part_used_2_trk + num_pairs_like_inc = num_pairs_like_inc + num_pairs_like + num_pairs_unlike_inc = num_pairs_unlike_inc + num_pairs_unlike + n_part_used_1_inc = n_part_used_1_inc + n_part_used_1_trk + n_part_used_2_inc = n_part_used_2_inc + n_part_used_2_trk + if(pid(1).gt.0) Call histog1(1,0,1,pid(1),0.,0.,0.) + if(pid(2).gt.0) Call histog1(1,0,2,pid(2),0.,0.,0.) + Call histog2(1,0,0,0,0,0.0,0.0,0.0,0.0) + Call correl_fit(1) + Call chisquare(1,chisq_like_1d,chisq_unlike_1d, + 1 chisq_like_3d_fine,chisq_unlike_3d_fine, + 2 chisq_like_3d_coarse,chisq_unlike_3d_coarse, + 3 chisq_hist1_1,chisq_hist1_2) + chisq_total = chisq_wt_like_1d *chisq_like_1d + 1 + chisq_wt_unlike_1d *chisq_unlike_1d + 2 + chisq_wt_like_3d_fine *chisq_like_3d_fine + 3 + chisq_wt_unlike_3d_fine *chisq_unlike_3d_fine + 4 + chisq_wt_like_3d_coarse *chisq_like_3d_coarse + 5 + chisq_wt_unlike_3d_coarse *chisq_unlike_3d_coarse + 6 + chisq_wt_hist1_1 *chisq_hist1_1 + 7 + chisq_wt_hist1_2 *chisq_hist1_2 + chisq_total_oldvalue = chisq_total + Call hist1_copy(1) + Call hist2_copy(1) + + niter = 0 +1000 Continue ! Starting Point for Track Shift Iteration Loop: + niter = niter + 1 + + if(niter.eq.1) then + write(8,99) + write(8,98) + write(8,99) + end if +98 Format(5x,'** START NEXT EVENT **') +99 Format(5x,'************************') + write(8,100) ievent,niter,chisq_total +100 Format(10x,'Event#+1,Iteration# and Chi-Sq = ',2I5,E11.4) + + IF(maxit .eq. 0) GO TO 1001 ! Option to compute correlations +C ! for input events. + +C------------------------------------- +C Begin Track Adjustment Loop: + + do i = 1,n_part_tot_trk +C------------------------------------- + + if(trk_flag(i) .eq. 0) then + +CCC Save initial track parameters (those that might change): + + px_save = trk_px(i) + py_save = trk_py(i) + pz_save = trk_pz(i) + E_save = trk_E(i) + pt_save = trk_pt(i) + phi_save = trk_phi(i) + eta_save = trk_eta(i) + px_sec_save = trk_px_sec(i) + py_sec_save = trk_py_sec(i) + pz_sec_save = trk_pz_sec(i) + old_sec_save = trk_sector(i) + +CCC Save the sector values that the track is initially located in: + + old_sec_ntrk = stm_n_trk_sec(trk_sector(i)) + old_sec_flag = stm_flag(trk_sector(i)) + do k = 1,stm_n_trk_sec(trk_sector(i)) + old_sec_trkid(k) = stm_track_id(k,trk_sector(i)) + end do + +CCC Determine the particle ID type: + + if(trk_ge_pid(i).eq.pid(1) .and. pid(1).gt.0) then + pid_index = 1 + else if(trk_ge_pid(i).eq.pid(2).and.pid(2).gt.0) then + pid_index = 2 + else + pid_index = 1 + end if + +CCC Randomly shift track momentum vector and compute new kinematics: + + trk_px(i) = trk_px(i) + deltap*(2.0*hbtpran(irand) - 1.0) + trk_py(i) = trk_py(i) + deltap*(2.0*hbtpran(irand) - 1.0) + trk_pz(i) = trk_pz(i) + deltap*(2.0*hbtpran(irand) - 1.0) + mass = part_mass(trk_ge_pid(i)) + Call Hbtp_kin(trk_px(i),trk_py(i),trk_pz(i),trk_E(i), + 1 trk_pt(i),trk_phi(i),trk_eta(i),mass,1) + Call tindex(1,i) + new_sec_save = trk_sector(i) + +CCC Determine if track has been shifted to a new sector, and if so, +CCC whether this overfills this new sector. If all is well, then +CCC update histograms. If not, then restore track parameters to their +CCC initial values prior to shifting. Keep the status of track(i) in +CCC 'track_status', where a value of 0 means the track is OK to use. +CCC +CCC The Logical steps are the following: +CCC +C IF(new track position is in same sector) THEN +C o Remove old track position from htmp1*, htmp* using old saved values. +C o Add new track position to htmp1*, htmp* using values in 'trk' +C (Sector information is unchanged) +C ELSE IF(new track position is in a different sector) THEN +C IF(# tracks in new sector is still OK, with the new track) THEN +C o Save values of new sector before trk was shifted into it. +C o Remove old trk position from htmp1*, htmp* using old saved values +C o Add new trk position to htmp1*, htmp* using values in trk +C o Update sector information in stm +C ELSE IF(# tracks in new sector becomes too many with new trk) THEN +C o Restore track parameters to pre-shifted values +C o Set track_status = 1, indicating the track could not be moved +C END IF +C END IF + + track_status = 0 + if(old_sec_save .eq. new_sec_save) then + Call histog1(2,i,pid_index,pid(pid_index),pt_save, + 1 phi_save,eta_save) + Call histog2(2,i,px_sec_save,py_sec_save,pz_sec_save, + 1 px_save,py_save,pz_save,E_save) + + Call histog1(3,i,pid_index,pid(pid_index),0.,0.,0.) + Call histog2(3,i,0,0,0,0.0,0.0,0.0,0.0) + + else if(old_sec_save .ne. new_sec_save) then + + if(stm_n_trk_sec(new_sec_save) .lt. max_trk_sec) then + new_sec_ntrk = stm_n_trk_sec(new_sec_save) + new_sec_flag = stm_flag(new_sec_save) + if(new_sec_ntrk .gt. 0) then + do k = 1,new_sec_ntrk + new_sec_trkid(k) = stm_track_id(k,new_sec_save) + end do + end if + + Call histog1(2,i,pid_index,pid(pid_index),pt_save, + 1 phi_save,eta_save) + Call histog2(2,i,px_sec_save,py_sec_save,pz_sec_save, + 1 px_save,py_save,pz_save,E_save) + + Call histog1(3,i,pid_index,pid(pid_index), + 1 0.,0.,0.) + Call histog2(3,i,0,0,0,0.0,0.0,0.0,0.0) + + Call stm_build(1,i,old_sec_save) + + else if(stm_n_trk_sec(new_sec_save) .ge. max_trk_sec) then + + track_status = 1 + trk_px(i) = px_save + trk_py(i) = py_save + trk_pz(i) = pz_save + trk_E(i) = E_save + trk_pt(i) = pt_save + trk_phi(i) = phi_save + trk_eta(i) = eta_save + trk_px_sec(i) = px_sec_save + trk_py_sec(i) = py_sec_save + trk_pz_sec(i) = pz_sec_save + trk_sector(i) = old_sec_save + + end if + end if ! End Histogram and Sector Update + +CCC If the track was succesfully shifted then compute C2 and determine +C if the chi-square decreases (improves) or increases. If it improves, +C then store the new chi-square value and keep the 1- and 2-body +C histograms in hist1* and hist*, repsectively. If chi-square +C increases (worsens), then restore the track parameters to the +C pre-shifted values, restore the histograms and if a new sector was +C involved, then restore both the old and new sector values. +C +C The Logical steps are the following: +C +C IF(new track position is OK, (i.e. track_status = 0)) Then +C o Compute C2 using htmp* +C o Compute chi-square and save +C IF(chi-square improves) Then +C o Replace previous (best) chi-square with new value +C o Update histograms, i.e. copy htmp1* -> hist1* and +C copy htmp* -> hist* +C ELSE IF(chi-square increases) Then +C o Restore track parameters +C o Restore histograms, i.e. copy hist1* -> htmp1* and +C copy hist* -> htmp* +C IF(new sector was used) Then +C o Restore old sector values to pre-shifted values +C o Restore new sector values to pre-shifted values +C END IF +C END IF +C END IF + + If(track_status .eq.0) Then + Call correl_fit(2) + Call chisquare(2,chisq_like_1d,chisq_unlike_1d, + 1 chisq_like_3d_fine,chisq_unlike_3d_fine, + 2 chisq_like_3d_coarse,chisq_unlike_3d_coarse, + 3 chisq_hist1_1,chisq_hist1_2) + chisq_total_newvalue = + 1 chisq_wt_like_1d *chisq_like_1d + 2 + chisq_wt_unlike_1d *chisq_unlike_1d + 3 + chisq_wt_like_3d_fine *chisq_like_3d_fine + 4 + chisq_wt_unlike_3d_fine *chisq_unlike_3d_fine + 5 + chisq_wt_like_3d_coarse *chisq_like_3d_coarse + 6 + chisq_wt_unlike_3d_coarse *chisq_unlike_3d_coarse + 7 + chisq_wt_hist1_1 *chisq_hist1_1 + 8 + chisq_wt_hist1_2 *chisq_hist1_2 + + if(chisq_total_newvalue .lt. chisq_total_oldvalue) then + chisq_total_oldvalue = chisq_total_newvalue + Call hist1_copy(2) + Call hist2_copy(2) + else if(chisq_total_newvalue.ge.chisq_total_oldvalue) then + trk_px(i) = px_save + trk_py(i) = py_save + trk_pz(i) = pz_save + trk_E(i) = E_save + trk_pt(i) = pt_save + trk_phi(i) = phi_save + trk_eta(i) = eta_save + trk_px_sec(i) = px_sec_save + trk_py_sec(i) = py_sec_save + trk_pz_sec(i) = pz_sec_save + trk_sector(i) = old_sec_save + Call hist1_copy(1) + Call hist2_copy(1) + + If(old_sec_save .ne. new_sec_save) then + + stm_n_trk_sec(old_sec_save) = old_sec_ntrk + stm_flag(old_sec_save) = old_sec_flag + do k = 1,max_trk_sec + stm_track_id(k,old_sec_save) = 0 + end do + do k = 1,old_sec_ntrk + stm_track_id(k,old_sec_save) = old_sec_trkid(k) + end do + + stm_n_trk_sec(new_sec_save) = new_sec_ntrk + stm_flag(new_sec_save) = new_sec_flag + do k = 1,max_trk_sec + stm_track_id(k,new_sec_save) = 0 + end do + do k = 1,new_sec_ntrk + stm_track_id(k,new_sec_save) = new_sec_trkid(k) + end do + + end if + end if + end if ! End Chi-Square Determination + end if ! End valid tracks option + end do ! End Track Shift Loop + +CCC Check chi-square for this iteration -- +C Best, current chi-square value is in 'chisq_total_oldvalue' +C Chi-square value at the beginning of the iteration loop is in +C 'chisq_total'. + + If(abs(200.0*(chisq_total_oldvalue - chisq_total)/ + 1 (chisq_total_oldvalue + chisq_total)) .lt. delchi) then + write(8,101) +101 Format(/5x,'Chi-Sq reduced .lt. delchi % on last iteration', + 1 ' - Stop Search') + go to 1001 + End If + If (niter .gt. maxit) Then + write(8,102) +102 Format(/5x,'Max # Search Iterations Reached - Abort track ', + 1 'Adj. process') + go to 1001 + End If + chisq_total = chisq_total_oldvalue + go to 1000 + +1001 Continue + +CCC Finished Track Adjustment Iteration Loop for event # 'ievent' + + if((ievent - 1) .le. max_events) then + Call dist_range(1,ntracks_out,ntracks_flagged) + num_iter(ievent-1) = float(niter) + n_part_used_1_store(ievent-1) = float(n_part_used_1_trk) + n_part_used_2_store(ievent-1) = float(n_part_used_2_trk) + n_part_tot_store(ievent-1) = float(n_part_tot_trk) + frac_trks_out(ievent-1)=float(ntracks_out)/ + 1 float(n_part_tot_trk) + frac_trks_flag(ievent-1) = + 1 float(ntracks_flagged)/float(n_part_tot_trk) + end if + + Call correl_fit(1) + Call chisquare(1,chisq_like_1d,chisq_unlike_1d, + 1 chisq_like_3d_fine,chisq_unlike_3d_fine, + 2 chisq_like_3d_coarse,chisq_unlike_3d_coarse, + 3 chisq_hist1_1,chisq_hist1_2) + chisq_total = chisq_wt_like_1d *chisq_like_1d + 1 + chisq_wt_unlike_1d *chisq_unlike_1d + 2 + chisq_wt_like_3d_fine *chisq_like_3d_fine + 3 + chisq_wt_unlike_3d_fine *chisq_unlike_3d_fine + 4 + chisq_wt_like_3d_coarse *chisq_like_3d_coarse + 5 + chisq_wt_unlike_3d_coarse *chisq_unlike_3d_coarse + 6 + chisq_wt_hist1_1 *chisq_hist1_1 + 7 + chisq_wt_hist1_2 *chisq_hist1_2 + + if((ievent - 1) .le. max_events) then + chisq_like_1d_store(ievent-1) = chisq_like_1d + chisq_unlike_1d_store(ievent-1) = chisq_unlike_1d + chisq_like_3d_fine_store(ievent-1) = chisq_like_3d_fine + chisq_unlike_3d_fine_store(ievent-1) = chisq_unlike_3d_fine + chisq_like_3d_coarse_store(ievent-1) = chisq_like_3d_coarse + chisq_unlike_3d_coarse_store(ievent-1) =chisq_unlike_3d_coarse + chisq_hist1_1_store(ievent-1) = chisq_hist1_1 + chisq_hist1_2_store(ievent-1) = chisq_hist1_2 + chisq_total_store(ievent-1) = chisq_total + +CCC Count # sectors with stm().flag = 1, indicating that too many +C tracks were attempted to be loaded into that sector. + + num_sec_flagged_store(ievent-1) = 0.0 + do k = 1,n_sectors + if(stm_flag(k) .eq. 1) then + num_sec_flagged_store(ievent-1) = + 1 num_sec_flagged_store(ievent-1) + 1.0 + end if + end do + end if + + Call hist1_incl_sum + Call hist2_incl_sum + if(print_full .eq. 1) Call write_data(5,ievent-1) + + end if ! End event-with-tracks processing. + Call read_data(8) + +C------------------------------- + end do ! End Event Loop +C------------------------------- + +CCC Compute Correlation Functions for the Inclusive Histograms + + Call correl_fit(3) + +CCC Compute Mean and Std. dev of event monitor and summary quantities: + + if(n_events .le. max_events) then + nev = n_events + else + nev = max_events + end if + + Call mean_rms(num_iter,nev,nev,niter_mean,niter_rms) + Call mean_rms(n_part_used_1_store,nev,nev,npart1_mean,npart1_rms) + Call mean_rms(n_part_used_2_store,nev,nev,npart2_mean,npart2_rms) + Call mean_rms(n_part_tot_store,nev,nev,npart_tot_mean, + 1 npart_tot_rms) + Call mean_rms(num_sec_flagged_store,nev,nev, + 1 nsec_flag_mean,nsec_flag_rms) + Call mean_rms(frac_trks_out,nev,nev, + 1 frac_trks_out_mean,frac_trks_out_rms) + Call mean_rms(frac_trks_flag,nev,nev, + 1 frac_trks_flag_mean,frac_trks_flag_rms) + Call mean_rms(chisq_like_1d_store,nev,nev, + 1 chi_l1d_mean,chi_l1d_rms) + Call mean_rms(chisq_unlike_1d_store,nev,nev, + 1 chi_u1d_mean,chi_u1d_rms) + Call mean_rms(chisq_like_3d_fine_store,nev,nev, + 1 chi_l3f_mean,chi_l3f_rms) + Call mean_rms(chisq_unlike_3d_fine_store,nev,nev, + 1 chi_u3f_mean,chi_u3f_rms) + Call mean_rms(chisq_like_3d_coarse_store,nev,nev, + 1 chi_l3c_mean,chi_l3c_rms) + Call mean_rms(chisq_unlike_3d_coarse_store,nev,nev, + 1 chi_u3c_mean,chi_u3c_rms) + Call mean_rms(chisq_hist1_1_store,nev,nev, + 1 chi_1_1_mean, chi_1_1_rms) + Call mean_rms(chisq_hist1_2_store,nev,nev, + 1 chi_1_2_mean, chi_1_2_rms) + Call mean_rms(chisq_total_store,nev,nev, + 1 chi_tot_mean, chi_tot_rms) + + If(ALICE .eq. 0) Then + Close(unit=2) + Close(unit=4) + Close(unit=10) + End If + + Return + END + +C------------------------------------------------------------------------ + + + subroutine hist1_copy(mode) + implicit none + +CCC Copy 1-body histograms if: +CCC +CCC mode = 1, then copy hist1* -> htmp1* +CCC mode = 2, then copy htmp1* -> hist1* + + Include 'common_parameters.inc' + Include 'common_mesh.inc' + Include 'common_histograms.inc' + +CCC Local Variable Type Declarations: + + integer*4 mode, i + +C--------------------------- + If(mode .eq. 1) Then ! Copy hist1* -> htmp1* +C--------------------------- + + if(pid(1) .gt. 0) then + do i = 1,n_pt_bins + htmp1_pt_1(i) = hist1_pt_1(i) + end do + do i = 1,n_phi_bins + htmp1_phi_1(i) = hist1_phi_1(i) + end do + do i = 1,n_eta_bins + htmp1_eta_1(i) = hist1_eta_1(i) + end do + end if + + if(pid(2) .gt. 0) then + do i = 1,n_pt_bins + htmp1_pt_2(i) = hist1_pt_2(i) + end do + do i = 1,n_phi_bins + htmp1_phi_2(i) = hist1_phi_2(i) + end do + do i = 1,n_eta_bins + htmp1_eta_2(i) = hist1_eta_2(i) + end do + end if + +C-------------------------------- + Else If (mode .eq. 2) Then ! Copy htmp1* -> hist1* +C-------------------------------- + + if(pid(1) .gt. 0) then + do i = 1,n_pt_bins + hist1_pt_1(i) = htmp1_pt_1(i) + end do + do i = 1,n_phi_bins + hist1_phi_1(i) = htmp1_phi_1(i) + end do + do i = 1,n_eta_bins + hist1_eta_1(i) = htmp1_eta_1(i) + end do + end if + + if(pid(2) .gt. 0) then + do i = 1,n_pt_bins + hist1_pt_2(i) = htmp1_pt_2(i) + end do + do i = 1,n_phi_bins + hist1_phi_2(i) = htmp1_phi_2(i) + end do + do i = 1,n_eta_bins + hist1_eta_2(i) = htmp1_eta_2(i) + end do + end if + +C------------ + End If +C------------ + + Return + END + +C---------------------------------------------------------------------- + + subroutine hist2_copy(mode) + implicit none + +CCC Copy 2-body histograms if: +CCC +CCC mode = 1, then copy hist* -> htmp* +CCC mode = 2, then copy htmp* -> hist* + + Include 'common_parameters.inc' + Include 'common_mesh.inc' + Include 'common_histograms.inc' + +CCC Local Variable Type Declarations: + + integer*4 mode, i,j,k + +C--------------------------- + If (mode .eq. 1) Then ! Copy hist* -> htmp* +C--------------------------- + + if(switch_1d.gt.0 .and. n_1d_total.gt.0) then + if(switch_type.eq.1 .or. switch_type.eq.3) then + do i = 1,n_1d_total + htmp_like_1d(i) = hist_like_1d(i) + end do + end if + if(switch_type.eq.2 .or. switch_type.eq.3) then + do i = 1,n_1d_total + htmp_unlike_1d(i) = hist_unlike_1d(i) + end do + end if + end if ! End 1D histogram copy + + if(switch_3d.gt.0) then + if(switch_type.eq.1 .or. switch_type.eq.3) then + + if(n_3d_fine .gt. 0) then + do i = 1,n_3d_fine + do j = 1,n_3d_fine + do k = 1,n_3d_fine + htmp_like_3d_fine(i,j,k) = hist_like_3d_fine(i,j,k) + end do + end do + end do + end if + + if(n_3d_coarse .gt. 0) then + do i = 1,n_3d_coarse + do j = 1,n_3d_coarse + do k = 1,n_3d_coarse + htmp_like_3d_coarse(i,j,k) = hist_like_3d_coarse(i,j,k) + end do + end do + end do + end if + + end if + + if(switch_type.eq.2 .or. switch_type.eq.3) then + + if(n_3d_fine .gt. 0) then + do i = 1,n_3d_fine + do j = 1,n_3d_fine + do k = 1,n_3d_fine + htmp_unlike_3d_fine(i,j,k) = hist_unlike_3d_fine(i,j,k) + end do + end do + end do + end if + + if(n_3d_coarse .gt. 0) then + do i = 1,n_3d_coarse + do j = 1,n_3d_coarse + do k = 1,n_3d_coarse + htmp_unlike_3d_coarse(i,j,k)=hist_unlike_3d_coarse(i,j,k) + end do + end do + end do + end if + + end if + end if ! End 3D histogram copy + +C-------------------------------- + Else If (mode .eq. 2) Then ! Copy htmp* -> hist* +C-------------------------------- + + if(switch_1d.gt.0 .and. n_1d_total.gt.0) then + if(switch_type.eq.1 .or. switch_type.eq.3) then + do i = 1,n_1d_total + hist_like_1d(i) = htmp_like_1d(i) + end do + end if + if(switch_type.eq.2 .or. switch_type.eq.3) then + do i = 1,n_1d_total + hist_unlike_1d(i) = htmp_unlike_1d(i) + end do + end if + end if ! End 1D histogram copy + + if(switch_3d.gt.0) then + if(switch_type.eq.1 .or. switch_type.eq.3) then + + if(n_3d_fine .gt. 0) then + do i = 1,n_3d_fine + do j = 1,n_3d_fine + do k = 1,n_3d_fine + hist_like_3d_fine(i,j,k) = htmp_like_3d_fine(i,j,k) + end do + end do + end do + end if + + if(n_3d_coarse .gt. 0) then + do i = 1,n_3d_coarse + do j = 1,n_3d_coarse + do k = 1,n_3d_coarse + hist_like_3d_coarse(i,j,k) = htmp_like_3d_coarse(i,j,k) + end do + end do + end do + end if + + end if + + if(switch_type.eq.2 .or. switch_type.eq.3) then + + if(n_3d_fine .gt. 0) then + do i = 1,n_3d_fine + do j = 1,n_3d_fine + do k = 1,n_3d_fine + hist_unlike_3d_fine(i,j,k) = htmp_unlike_3d_fine(i,j,k) + end do + end do + end do + end if + + if(n_3d_coarse .gt. 0) then + do i = 1,n_3d_coarse + do j = 1,n_3d_coarse + do k = 1,n_3d_coarse + hist_unlike_3d_coarse(i,j,k)=htmp_unlike_3d_coarse(i,j,k) + end do + end do + end do + end if + + end if + end if ! End 3D histogram copy + +C------------- + End If ! End mode selection options +C------------- + + Return + END + +C----------------------------------------------------------------------- + + + subroutine hist1_incl_sum + implicit none + +CCC Sum 1-body histograms for each event into inclusive totals, where +CCC hinc1* = SUM[hist1*] + + Include 'common_parameters.inc' + Include 'common_mesh.inc' + Include 'common_histograms.inc' + +CCC Local Variable Type Declarations: + + integer*4 i + + if(pid(1) .gt. 0) then + do i = 1,n_pt_bins + hinc1_pt_1(i) = hinc1_pt_1(i) + hist1_pt_1(i) + end do + do i = 1,n_phi_bins + hinc1_phi_1(i) = hinc1_phi_1(i) + hist1_phi_1(i) + end do + do i = 1,n_eta_bins + hinc1_eta_1(i) = hinc1_eta_1(i) + hist1_eta_1(i) + end do + end if + + if(pid(2) .gt. 0) then + do i = 1,n_pt_bins + hinc1_pt_2(i) = hinc1_pt_2(i) + hist1_pt_2(i) + end do + do i = 1,n_phi_bins + hinc1_phi_2(i) = hinc1_phi_2(i) + hist1_phi_2(i) + end do + do i = 1,n_eta_bins + hinc1_eta_2(i) = hinc1_eta_2(i) + hist1_eta_2(i) + end do + end if + + Return + END + + +C------------------------------------------------------------------------ + + + subroutine hist2_incl_sum + implicit none + +CCC Sum 2-body histograms for each event into inclusive totals, where +CCC hinc* = SUM[hist*] + + Include 'common_parameters.inc' + Include 'common_mesh.inc' + Include 'common_histograms.inc' + +CCC Local Variable Type Declarations: + + integer*4 i,j,k + + if(switch_1d.gt.0 .and. n_1d_total.gt.0) then + if(switch_type.eq.1 .or. switch_type.eq.3) then + do i = 1,n_1d_total + hinc_like_1d(i) = hinc_like_1d(i) + hist_like_1d(i) + end do + end if + if(switch_type.eq.2 .or. switch_type.eq.3) then + do i = 1,n_1d_total + hinc_unlike_1d(i) = hinc_unlike_1d(i) + hist_unlike_1d(i) + end do + end if + end if ! End 1D Inclusive Histogram Sum + + if(switch_3d.gt.0) then + if(switch_type.eq.1 .or. switch_type.eq.3) then + + if(n_3d_fine .gt. 0) then + do i = 1,n_3d_fine + do j = 1,n_3d_fine + do k = 1,n_3d_fine + hinc_like_3d_fine(i,j,k) = hinc_like_3d_fine(i,j,k) + 1 + hist_like_3d_fine(i,j,k) + end do + end do + end do + end if + + if(n_3d_coarse .gt. 0) then + do i = 1,n_3d_coarse + do j = 1,n_3d_coarse + do k = 1,n_3d_coarse + hinc_like_3d_coarse(i,j,k) = hinc_like_3d_coarse(i,j,k) + 1 + hist_like_3d_coarse(i,j,k) + end do + end do + end do + end if + + end if + + if(switch_type.eq.2 .or. switch_type.eq.3) then + + if(n_3d_fine .gt. 0) then + do i = 1,n_3d_fine + do j = 1,n_3d_fine + do k = 1,n_3d_fine + hinc_unlike_3d_fine(i,j,k) = hinc_unlike_3d_fine(i,j,k) + 1 + hist_unlike_3d_fine(i,j,k) + end do + end do + end do + end if + + if(n_3d_coarse .gt. 0) then + do i = 1,n_3d_coarse + do j = 1,n_3d_coarse + do k = 1,n_3d_coarse + hinc_unlike_3d_coarse(i,j,k) = hinc_unlike_3d_coarse(i,j,k) + 1 + hist_unlike_3d_coarse(i,j,k) + end do + end do + end do + end if + + end if + end if ! End 3D Inclusive Histogram Sum + + Return + END + +C-------------------------------------------------------------------------- + + + subroutine correl_fit(mode) + implicit none + +CCC This subroutine calculates the 2-body correlation function with +CCC errors for the cases: +CCC +CCC (1) 1D and/or 3D fine and coarse grid distributions +CCC (2) like pairs and/or unlike pairs +CCC +CCC Uses the signal and reference histograms. The input parameter +CCC 'mode' selects which histograms to use. +CCC +CCC Mode = 1, use hist* +CCC Mode = 2, use htmp* +CCC Mode = 3, use hinc* + + Include 'common_parameters.inc' + Include 'common_mesh.inc' + Include 'common_histograms.inc' + Include 'common_correlations.inc' + +CCC Local Variable Type Declarations: + + integer*4 mode,i,j,k + +CCC Initialize correlation functions and error arrays to zero: + + do i = 1,max_c2_1d + c2fit_like_1d(i) = 0.0 + c2fit_unlike_1d(i) = 0.0 + c2err_like_1d(i) = 0.0 + c2err_unlike_1d(i) = 0.0 + end do + + do i = 1,max_c2_3d + do j = 1,max_c2_3d + do k = 1,max_c2_3d + c2fit_like_3d_fine(i,j,k) = 0.0 + c2fit_unlike_3d_fine(i,j,k) = 0.0 + c2fit_like_3d_coarse(i,j,k) = 0.0 + c2fit_unlike_3d_coarse(i,j,k) = 0.0 + c2err_like_3d_fine(i,j,k) = 0.0 + c2err_unlike_3d_fine(i,j,k) = 0.0 + c2err_like_3d_coarse(i,j,k) = 0.0 + c2err_unlike_3d_coarse(i,j,k) = 0.0 + end do + end do + end do + +CCC Compute 1D Correlation Functions and Errors: + + if(switch_1d .gt. 0) then + if(switch_type.eq.1 .or. switch_type.eq.3) then + + if(mode .eq. 1) then + Call c2_1d(hist_like_1d,href_like_1d,c2fit_like_1d, + 1 c2err_like_1d,max_h_1d,max_c2_1d,n_1d_total, + 2 num_pairs_like,num_pairs_like_ref) + else if (mode .eq. 2) then + Call c2_1d(htmp_like_1d,href_like_1d,c2fit_like_1d, + 1 c2err_like_1d,max_h_1d,max_c2_1d,n_1d_total, + 2 num_pairs_like,num_pairs_like_ref) + else if (mode .eq. 3) then + Call c2_1d(hinc_like_1d,href_like_1d,c2fit_like_1d, + 1 c2err_like_1d,max_h_1d,max_c2_1d,n_1d_total, + 2 num_pairs_like_inc,num_pairs_like_ref) + end if + + end if + + if(switch_type.eq.2 .or. switch_type.eq.3) then + + if(mode .eq. 1) then + Call c2_1d(hist_unlike_1d,href_unlike_1d,c2fit_unlike_1d, + 1 c2err_unlike_1d,max_h_1d,max_c2_1d,n_1d_total, + 2 num_pairs_unlike,num_pairs_unlike_ref) + else if (mode .eq. 2) then + Call c2_1d(htmp_unlike_1d,href_unlike_1d,c2fit_unlike_1d, + 1 c2err_unlike_1d,max_h_1d,max_c2_1d,n_1d_total, + 2 num_pairs_unlike,num_pairs_unlike_ref) + else if (mode .eq. 3) then + Call c2_1d(hinc_unlike_1d,href_unlike_1d,c2fit_unlike_1d, + 1 c2err_unlike_1d,max_h_1d,max_c2_1d,n_1d_total, + 2 num_pairs_unlike_inc,num_pairs_unlike_ref) + end if + end if + end if ! End 1D correlations + +CCC Compute 3D Correlation Functions and Errors: + + if(switch_3d .gt. 0) then + if(switch_type.eq.1 .or. switch_type.eq.3) then + + if(mode .eq. 1) then + Call c2_3d(hist_like_3d_fine,href_like_3d_fine, + 1 c2fit_like_3d_fine,c2err_like_3d_fine, + 2 max_h_3d,max_c2_3d,n_3d_fine, + 3 num_pairs_like,num_pairs_like_ref) + Call c2_3d(hist_like_3d_coarse,href_like_3d_coarse, + 1 c2fit_like_3d_coarse,c2err_like_3d_coarse, + 2 max_h_3d,max_c2_3d,n_3d_coarse, + 3 num_pairs_like,num_pairs_like_ref) + else if(mode .eq. 2) then + Call c2_3d(htmp_like_3d_fine,href_like_3d_fine, + 1 c2fit_like_3d_fine,c2err_like_3d_fine, + 2 max_h_3d,max_c2_3d,n_3d_fine, + 3 num_pairs_like,num_pairs_like_ref) + Call c2_3d(htmp_like_3d_coarse,href_like_3d_coarse, + 1 c2fit_like_3d_coarse,c2err_like_3d_coarse, + 2 max_h_3d,max_c2_3d,n_3d_coarse, + 3 num_pairs_like,num_pairs_like_ref) + else if(mode .eq. 3) then + Call c2_3d(hinc_like_3d_fine,href_like_3d_fine, + 1 c2fit_like_3d_fine,c2err_like_3d_fine, + 2 max_h_3d,max_c2_3d,n_3d_fine, + 3 num_pairs_like_inc,num_pairs_like_ref) + Call c2_3d(hinc_like_3d_coarse,href_like_3d_coarse, + 1 c2fit_like_3d_coarse,c2err_like_3d_coarse, + 2 max_h_3d,max_c2_3d,n_3d_coarse, + 3 num_pairs_like_inc,num_pairs_like_ref) + end if + + end if + + if(switch_type.eq.2 .or. switch_type.eq.3) then + + if(mode .eq. 1) then + Call c2_3d(hist_unlike_3d_fine,href_unlike_3d_fine, + 1 c2fit_unlike_3d_fine,c2err_unlike_3d_fine, + 2 max_h_3d,max_c2_3d,n_3d_fine, + 3 num_pairs_unlike,num_pairs_unlike_ref) + Call c2_3d(hist_unlike_3d_coarse,href_unlike_3d_coarse, + 1 c2fit_unlike_3d_coarse,c2err_unlike_3d_coarse, + 2 max_h_3d,max_c2_3d,n_3d_coarse, + 3 num_pairs_unlike,num_pairs_unlike_ref) + else if(mode .eq. 2) then + Call c2_3d(htmp_unlike_3d_fine,href_unlike_3d_fine, + 1 c2fit_unlike_3d_fine,c2err_unlike_3d_fine, + 2 max_h_3d,max_c2_3d,n_3d_fine, + 3 num_pairs_unlike,num_pairs_unlike_ref) + Call c2_3d(htmp_unlike_3d_coarse,href_unlike_3d_coarse, + 1 c2fit_unlike_3d_coarse,c2err_unlike_3d_coarse, + 2 max_h_3d,max_c2_3d,n_3d_coarse, + 3 num_pairs_unlike,num_pairs_unlike_ref) + else if(mode .eq. 3) then + Call c2_3d(hinc_unlike_3d_fine,href_unlike_3d_fine, + 1 c2fit_unlike_3d_fine,c2err_unlike_3d_fine, + 2 max_h_3d,max_c2_3d,n_3d_fine, + 3 num_pairs_unlike_inc,num_pairs_unlike_ref) + Call c2_3d(hinc_unlike_3d_coarse,href_unlike_3d_coarse, + 1 c2fit_unlike_3d_coarse,c2err_unlike_3d_coarse, + 2 max_h_3d,max_c2_3d,n_3d_coarse, + 3 num_pairs_unlike_inc,num_pairs_unlike_ref) + end if + end if + end if ! End 3D correlations + + Return + END + + +C----------------------------------------------------------------------- + + + subroutine c2_1d(h,href,c2,c2err,maxh,maxc2,n,num_pairs_sig, + 1 num_pairs_bkg) + implicit none + +CCC Computes the two-body correlation function for 1D distributions. +CCC Errors are also computed. +CCC +CCC Description of Input Variables in Argument List: +C +C h(maxh) = signal histogram (numerator) +C href(maxh) = background histogram (denominator) +C c2(maxc2) = correlation function = a/b +C c2err(maxc2) = correlation function error +C maxh = dimension of histogram arrays +C maxc2 = dimension of correlation function array. +C n = # bins to use +C num_pairs_sig = # pairs used in signal histogram +C num_pairs_bkg = # pairs used in background histogram +C + +CCC Local Variable Type Declarations: + + integer*4 maxh,maxc2,n,num_pairs_sig,num_pairs_bkg + integer*4 h(maxh), href(maxh) + integer*4 k + + real*4 c2(maxc2), c2err(maxc2) + real*4 a,a_error,b,b_error + + do k = 1,n + if(href(k).le.0 .or. h(k).le.0) then + c2(k) = 0.0 + c2err(k) = 1.0 + else + a = float(h(k))/float(num_pairs_sig) + a_error = sqrt(float(h(k)))/float(num_pairs_sig) + b = float(href(k))/float(num_pairs_bkg) + b_error = sqrt(float(href(k)))/float(num_pairs_bkg) + c2(k) = a/b + c2err(k) = c2(k)*sqrt((a_error/a)**2 + (b_error/b)**2) + end if + end do + + Return + END + +C----------------------------------------------------------------------- + + + subroutine c2_3d(h,href,c2,c2err,maxh,maxc2,n,num_pairs_sig, + 1 num_pairs_bkg) + implicit none + +CCC Computes the two-body correlation function for 3D distributions. +CCC Errors are also computed. +CCC +CCC Description of Input Variables in Argument List: +C +C h(maxh,maxh,maxh) = 3D signal histogram (numerator) +C href(maxh,maxh,maxh)) = 3D background histogram (denominator) +C c2(maxc2,maxc2,maxc2) = 3D correlation function = a/b +C c2err(maxc2,maxc2,maxc2) = 3D correlation function error +C maxh = dimension of 3D histogram arrays +C maxc2 = dimension of 3D correlation function array. +C n = # bins to use +C num_pairs_sig = # pairs used in signal histogram +C num_pairs_bkg = # pairs used in background histogram +C + +CCC Local Variable Type Declarations: + + integer*4 maxh,maxc2,n,num_pairs_sig,num_pairs_bkg + integer*4 h(maxh,maxh,maxh), href(maxh,maxh,maxh) + integer*4 i,j,k + + real*4 c2(maxc2,maxc2,maxc2), c2err(maxc2,maxc2,maxc2) + real*4 a,a_error,b,b_error + + do i = 1,n + do j = 1,n + do k = 1,n + if(href(i,j,k).le.0 .or. h(i,j,k).le.0) then + c2(i,j,k) = 0.0 + c2err(i,j,k) = 1.0 + else + a = float(h(i,j,k))/float(num_pairs_sig) + a_error = sqrt(float(h(i,j,k)))/float(num_pairs_sig) + b = float(href(i,j,k))/float(num_pairs_bkg) + b_error = sqrt(float(href(i,j,k)))/float(num_pairs_bkg) + c2(i,j,k) = a/b + c2err(i,j,k) = c2(i,j,k)*sqrt((a_error/a)**2 + (b_error/b)**2) + end if + end do + end do + end do + + Return + END + + +C------------------------------------------------------------------------- + + + subroutine chisquare(mode,chisq_like_1d,chisq_unlike_1d, + 1 chisq_like_3d_fine,chisq_unlike_3d_fine, + 2 chisq_like_3d_coarse,chisq_unlike_3d_coarse, + 3 chisq_hist1_1,chisq_hist1_2) + implicit none + +CCC This subroutine calculates the chi-squares for the following: +C o Like pair 1D 2-body correlations +C o Unlike pair 1D 2-body correlations +C o Like pair 3D, Fine Mesh 2-body correlations +C o Unlike pair 3D, Fine Mesh 2-body correlations +C o Like pair 3D, Coarse Mesh 2-body correlations +C o Unlike pair 3D, Coarse Mesh 2-body correlations +C o One-body 1D {pt,phi,eta} (summed) distributions for PID#1 +C o One-body 1D {pt,phi,eta} (summed) distributions for PID#2 +C +C (where the separate chi-squares for the 1D pt, phi and eta +C one-body distributions are added and only the sum is returned.) +C +C 'Mode' determines which one-body histogram is compared to the +C reference histogram, where: +C +C If mode = 1, then hist1* are used +C If mode = 2, then htmp1* are used +C +C The one-body reference histograms used in the chi-square calculation +C are in href1* + + Include 'common_parameters.inc' + Include 'common_mesh.inc' + Include 'common_histograms.inc' + Include 'common_correlations.inc' + +CCC Local Variable Type Declarations: + + integer*4 i,j,k,mode + + real*4 chisq_like_1d, chisq_unlike_1d + real*4 chisq_like_3d_fine,chisq_unlike_3d_fine + real*4 chisq_like_3d_coarse,chisq_unlike_3d_coarse + real*4 chisq_hist1_1,chisq_hist1_2 + + real*4 n1fac,n2fac ! # part 1(2) used/# part 1(2) used in Ref. + real*4 avgerrsq_pt_1, avgerrsq_phi_1, avgerrsq_eta_1 + real*4 avgerrsq_pt_2, avgerrsq_phi_2, avgerrsq_eta_2 + real*4 avgerrsq_pt_ref_1,avgerrsq_phi_ref_1,avgerrsq_eta_ref_1 + real*4 avgerrsq_pt_ref_2,avgerrsq_phi_ref_2,avgerrsq_eta_ref_2 + real*4 chisq1 + +CCC Initialize all chi-square values to zero: + + chisq_like_1d = 0.0 + chisq_unlike_1d = 0.0 + chisq_like_3d_fine = 0.0 + chisq_unlike_3d_fine = 0.0 + chisq_like_3d_coarse = 0.0 + chisq_unlike_3d_coarse = 0.0 + chisq_hist1_1 = 0.0 + chisq_hist1_2 = 0.0 + + if(switch_1d .gt. 0) then + if(switch_type.eq.1 .or. switch_type.eq.3) then + do i = 1,n_1d_total + if(c2fit_like_1d(i) .ne. 0.0) then + chisq_like_1d = chisq_like_1d + ((c2fit_like_1d(i) + 1 - c2mod_like_1d(i))/c2err_like_1d(i))**2 + end if + end do + end if + if(switch_type.eq.2 .or. switch_type.eq.3) then + do i = 1,n_1d_total + if(c2fit_unlike_1d(i) .ne. 0.0) then + chisq_unlike_1d = chisq_unlike_1d + ((c2fit_unlike_1d(i) + 1 - c2mod_unlike_1d(i))/c2err_unlike_1d(i))**2 + end if + end do + end if + end if ! End 1D correlation function, chi-square option + + if(switch_3d .gt. 0) then + if(switch_type.eq.1 .or. switch_type.eq.3) then + + if(n_3d_fine .gt. 0) then + do i = 1,n_3d_fine + do j = 1,n_3d_fine + do k = 1,n_3d_fine + if(c2fit_like_3d_fine(i,j,k).ne.0.0) then + chisq_like_3d_fine = chisq_like_3d_fine + 1 + ((c2fit_like_3d_fine(i,j,k) + 2 - c2mod_like_3d_fine(i,j,k)) + 3 /c2err_like_3d_fine(i,j,k))**2 + end if + end do + end do + end do + end if + + if(n_3d_coarse .gt. 0) then + do i = 1,n_3d_coarse + do j = 1,n_3d_coarse + do k = 1,n_3d_coarse + if((i+j+k).gt.3) then + if(c2fit_like_3d_coarse(i,j,k).ne.0.0) then + chisq_like_3d_coarse = chisq_like_3d_coarse + 1 +((c2fit_like_3d_coarse(i,j,k) + 2 - c2mod_like_3d_coarse(i,j,k)) + 3 /c2err_like_3d_coarse(i,j,k))**2 + end if + end if + end do + end do + end do + end if + + end if + + if(switch_type.eq.2 .or. switch_type.eq.3) then + + if(n_3d_fine .gt. 0) then + do i = 1,n_3d_fine + do j = 1,n_3d_fine + do k = 1,n_3d_fine + if(c2fit_unlike_3d_fine(i,j,k).ne.0.0) then + chisq_unlike_3d_fine = chisq_unlike_3d_fine + 1 + ((c2fit_unlike_3d_fine(i,j,k) + 2 - c2mod_unlike_3d_fine(i,j,k)) + 3 /c2err_unlike_3d_fine(i,j,k))**2 + end if + end do + end do + end do + end if + + if(n_3d_coarse .gt. 0) then + do i = 1,n_3d_coarse + do j = 1,n_3d_coarse + do k = 1,n_3d_coarse + if((i+j+k).gt.3) then + if(c2fit_unlike_3d_coarse(i,j,k).ne.0.0) then + chisq_unlike_3d_coarse = chisq_unlike_3d_coarse + 1 +((c2fit_unlike_3d_coarse(i,j,k) + 2 - c2mod_unlike_3d_coarse(i,j,k)) + 3 /c2err_unlike_3d_coarse(i,j,k))**2 + end if + end if + end do + end do + end do + end if + + end if + end if ! End of 3D Correlation Function, Chi-Square Option + +CCC Obtain chi-squares for one-body distributions + + if(pid(1) .gt. 0) then + n1fac = float(n_part_used_1_trk)/float(n_part_used_1_ref) + avgerrsq_pt_1 = float(n_part_used_1_trk)/float(n_pt_bins) + avgerrsq_phi_1 = float(n_part_used_1_trk)/float(n_phi_bins) + avgerrsq_eta_1 = float(n_part_used_1_trk)/float(n_eta_bins) + avgerrsq_pt_ref_1 = float(n_part_used_1_ref)/float(n_pt_bins) + avgerrsq_phi_ref_1 = float(n_part_used_1_ref)/float(n_phi_bins) + avgerrsq_eta_ref_1 = float(n_part_used_1_ref)/float(n_eta_bins) + end if + + if(pid(2) .gt. 0) then + n2fac = float(n_part_used_2_trk)/float(n_part_used_2_ref) + avgerrsq_pt_2 = float(n_part_used_2_trk)/float(n_pt_bins) + avgerrsq_phi_2 = float(n_part_used_2_trk)/float(n_phi_bins) + avgerrsq_eta_2 = float(n_part_used_2_trk)/float(n_eta_bins) + avgerrsq_pt_ref_2 = float(n_part_used_2_ref)/float(n_pt_bins) + avgerrsq_phi_ref_2 = float(n_part_used_2_ref)/float(n_phi_bins) + avgerrsq_eta_ref_2 = float(n_part_used_2_ref)/float(n_eta_bins) + end if + + if(pid(1) .gt. 0) then + if(mode .eq. 1) then + + chisq_hist1_1 = + 1 chisq1(hist1_pt_1,href1_pt_1,max_h_1d,avgerrsq_pt_1, + 2 avgerrsq_pt_ref_1,n1fac,n_pt_bins) + 3 +chisq1(hist1_phi_1,href1_phi_1,max_h_1d,avgerrsq_phi_1, + 4 avgerrsq_phi_ref_1,n1fac,n_phi_bins) + 5 +chisq1(hist1_eta_1,href1_eta_1,max_h_1d,avgerrsq_eta_1, + 6 avgerrsq_eta_ref_1,n1fac,n_eta_bins) + + else if(mode .eq. 2) then + + chisq_hist1_1 = + 1 chisq1(htmp1_pt_1,href1_pt_1,max_h_1d,avgerrsq_pt_1, + 2 avgerrsq_pt_ref_1,n1fac,n_pt_bins) + 3 +chisq1(htmp1_phi_1,href1_phi_1,max_h_1d,avgerrsq_phi_1, + 4 avgerrsq_phi_ref_1,n1fac,n_phi_bins) + 5 +chisq1(htmp1_eta_1,href1_eta_1,max_h_1d,avgerrsq_eta_1, + 6 avgerrsq_eta_ref_1,n1fac,n_eta_bins) + + end if + end if ! End pid(1) one-body histogram chi-square calculation + + if(pid(2) .gt. 0) then + if(mode .eq. 1) then + + chisq_hist1_2 = + 1 chisq1(hist1_pt_2,href1_pt_2,max_h_1d,avgerrsq_pt_2, + 2 avgerrsq_pt_ref_2,n2fac,n_pt_bins) + 3 +chisq1(hist1_phi_2,href1_phi_2,max_h_1d,avgerrsq_phi_2, + 4 avgerrsq_phi_ref_2,n2fac,n_phi_bins) + 5 +chisq1(hist1_eta_2,href1_eta_2,max_h_1d,avgerrsq_eta_2, + 6 avgerrsq_eta_ref_2,n2fac,n_eta_bins) + + else if(mode .eq. 2) then + + chisq_hist1_2 = + 1 chisq1(htmp1_pt_2,href1_pt_2,max_h_1d,avgerrsq_pt_2, + 2 avgerrsq_pt_ref_2,n2fac,n_pt_bins) + 3 +chisq1(htmp1_phi_2,href1_phi_2,max_h_1d,avgerrsq_phi_2, + 4 avgerrsq_phi_ref_2,n2fac,n_phi_bins) + 5 +chisq1(htmp1_eta_2,href1_eta_2,max_h_1d,avgerrsq_eta_2, + 6 avgerrsq_eta_ref_2,n2fac,n_eta_bins) + + end if + end if ! End pid(2) one-body histogram chi-square calculation + + Return + END + +C---------------------------------------------------------------------- + + + real*4 function chisq1(h,href,maxh,herravgsq,hreferravgsq, + 1 numfac,nbins) + implicit none + +CCC Compute chi-square for 1D histogram h(), with respect to the +CCC reference histogram, href(). +C +C h(maxh) = 1D histogram array +C href(maxh) = 1D reference histogram array +C maxh = dimension of histogram arrays +C herravgsq = average error squared in histogram h's bins +C hreferravgsq = average error squared in ref. hist. href's bins +C numfac = ratio of total number of entries in h to that +C in href +C nbins = # bins to use in chi-square sum, starting at array +C element 1,2,... nbins (where nbins .le. maxh) +C +C The chi-square value is returned in chisq1 + +CCC Local Variable Type Declarations: + + integer*4 maxh, nbins, i + integer*4 h(maxh),href(maxh) + + real*4 herravgsq,hreferravgsq,numfac,numfacsq + real*4 herrsq,hreferrsq + + chisq1 = 0.0 + numfacsq = numfac*numfac + + do i = 1,nbins + if(h(i) .gt. 0) then + herrsq = float(h(i)) + else + herrsq = herravgsq + end if + + if(href(i) .gt. 0) then + hreferrsq = float(href(i)) + else + hreferrsq = hreferravgsq + end if + + chisq1 = chisq1 + ((float(h(i)) - numfac*float(href(i)))**2) + 1 /(herrsq + numfacsq*hreferrsq) + end do + + Return + END + +C----------------------------------------------------------------------- + + + Subroutine write_data(mode,ievent) + implicit none + +CCC This subroutine writes the main output file, 'hbt_simulation.out' +C on File Unit 8. File Unit 8 is opened and closed by the main +C program. +C +C Also, the computed 1- and 2-body reference histograms are printed +C out from this subroutine on File Units 11 and 9, respectively. These +C files are opened/closed here. +C +C Output content determined by input parameter 'mode', where: +C +C Mode Description of Output +C ----- ----------------------------------------------------------- +C 1 basic output file header +C input and derived quantities +C +C 2 reference histograms (1 and 2-body) +C saved to separate I/O File Unit=11,9 respectively +C +C 3 reference histogram output +C +C 4 correlation model +C +C 5 correlation fit and one-body distributions +C for each event, optional output +C +C 6 inclusive one-body distributions and inclusive +C correlation fit; projection onto 1D axes. +C + + Include 'common_parameters.inc' + Include 'common_mesh.inc' + Include 'common_histograms.inc' + Include 'common_correlations.inc' + Include 'common_coulomb.inc' + Include 'common_event_summary.inc' + + Include 'common_track.inc' + Include 'common_sec_track.inc' + Include 'common_sec_track2.inc' + +CCC Local Variable Type Declarations: + + integer*4 mode,i,j,k,ievent,ref_print,nev + + real*4 nfac1,nfac2,ref_error + real*4 c2mod_proj1(max_c2_3d) + real*4 c2mod_proj2(max_c2_3d) + real*4 c2mod_proj3(max_c2_3d) + real*4 c2fit_proj1(max_c2_3d) + real*4 c2fit_proj2(max_c2_3d) + real*4 c2fit_proj3(max_c2_3d) + real*4 c2err_proj1(max_c2_3d) + real*4 c2err_proj2(max_c2_3d) + real*4 c2err_proj3(max_c2_3d) + +C------------------------------------------- + If(mode.eq.1) Then !Basic Output Header +C------------------------------------------- + + write(8,100) + write(8,101) + write(8,100) +C write(8,102) n_events + write(8,103) n_pid_types,pid(1),mass1,pid(2),mass2 + write(8,104) ref_control + write(8,105) switch_1d + write(8,106) switch_3d + write(8,107) switch_type + write(8,108) switch_coherence + write(8,109) switch_coulomb + write(8,110) switch_fermi_bose + write(8,1101) trk_accep + write(8,111) print_full,print_sector_data +C write(8,112) n_part_used_1_ref,n_part_used_2_ref +C write(8,113) n_part_used_1_inc,n_part_used_2_inc +C write(8,114) num_pairs_like_ref,num_pairs_unlike_ref +C write(8,115) num_pairs_like_inc,num_pairs_unlike_inc + write(8,116) lambda + write(8,117) R_1d + write(8,118) Rside,Rout,Rlong + write(8,119) Rperp,Rparallel,R0 + write(8,120) Q0 + write(8,121) irand + write(8,122) maxit + write(8,123) deltap + write(8,124) delchi + write(8,125) chisq_wt_like_1d + write(8,126) chisq_wt_unlike_1d + write(8,127) chisq_wt_like_3d_fine + write(8,128) chisq_wt_unlike_3d_fine + write(8,129) chisq_wt_like_3d_coarse + write(8,130) chisq_wt_unlike_3d_coarse + write(8,131) chisq_wt_hist1_1 + write(8,132) chisq_wt_hist1_2 + write(8,133) + write(8,134) n_pt_bins,pt_bin_size,pt_min,pt_max + write(8,135) n_phi_bins,phi_bin_size,phi_min,phi_max + write(8,136) n_eta_bins,eta_bin_size,eta_min,eta_max + write(8,137) + write(8,138) n_px_bins,delpx,px_min,px_max + write(8,139) n_py_bins,delpy,py_min,py_max + write(8,140) n_pz_bins,delpz,pz_min,pz_max + write(8,141) n_sectors + write(8,142) + write(8,143) n_1d_fine,n_1d_coarse,n_1d_total + write(8,144) binsize_1d_fine,binsize_1d_coarse + write(8,145) qmid_1d,qmax_1d + write(8,146) + write(8,147) n_3d_fine,n_3d_coarse,n_3d_total + write(8,148) binsize_3d_fine,binsize_3d_coarse + write(8,149) qmid_3d,qmax_3d + write(8,150) n_3d_fine_project + +CCC Formats for Mode=1 Output + + 100 format( 15x,50('*')) + 101 format( 15x,'*****',7x,'HBT CORRELATION SIMULATION',7x,'*****') + 102 format(///15x,'Number of Events in Event Text Input File=',I5) + 103 format( /15x,'#PID types=',I2,' PID#,mass=',I2,F8.5, + 1' PID#,mass=',I2,F8.5) + 104 format(/ 15x,'Reference Spectra Selection Option=',I2) + 105 format(// 15x,'Control Switches: Switch_1d =',I2) + 106 format( 15x,' Switch_3d =',I2) + 107 format( 15x,' Switch_type =',I2) + 108 format( 15x,' Switch_coherence =',I2) + 109 format( 15x,' Switch_coulomb =',I2) + 110 format( 15x,' Switch_fermi_bose =',I2) +1101 format( 15x,' trk_accep =',F10.7) + 111 format(/ 15x,'Print Options: Full=',I2,' Sectors=',I2) + 112 format(// 15x, + 1'Number particles used in Reference, for PID types=',2I5) + 113 format( 15x, + 1'Number particles used in Inclusive, for PID types=',2I5) + 114 format(/ 15x, + 1'Number pairs used in Reference, like and unlike=',2I5) + 115 format( 15x, + 1'Number pairs used in Inclusive, like and unlike=',2I5) + 116 format(// 15x,'Correlation Model Parameters: Chaoticity =',F8.5) + 117 format( 15x,'1D Spherical Source Radius=',F8.4) + 118 format( 15x,'Bertsch-Pratt R-side,out,long=',3F8.4) + 119 format( 15x,'YKP R-perp,parallel,time=',3F8.4) + 120 format( 15x,'Coulomb parameter=',F8.5) + 121 format(// 15x,'Iteration Controls: Random # seed =',I10) + 122 format( 15x,' Max # iterations =',I5) + 123 format( 15x,' Momentum Shift Range =',F8.5) + 124 format( 15x,' Min % Chi-Sq limit =',F8.5) + 125 format(// 15x,'CHI-Sq Weights: correl,like, 1d =',F8.5) + 126 format( 15x,' correl,unlike,1d =',F8.5) + 127 format( 15x,' correl,like, 3d_fine =',F8.5) + 128 format( 15x,' correl,unlike,3d_fine =',F8.5) + 129 format( 15x,' correl,like, 3d_coarse=',F8.5) + 130 format( 15x,' correl,unlike,3d_coarse=',F8.5) + 131 format( 15x,' 1-body, PID#1 =',F8.5) + 132 format( 15x,' 1-body, PID#2 =',F8.5) + 133 format(// 15x,'Momentum Space Acceptance Range and 1D Bins:') + 134 format( 15x,'#bins,bin size,min,max for pt =',I5,3F8.5) + 135 format( 15x,'#bins,bin size,min,max for phi=',I5,3F8.4) + 136 format( 15x,'#bins,bin size,min,max for eta=',I5,3F8.4) + 137 format(// 15x,'Momentum Space Sectors:') + 138 format( 15x,'#sectors,sectorsize,min,max for px=',I5,3F8.4) + 139 format( 15x,'#sectors,sectorsize,min,max for py=',I5,3F8.4) + 140 format( 15x,'#sectors,sectorsize,min,max for pz=',I5,3F8.4) + 141 format( 15x,'Total Number of Sectors =',I5) + 142 format(// 15x,'2-Body Correlations, 1-D Grid:') + 143 format( 15x,'#bins_fine,coarse,total =',3I5) + 144 format( 15x,'bin size - fine, coarse =',2F8.5) + 145 format( 15x,'Q mid point, Q maximum =',2F8.5) + 146 format(// 15x,'2-Body Correlations, 3-D Grid:') + 147 format( 15x,'#bins - fine, coarse, total =',3I5) + 148 format( 15x,'bin size - fine, coarse =',2F8.5) + 149 format( 15x,'Q mid point, Q maximum =',2F8.5) + 150 format( 15x,'# 3D fine bin projected =',I5) + +CCC END mode=1 Output and Formats + +C----------------------------- + Else If(mode.eq.2) Then !Store 2- and 1-body Ref. Histograms +C----------------------------- + + + open(unit=9,status='unknown',access='sequential', + 1 name='hbt_pair_reference.hist') + open(unit=11,status='unknown',access='sequential', + 1 name='hbt_singles_reference.hist') + +C Write Pair Reference Hist: + + write(9,201) n_pid_types,pid(1),pid(2) + write(9,202) n_pt_bins,pt_min,pt_max + write(9,202) n_phi_bins,phi_min,phi_max + write(9,202) n_eta_bins,eta_min,eta_max + write(9,201) switch_1d,switch_3d,switch_type + write(9,203) n_1d_fine,n_1d_coarse,n_3d_fine,n_3d_coarse + write(9,204) binsize_1d_fine,binsize_1d_coarse, + 1 binsize_3d_fine,binsize_3d_coarse + write(9,201) num_pairs_like_ref,num_pairs_unlike_ref + 201 format(2x,3I10) + 202 format(2x,I10,2E15.6) + 203 format(2x,4I10) + 204 format(2x,4E15.6) + 205 format(2x,I20) + + if(switch_1d.gt.0.and.n_1d_total.gt.0) then + if(switch_type.eq.1.or.switch_type.eq.3) then + write(9,205) (href_like_1d(i),i=1,n_1d_total) + end if + if(switch_type.eq.2.or.switch_type.eq.3) then + write(9,205) (href_unlike_1d(i),i=1,n_1d_total) + endif + endif !End 1D Ref. Hist. Output + + if(switch_3d.gt.0) then + if(switch_type.eq.1.or.switch_type.eq.3) then + + if(n_3d_fine.gt.0) then + do i=1,n_3d_fine + do j=1,n_3d_fine + do k=1,n_3d_fine + write(9,205) href_like_3d_fine(i,j,k) + enddo + enddo + enddo + endif + + if(n_3d_coarse.gt.0) then + do i=1,n_3d_coarse + do j=1,n_3d_coarse + do k=1,n_3d_coarse + write(9,205) href_like_3d_coarse(i,j,k) + enddo + enddo + enddo + endif + + end if + + if(switch_type.eq.2.or.switch_type.eq.3) then + + if(n_3d_fine.gt.0) then + do i=1,n_3d_fine + do j=1,n_3d_fine + do k=1,n_3d_fine + write(9,205) href_unlike_3d_fine(i,j,k) + enddo + enddo + enddo + endif + + if(n_3d_coarse.gt.0) then + do i=1,n_3d_coarse + do j=1,n_3d_coarse + do k=1,n_3d_coarse + write(9,205) href_unlike_3d_coarse(i,j,k) + enddo + enddo + enddo + endif + + endif + endif !End 3D Reference Histograms Output + +CC Write One-Body - singles histograms: + + write(11,201) n_pid_types,pid(1),pid(2) + write(11,202) n_pt_bins,pt_min,pt_max + write(11,202) n_phi_bins,phi_min,phi_max + write(11,202) n_eta_bins,eta_min,eta_max + write(11,201) n_part_used_1_ref,n_part_used_2_ref + + if(pid(1).gt.0) then + write(11,205)(href1_pt_1(i),i=1,n_pt_bins) + write(11,205)(href1_phi_1(i),i=1,n_phi_bins) + write(11,205)(href1_eta_1(i),i=1,n_eta_bins) + endif + + + if(pid(2).gt.0) then + write(11,205)(href1_pt_2(i),i=1,n_pt_bins) + write(11,205)(href1_phi_2(i),i=1,n_phi_bins) + write(11,205)(href1_eta_2(i),i=1,n_eta_bins) + endif + + close(unit=9) + close(unit=11) + +CCC END mode=2 Reference Histogram Output + +C----------------------------- + Else If(mode.eq.3) Then !Print out the Reference Histograms +C----------------------------- + + write(8,300) + write(8,301) + write(8,302) n_pt_bins,pt_min,pt_max + write(8,303) n_phi_bins,phi_min,phi_max + write(8,304) n_eta_bins,eta_min,eta_max + write(8,305) n_part_used_1_ref,n_part_used_2_ref + + write(8,306) + do i=1,n_pt_bins + write(8,307) i,href1_pt_1(i),href1_pt_2(i) + enddo + + write(8,308) + do i=1,n_phi_bins + write(8,307) i,href1_phi_1(i),href1_phi_2(i) + enddo + + write(8,309) + do i=1,n_eta_bins + write(8,307) i,href1_eta_1(i),href1_eta_2(i) + enddo + + write(8,310) + write(8,311) n_1d_fine,n_1d_coarse + write(8,312) binsize_1d_fine,binsize_1d_coarse + write(8,313) n_3d_fine,n_3d_coarse + write(8,314) binsize_3d_fine,binsize_3d_coarse + write(8,315) num_pairs_like_ref,num_pairs_unlike_ref + + if(switch_1d.gt.0.and.n_1d_total.gt.0) then + write(8,316) + do i=1,n_1d_total + write(8,307) i,href_like_1d(i),href_unlike_1d(i) + enddo + endif !End Print Out of 2-body, 1D reference histogram + + if(switch_3d.gt.0.and.n_3d_fine.gt.0) then + write(8,317) + do i=1,n_3d_fine + do j=1,n_3d_fine + do k=1,n_3d_fine + write(8,318) i,j,k,href_like_3d_fine(i,j,k), + 1 href_unlike_3d_fine(i,j,k) + enddo + enddo + enddo + endif !End Print Out of 2-Body, 3D-Fine Mesh Ref. Hist. + + + if(switch_3d.gt.0.and.n_3d_coarse.gt.0) then + write(8,319) + do i=1,n_3d_coarse + do j=1,n_3d_coarse + do k=1,n_3d_coarse + write(8,318) i,j,k,href_like_3d_coarse(i,j,k), + 1 href_unlike_3d_coarse(i,j,k) + enddo + enddo + enddo + endif !End Print Out of 2-Body, 3D-Coarse Mesh Ref. Hist. + +CCC Formats for mode=3 Output: + + 300 format(///5x,15('*'),'REFERENCE HISTOGRAMS',15('*')) + 301 format(//15x,'ONE-BODY REFERENCE DISTRIBUTIONS:') + 302 format(/ 15x,'PT BINS: (#,min,max)=',I5,2F8.4) + 303 format( 15x,'PHI BINS:(#,min,max)=',I5,2F8.4) + 304 format( 15x,'ETA BINS:(#,min,max)=',I5,2F8.4) + 305 format( 15x,'Number particles used in Ref, PID type1,2=',2I8) + 306 format(/ 9x,'PT',10x,'BIN#',5x,'PID-1',5x,'PID-2') + 308 format(/ 9x,'PHI',9x,'BIN#',5x,'PID-1',5x,'PID-2') + 309 format(/ 9x,'ETA',9x,'BIN#',5x,'PID-1',5x,'PID-2') + 307 format( 20x,I5,2I10) + 310 format(///15x,'TWO-BODY REFERENCE DISTRIBUTIONS:') + 311 format(/ 15x,'#BINS FOR 1D-Fine and Coarse Grid =',2I5) + 312 format( 15x,'BIN SIZES FOR 1D-Fine and Coarse =',2F8.5) + 313 format( 15x,'#BINS FOR 3D-Fine and Coarse Grid =',2I5) + 314 format( 15x,'BIN SIZES FOR 3D-Fine and Coarse =',2F8.5) + 315 format( 15x,'Number of Like and Unlike Pairs For Ref. = ', + 1 2I10) + 316 format(/5x,'2-BODY, 1D',6x,'BIN#',5x,'LIKE',5x,'UNLIKE') + 317 format(/3x,'2-BODY, 3D-FINE',2x,'BIN:i',4x,'j',4x, + 1 'k',5x,'LIKE',5x,'UNLIKE') + 318 format( 20x,3I5,2I10) + 319 format(/2x,'2-BODY, 3D-COARSE',1x,'BIN:i',4x,'j',4x, + 1 'k',5x,'LIKE',5x,'UNLIKE') + +CCC END mode=3 Output and Formats + +C---------------------------- + Else If(mode.eq.4) Then !Print Correlation Function Model +C---------------------------- + + write(8,400) + write(8,311) n_1d_fine,n_1d_coarse + write(8,312) binsize_1d_fine,binsize_1d_coarse + write(8,313) n_3d_fine,n_3d_coarse + write(8,314) binsize_3d_fine,binsize_3d_coarse + + + if(switch_1d.gt.0.and.n_1d_total.gt.0) then + write(8,316) + do i=1,n_1d_total + write(8,407) i,c2mod_like_1d(i),c2mod_unlike_1d(i) + enddo + endif !End Print Out of 2-body, 1D Model Correction Functions + + if(switch_3d.gt.0.and.n_3d_fine.gt.0) then + write(8,317) + do i=1,n_3d_fine + do j=1,n_3d_fine + do k=1,n_3d_fine + write(8,418) i,j,k,c2mod_like_3d_fine(i,j,k), + 1 c2mod_unlike_3d_fine(i,j,k) + enddo + enddo + enddo + endif !End Print Out of 2-Body, 3D-Fine mesh Model Correl. Function + + if(switch_3d.gt.0.and.n_3d_coarse.gt.0) then + write(8,319) + do i=1,n_3d_coarse + do j=1,n_3d_coarse + do k=1,n_3d_coarse + write(8,418) i,j,k,c2mod_like_3d_coarse(i,j,k), + 1 c2mod_unlike_3d_coarse(i,j,k) + enddo + enddo + enddo + endif !End Print Out of 2-Body, 3D-Coarse Model Correlation Function + + if(switch_coulomb.eq.3) then ! Print interpolated Pratt Model +CC ! Coulomb Correction for Finite +CC ! Source Radius Q0 + write(8,401)Q0 + write(8,402) + do i=1,max_c2_coul + write(8,403) i,q_coul(i),c2_coul_like(i), + 1 c2_coul_unlike(i) + enddo + endif + +CCC Additional Formats for Mode=4 Output: + + 400 format(///5x,15('*'),'MODEL CORRELATION FUNCTIONS',15('*')) + 401 format(///15x,'COULOMB SOURCE RADIUS FOR PRATT MODEL=',F8.4) + 402 format(// 5x,'q-bin',2x,'q',4x,'C2_coul_like',2x, + 1 'C2_coul_unlike') + 403 format( 5x,I5,3E15.6) + 407 format( 20x,I5,2F10.7) + 418 format( 20x,3I5,2F10.7) + +CCC END MODE = 4 OUTPUT AND FORMATS + +C------------------------------ + Else If(mode.eq.5) Then ! Optional Output for 1- and 2-Body Fits +C------------------------------ ! for each event. + + write(8,500) ievent + write(8,501) n_part_1_trk,n_part_2_trk,n_part_tot_trk + write(8,502) n_part_used_1_trk, n_part_used_2_trk + write(8,503) num_pairs_like, num_pairs_unlike + +CCC Output one-body distributions for event: + + write(8,504) + if(pid(1) .gt. 0) then + nfac1 = float(n_part_used_1_trk)/float(n_part_used_1_ref) + write(8,505) nfac1 + + write(8,507) + do i = 1,n_pt_bins + ref_print = int(nfac1*float(href1_pt_1(i))) + ref_error = nfac1*sqrt(float(href1_pt_1(i))) + write(8,510) i,hist1_pt_1(i),ref_print,ref_error + end do + + write(8,508) + do i = 1,n_phi_bins + ref_print = int(nfac1*float(href1_phi_1(i))) + ref_error = nfac1*sqrt(float(href1_phi_1(i))) + write(8,510) i,hist1_phi_1(i),ref_print,ref_error + end do + + write(8,509) + do i = 1,n_eta_bins + ref_print = int(nfac1*float(href1_eta_1(i))) + ref_error = nfac1*sqrt(float(href1_eta_1(i))) + write(8,510) i,hist1_eta_1(i),ref_print,ref_error + end do + + end if ! End PID # 1, One-Body Distribution Output + + if(pid(2) .gt. 0) then + nfac2 = float(n_part_used_2_trk)/float(n_part_used_2_ref) + write(8,506) nfac2 + + write(8,507) + do i = 1,n_pt_bins + ref_print = int(nfac2*float(href1_pt_2(i))) + ref_error = nfac2*sqrt(float(href1_pt_2(i))) + write(8,510) i,hist1_pt_2(i),ref_print,ref_error + end do + + write(8,508) + do i = 1,n_phi_bins + ref_print = int(nfac2*float(href1_phi_2(i))) + ref_error = nfac2*sqrt(float(href1_phi_2(i))) + write(8,510) i,hist1_phi_2(i),ref_print,ref_error + end do + + write(8,509) + do i = 1,n_eta_bins + ref_print = int(nfac2*float(href1_eta_2(i))) + ref_error = nfac2*sqrt(float(href1_eta_2(i))) + write(8,510) i,hist1_eta_2(i),ref_print,ref_error + end do + + end if ! End PID # 2, One-Body Distribution Output + +CCC Output Two-Body Correlation Functions for Event: + + write(8,520) + if(switch_1d.gt.0 .and. n_1d_total.gt.0) then + write(8,530) + write(8,521) + write(8,522) + do i = 1,n_1d_total + write(8,523) i,c2mod_like_1d(i),c2fit_like_1d(i), + 1 c2err_like_1d(i),c2mod_unlike_1d(i), + 2 c2fit_unlike_1d(i),c2err_unlike_1d(i) + end do + end if ! End 1D Correlation Model and Fit Output + + if(switch_3d.gt.0 .and. n_3d_fine.gt.0) then + write(8,531) + write(8,524) + write(8,525) + do i = 1,n_3d_fine + do j = 1,n_3d_fine + do k = 1,n_3d_fine + write(8,526) i,j,k,c2mod_like_3d_fine(i,j,k), + 1 c2fit_like_3d_fine(i,j,k),c2err_like_3d_fine(i,j,k), + 2 c2mod_unlike_3d_fine(i,j,k),c2fit_unlike_3d_fine(i,j,k), + 3 c2err_unlike_3d_fine(i,j,k) + end do + end do + end do + end if ! End 3D Fine Mesh Correlation Model and Fit Output + + if(switch_3d.gt.0 .and. n_3d_coarse.gt.0) then + write(8,532) + write(8,524) + write(8,525) + do i = 1,n_3d_coarse + do j = 1,n_3d_coarse + do k = 1,n_3d_coarse + write(8,526) i,j,k,c2mod_like_3d_coarse(i,j,k), + 1 c2fit_like_3d_coarse(i,j,k),c2err_like_3d_coarse(i,j,k), + 2 c2mod_unlike_3d_coarse(i,j,k),c2fit_unlike_3d_coarse(i,j,k), + 3 c2err_unlike_3d_coarse(i,j,k) + end do + end do + end do + end if ! End 3D Coarse Mesh Correlation Model and Fit Output + +CCC Output Event Summary and Chi-Square Information for Event: + + write(8,539) ievent + write(8,540) num_iter(ievent) + write(8,541) n_part_used_1_store(ievent), + 1 n_part_used_2_store(ievent) + write(8,5411) n_part_tot_store(ievent) + write(8,542) num_sec_flagged_store(ievent) + write(8,543) frac_trks_out(ievent),frac_trks_flag(ievent) + write(8,544) chisq_like_1d_store(ievent), + 1 chisq_unlike_1d_store(ievent) + write(8,545) chisq_like_3d_fine_store(ievent), + 1 chisq_unlike_3d_fine_store(ievent) + write(8,546) chisq_like_3d_coarse_store(ievent), + 1 chisq_unlike_3d_coarse_store(ievent) + write(8,547) chisq_hist1_1_store(ievent), + 1 chisq_hist1_2_store(ievent) + write(8,548) chisq_total_store(ievent) + +CCC Formats for Mode = 5 Output: + +500 Format(///5x,5('*'),'Fitted 1-Body Distributions and ', + 1 'Correlations for Event #',I5,5('*')) +501 Format(//15x,'Number of Particles of PID types 1,2,total = ', + 1 3I5) +502 Format( 15x,'Number of Particles of PID types 1,2 Used = ', + 1 2I5) +503 Format( 15x,'Number of Pairs Used - Like and Unlike = ',2I10) +504 Format(//5x,'Fitted and Normalized Reference One-Body ', + 1 'Distributions') +505 Format( /10x,'Particle Type 1: Reference Scale Factor = ',E12.5) +506 Format( /10x,'Particle Type 2: Reference Scale Factor = ',E12.5) +507 Format(/2x,' PT: BIN#',5x,'hist1',7x,'href1-scaled',2x, + 1 'ref-err-scaled') +508 Format(/2x,'PHI: BIN#',5x,'hist1',7x,'href1-scaled',2x, + 1 'ref-err-scaled') +509 Format(/2x,'ETA: BIN#',5x,'hist1',7x,'href1-scaled',2x, + 1 'ref-err-scaled') +510 Format(7x,I4,3x,I7,8x,I7,7x,F10.5) +520 Format(//5x,'Model and Fitted Correlations') +530 Format(//21x,'One-Dimensional Fit - Fine & Coarse Mesh') +531 Format(//25x,'Three-Dimensional Fit - Fine Mesh') +532 Format(//24x,'Three-Dimensional Fit - Coarse Mesh') +521 Format(/1x,'BIN',13x,'LIKE PAIRS',27x,'UNLIKE PAIRS') +522 Format(8x,'MOD',9x,'FIT',9x,'ERR',11x,'MOD',9x,'FIT',9x, + 1 'ERR',/) +523 Format(1x,I3,3E12.4,2x,3E12.4) +524 Format(/2x,'BINS',12x,'LIKE PAIRS',24x,'UNLIKE PAIRS') +525 Format(1x,' i j k',4x,'MOD',8x,'FIT',8x,'ERR',10x,'MOD', + 1 8x,'FIT',8x,'ERR',/) +526 Format(1x,3I2,3E11.4,2x,3E11.4) +539 Format(///10x,'Event and Chi-Square Summary for Event #',I5) +540 Format( //15x,'Number of Iterations =',F10.2) +541 Format( 15x,'# Particles Used for PID Types1,2=',2F10.2) +5411 Format( 15x,'Total # Particles in track table =',F10.2) +542 Format( 15x,'# Sectors Flagged =',F10.2) +543 Format( 15x,'Frac Trks Out of Accep., Flagged =',2E11.4) +544 Format( 15x,'Chi-Sq: 1D - Like & Unlike =',2E11.4) +545 Format( 15x,'Chi-Sq: 3D - Fine -Like & Unlike =',2E11.4) +546 Format( 15x,'Chi-Sq: 3D - Coarse-Like &Unlike =',2E11.4) +547 Format( 15x,'Chi-Sq: One-Body Dist. PID# 1&2 =',2E11.4) +548 Format( 15x,'Chi-Sq: Total Weighted =',E11.4) + +CCC End Mode = 5 Output and Formats + +C------------------------------ + Else If(mode.eq.6) Then ! Inclusive 1 & 2 Body Output +C------------------------------ + write(8,600) n_events + write(8,601) n_part_used_1_inc,n_part_used_2_inc + write(8,602) num_pairs_like_inc,num_pairs_unlike_inc + + write(8,603) + if(pid(1).gt.0) then +C Division by zero check + IF (n_part_used_1_ref .LE. 0) THEN + PRINT*,'************************************' + PRINT*,'* HBT PROCESSOR *' + PRINT*,'* Number of particles selected for *' + PRINT*,'* processing is less or equal *' + PRINT*,'* !!!!!!!! ZER0 !!!!!!!!!! *' + PRINT*,'* unable to proceed *' + PRINT*,'* EXITING FORTRAN *' + PRINT*,'* *' + PRINT*,'* HINT: broad the parameter regions*' + PRINT*,'* OR/AND number of particles OR/AND*' + PRINT*,'* number of events *' + PRINT*,'************************************' + WRITE(7,5481) +5481 FORMAT(5x,'Number of particles selected for processing is', + 1 ' less or equal 0', + 2 ' - STOP') + errorcode = 1 + Return + END IF + nfac1=float(n_part_used_1_inc)/float(n_part_used_1_ref) + write(8,604) nfac1 + write(8,605) + do i = 1,n_pt_bins + ref_print=int(nfac1*float(href1_pt_1(i))) + ref_error=nfac1*sqrt(float(href1_pt_1(i))) + write(8,510) i,hinc1_pt_1(i),ref_print,ref_error + enddo + + write(8,606) + do i = 1,n_phi_bins + ref_print=int(nfac1*float(href1_phi_1(i))) + ref_error=nfac1*sqrt(float(href1_phi_1(i))) + write(8,510) i,hinc1_phi_1(i),ref_print,ref_error + enddo + + write(8,607) + do i = 1,n_eta_bins + ref_print=int(nfac1*float(href1_eta_1(i))) + ref_error=nfac1*sqrt(float(href1_eta_1(i))) + write(8,510) i,hinc1_eta_1(i),ref_print,ref_error + enddo + + endif !END PID #1 One-BODY INCL. DISTRIBUTION OUTPUT + + if(pid(2).gt.0) then + nfac2=float(n_part_used_2_inc)/float(n_part_used_2_ref) + write(8,608) nfac2 + write(8,605) + do i = 1,n_pt_bins + ref_print=int(nfac2*float(href1_pt_2(i))) + ref_error=nfac2*sqrt(float(href1_pt_2(i))) + write(8,510) i,hinc1_pt_2(i),ref_print,ref_error + enddo + + write(8,606) + do i = 1,n_phi_bins + ref_print=int(nfac2*float(href1_phi_2(i))) + ref_error=nfac2*sqrt(float(href1_phi_2(i))) + write(8,510) i,hinc1_phi_2(i),ref_print,ref_error + enddo + + write(8,607) + do i = 1,n_eta_bins + ref_print=int(nfac2*float(href1_eta_2(i))) + ref_error=nfac2*sqrt(float(href1_eta_2(i))) + write(8,510) i,hinc1_eta_2(i),ref_print,ref_error + enddo + + endif !END PID #2 One-BODY INCl. DISTRIBUTION OUTPUT + +CC OUTPUT TWO-BODY INCLUSIVE HISTOGRAMS: + + write(8,660) + if(switch_1d.gt.0.and.n_1d_total.gt.0) then + write(8,316) + do i=1,n_1d_total + write(8,307) i,hinc_like_1d(i),hinc_unlike_1d(i) + end do + end if ! End Print out of 2-Body, 1D Inclusive Histograms + + if(switch_3d.gt.0.and.n_3d_fine.gt.0) then + write(8,317) + do i=1,n_3d_fine + do j=1,n_3d_fine + do k=1,n_3d_fine + write(8,318) i,j,k,hinc_like_3d_fine(i,j,k), + 1 hinc_unlike_3d_fine(i,j,k) + enddo + enddo + enddo + endif ! End Print out of 2-Body, 3D-Fine Inclusive Histograms + + if(switch_3d.gt.0.and.n_3d_coarse.gt.0) then + write(8,319) + do i=1,n_3d_coarse + do j=1,n_3d_coarse + do k=1,n_3d_coarse + write(8,318) i,j,k,hinc_like_3d_coarse(i,j,k), + 1 hinc_unlike_3d_coarse(i,j,k) + enddo + enddo + enddo + endif ! End Print out of 2-Body, 3D-Coarse Inclusive Histograms + +CC OUTPUT TWO-BODY INCL.CORRELATION FUNCTIONS FOR EVENT + + write(8,620) + if(switch_1d.gt.0.and.n_1d_total.gt.0) then + write(8,530) + write(8,521) + write(8,522) + do i=1,n_1d_total + write(8,523) i,c2mod_like_1d(i),c2fit_like_1d(i), + 1 c2err_like_1d(i),c2mod_unlike_1d(i), + 2 c2fit_unlike_1d(i),c2err_unlike_1d(i) + enddo + endif + + if(switch_3d.gt.0.and.n_3d_fine.gt.0) then + write(8,531) + write(8,524) + write(8,525) + do i=1,n_3d_fine + do j=1,n_3d_fine + do k=1,n_3d_fine + write(8,526) i,j,k,c2mod_like_3d_fine(i,j,k), + 1 c2fit_like_3d_fine(i,j,k), + 2 c2err_like_3d_fine(i,j,k), + 3 c2mod_unlike_3d_fine(i,j,k), + 4 c2fit_unlike_3d_fine(i,j,k), + 5 c2err_unlike_3d_fine(i,j,k) + + enddo + enddo + enddo + endif + + if(switch_3d.gt.0.and.n_3d_coarse.gt.0) then + write(8,532) + write(8,524) + write(8,525) + do i=1,n_3d_coarse + do j=1,n_3d_coarse + do k=1,n_3d_coarse + write(8,526) i,j,k,c2mod_like_3d_coarse(i,j,k), + 1 c2fit_like_3d_coarse(i,j,k), + 2 c2err_like_3d_coarse(i,j,k), + 3 c2mod_unlike_3d_coarse(i,j,k), + 4 c2fit_unlike_3d_coarse(i,j,k), + 5 c2err_unlike_3d_coarse(i,j,k) + + enddo + enddo + enddo + endif + +CCC Compute and Print 1D projections of 3D fine mesh C2 model, +CCC fit and errors for like and unlike pairs. + + if(switch_3d .gt. 0 .and. n_3d_fine .gt. 0) then + if(switch_type .eq. 1 .or. switch_type .eq. 3) then + Call c2_3d_projected(hinc_like_3d_fine, + 1 href_like_3d_fine,c2mod_like_3d_fine, + 2 c2mod_proj1,c2mod_proj2,c2mod_proj3, + 3 c2fit_proj1,c2fit_proj2,c2fit_proj3, + 4 c2err_proj1,c2err_proj2,c2err_proj3, + 5 max_h_3d, max_c2_3d, n_3d_fine, + 6 n_3d_fine_project,num_pairs_like_inc, + 7 num_pairs_like_ref) + write(8,650) + write(8,651) + write(8,657) + do i = 1,n_3d_fine + write(8,658) i,c2mod_proj1(i),c2fit_proj1(i),c2err_proj1(i) + end do + write(8,652) + write(8,657) + do i = 1,n_3d_fine + write(8,658) i,c2mod_proj2(i),c2fit_proj2(i),c2err_proj2(i) + end do + write(8,653) + write(8,657) + do i = 1,n_3d_fine + write(8,658) i,c2mod_proj3(i),c2fit_proj3(i),c2err_proj3(i) + end do + end if ! End Like pair output + + if(switch_type .eq. 2 .or. switch_type .eq. 3) then + Call c2_3d_projected(hinc_unlike_3d_fine, + 1 href_unlike_3d_fine,c2mod_unlike_3d_fine, + 2 c2mod_proj1,c2mod_proj2,c2mod_proj3, + 3 c2fit_proj1,c2fit_proj2,c2fit_proj3, + 4 c2err_proj1,c2err_proj2,c2err_proj3, + 5 max_h_3d, max_c2_3d, n_3d_fine, + 6 n_3d_fine_project,num_pairs_unlike_inc, + 7 num_pairs_unlike_ref) + write(8,654) + write(8,657) + do i = 1,n_3d_fine + write(8,658) i,c2mod_proj1(i),c2fit_proj1(i),c2err_proj1(i) + end do + write(8,655) + write(8,657) + do i = 1,n_3d_fine + write(8,658) i,c2mod_proj2(i),c2fit_proj2(i),c2err_proj2(i) + end do + write(8,656) + write(8,657) + do i = 1,n_3d_fine + write(8,658) i,c2mod_proj3(i),c2fit_proj3(i),c2err_proj3(i) + end do + end if ! End Unlike pair output + end if ! End 1D projections + + +CCC EVENT AND CHISQ SUMMARY INFORMATION: + + if(n_events.le.max_events) then + nev=n_events + else + nev=max_events + endif + + write(8,621) + write(8,622) + + do i=1,nev + write(8,623) i,num_iter(i),n_part_used_1_store(i), + 1 n_part_used_2_store(i), + 2 num_sec_flagged_store(i), + 3 frac_trks_out(i),frac_trks_flag(i), + 4 chisq_total_store(i) + enddo + + write(8,6231) trk_maxlen + write(8,6232) + do i=1,nev + write(8,6233) i,n_part_tot_store(i) + end do + + write(8,624) + do i=1,nev + write(8,625) i,chisq_like_1d_store(i), + 1 chisq_unlike_1d_store(i) + enddo + + + write(8,626) + do i=1,nev + write(8,625) i,chisq_like_3d_fine_store(i), + 1 chisq_unlike_3d_fine_store(i) + enddo + + + write(8,627) + do i=1,nev + write(8,625) i,chisq_like_3d_coarse_store(i), + 1 chisq_unlike_3d_coarse_store(i) + enddo + + + write(8,628) + do i=1,nev + write(8,625) i,chisq_hist1_1_store(i), + 1 chisq_hist1_2_store(i) + enddo + +CCC Output the Mean and RMS values for the Event Loop: + + write(8,629) + write(8,630) + write(8,631) niter_mean,niter_rms + write(8,632) npart1_mean,npart1_rms + write(8,633) npart2_mean,npart2_rms + write(8,6331) npart_tot_mean, npart_tot_rms + write(8,634) nsec_flag_mean,nsec_flag_rms + write(8,635) frac_trks_out_mean,frac_trks_out_rms + write(8,636) frac_trks_flag_mean,frac_trks_flag_rms + write(8,637) chi_l1d_mean,chi_l1d_rms + write(8,638) chi_u1d_mean,chi_u1d_rms + write(8,639) chi_l3f_mean,chi_l3f_rms + write(8,640) chi_u3f_mean,chi_u3f_rms + write(8,641) chi_l3c_mean,chi_l3c_rms + write(8,642) chi_u3c_mean,chi_u3c_rms + write(8,643) chi_1_1_mean,chi_1_1_rms + write(8,644) chi_1_2_mean,chi_1_2_rms + write(8,645) chi_tot_mean,chi_tot_rms + +CCC FORMATS FOR MODE = 6 OUTPUT + + 600 format(/// 2x,'FITTED 1-BODY DIST. AND CORRELATIONS ', + 1 'FOR INCLUSIVE SUM OF',I5,' EVENTS') + 601 format(// 15x,'Inclusive # Particles USED of PID ', + 1 'types 1,2=',2I8) + 602 format( 15x,'Inclusive # of pairs used; like/unlike=', + 1 2I10) + 603 format(// 5x,'Inclusive and Normalized Reference ', + 1 'One-Body Distributions') + 604 format(/ 10x,'Inclusive: Particle Type 1 - Reference ', + 1 'Scale Factor=',E12.5) + 605 format(/ 2x,' PT: BIN#',5x,'hinc1',7x,'href1-scaled',2x, + 1 'ref-err-scaled') + 606 format(/ 2x,'PHI: BIN#',5x,'hinc1',7x,'href1-scaled',2x, + 1 'ref-err-scaled') + 607 format(/ 2x,'ETA: BIN#',5x,'hinc1',7x,'href1-scaled',2x, + 1 'ref-err-scaled') + 608 format(/ 10x,'Inclusive: Particle Type 2 - ', + 1 'Reference Scale Factor=',E12.5) + 620 format(// 5x,'MODEL AND INCLUSIVE FITTED CORRELATIONS') + 621 format(// 15x,'Event and Chi-Square Summary Lists') + 622 format(/ 3x,'event',2x,'#iter',3x,'#PID1',4x,'#PID2',3x, + 1 '#sec-flg',3x,'frac-out',4x,'frac-flg',3x,'CHISQ-TOT') + 623 format(3x,I5,2x,F6.0,2(1x,F8.0),1x,F9.0, + 1 2(1x,F11.8),1x,E11.4) +6231 format(/5x,'Max# tracks allowed in track table = ',I8) +6232 format(/5x,'event',4x,'Tot# trks') +6233 format(5x,I5,F12.2) + 624 format(/5x,'event',4x,'CHI_l1d',8x,'CHI_u1d') + 626 format(/5x,'event',4x,'CHI_l3f',8x,'CHI_u3f') + 627 format(/5x,'event',4x,'CHI_l3c',8x,'CHI_u3c') + 628 format(/5x,'event',4x,'CHI_1-1',8x,'CHI_1-2') + 625 format(5x,I5,2E15.6) + 629 format(// 10x,'Event and Chi-Square Summary - ', + 1 'Mean and RMS Values') + 630 format(/ 14x,'Quantity',15x,'Mean',11x,'RMS') + 631 format( 5x,'Number of Iterations ',2E15.6) + 632 format( 5x,'#PID Type 1 ',2E15.6) + 633 format( 5x,'#PID Type 2 ',2E15.6) +6331 format( 5x,'Tot # Tracks in Table ',2E15.6) + 634 format( 5x,'#Sectors Flagged ',2E15.6) + 635 format( 5x,'Frac. Trks Out of Accept. ',2E15.6) + 636 format( 5x,'Frac. Trks Flagged ',2E15.6) + 637 format( 5x,'CHISQ like 1D ',2E15.6) + 638 format( 5x,'CHISQ unlike 1D ',2E15.6) + 639 format( 5x,'CHISQ like 3D Fine ',2E15.6) + 640 format( 5x,'CHISQ unlike 3D Fine ',2E15.6) + 641 format( 5x,'CHISQ like 3D Coarse ',2E15.6) + 642 format( 5x,'CHISQ unlike 3D Coarse ',2E15.6) + 643 format( 5x,'CHISQ 1 Body #1 ',2E15.6) + 644 format( 5x,'CHISQ 1 Body #2 ',2E15.6) + 645 format( 5x,'CHISQ Total ',2E15.6) + 650 format(//10x ,'Inclusive Three-Dimensional Projected Fits -', + 1 ' Fine Mesh') + 651 format( /25x ,'Like Pairs - Axis #1 ') + 652 format( /25x ,'Like Pairs - Axis #2 ') + 653 format( /25x ,'Like Pairs - Axis #3 ') + 654 format( /25x ,'Unlike Pairs - Axis #1 ') + 655 format( /25x ,'Unlike Pairs - Axis #2 ') + 656 format( /25x ,'Unlike Pairs - Axis #3 ') + 657 format( 2x,'BIN#',3x,'Model',8x,'Fit',8x,'Error') + 658 format( 3x,I3,3E12.4) + 660 format(// 5x,'INCLUSIVE TWO-BODY HISTOGRAMS') + +CCC END MODE = 6 OUTPUT AND FORMATS + +C---------------- + END IF +C---------------- + + Return + END + +C----------------------------------------------------------------------- + + + subroutine c2_3d_projected(h,href,c2mod, + 1 c2mod_proj1,c2mod_proj2,c2mod_proj3, + 2 c2fit_proj1,c2fit_proj2,c2fit_proj3, + 3 c2err_proj1,c2err_proj2,c2err_proj3, + 4 maxh,maxc2,n,n_proj,num_pairs_sig, + 5 num_pairs_bkg) + + implicit none + +CCC This Subroutine computes the projected two-body correlation +CCC function for 3D distributions - fine mesh only; for both the +CCC correlation model (weighted with the reference histogram) and +CCC the inclusive correlation fit. +CCC +CCC Description of Input Variables in the Argument List: +CCC +CCC h(maxh,maxh,maxh) = 3D fine mesh inclusive signal histog. +CCC href(maxh,maxh,maxh) = 3D fine mesh inclusive background hist. +CCC c2mod(maxc2,maxc2,maxc2) = 3D fine mesh correlation model +CCC maxh = Dimension of 3D fine mesh histogram arrays +CCC maxc2 = Dimension of 3D fine mesh correlation function arrays +CCC n = Number of bins to use +CCC n_proj = Number of bins to integrate in (i,j) to project onto (k) +CCC num_pairs_sig = # pairs used in signal histogram +CCC num_pairs_bkg = # pairs used in background histogram +CCC +CCC Description of Output quantities: +CCC +CCC c2mod_proj1,2,3(maxc2) = Reference histogram weighted 1D projections +CCC of C2 model function along {1,2,3} axes. +CCC c2fit_proj1,2,3(maxc2) = Fitted 3D correlation function projected +CCC onto {1,2,3} axes. +CCC c2err_proj1,2,3(maxc2) = Error in fitted 3D correlation function +CCC projected onto {1,2,3} axes. + +CCC Local Variable Type Declarations: + + integer*4 maxh,maxc2,n,n_proj,num_pairs_sig,num_pairs_bkg + integer*4 h(maxh,maxh,maxh),href(maxh,maxh,maxh) + integer*4 i,j,k + + real*4 c2mod(maxc2,maxc2,maxc2) + real*4 c2mod_proj1(maxc2),c2mod_proj2(maxc2),c2mod_proj3(maxc2) + real*4 c2fit_proj1(maxc2),c2fit_proj2(maxc2),c2fit_proj3(maxc2) + real*4 c2err_proj1(maxc2),c2err_proj2(maxc2),c2err_proj3(maxc2) + real*4 a,a_error,b,b_error + real*4 sum1n,sum1d,sum2n,sum2d,sum3n,sum3d + +CCC Initialize arrays to zero: + + do i = 1,maxc2 + c2mod_proj1(i) = 0.0 + c2mod_proj2(i) = 0.0 + c2mod_proj3(i) = 0.0 + c2fit_proj1(i) = 0.0 + c2fit_proj2(i) = 0.0 + c2fit_proj3(i) = 0.0 + c2err_proj1(i) = 0.0 + c2err_proj2(i) = 0.0 + c2err_proj3(i) = 0.0 + end do + +CCC Project Reference spectra (histogram) weighted model correlation: + + do i = 1,n + sum1n = 0.0 + sum1d = 0.0 + sum2n = 0.0 + sum2d = 0.0 + sum3n = 0.0 + sum3d = 0.0 + do j = 1,n_proj + do k = 1,n_proj + sum1n = sum1n + c2mod(i,j,k)*float(href(i,j,k)) + sum1d = sum1d + float(href(i,j,k)) + sum2n = sum2n + c2mod(k,i,j)*float(href(k,i,j)) + sum2d = sum2d + float(href(k,i,j)) + sum3n = sum3n + c2mod(j,k,i)*float(href(j,k,i)) + sum3d = sum3d + float(href(j,k,i)) + end do + end do + if(sum1d .le. 0.0) then + c2mod_proj1(i) = 0.0 + else + c2mod_proj1(i) = sum1n/sum1d + end if + if(sum2d .le. 0.0) then + c2mod_proj2(i) = 0.0 + else + c2mod_proj2(i) = sum2n/sum2d + end if + if(sum3d .le. 0.0) then + c2mod_proj3(i) = 0.0 + else + c2mod_proj3(i) = sum3n/sum3d + end if + end do + +CCC Calculate and Project the fitted correlation functions: + + do i = 1,n + sum1n = 0.0 + sum1d = 0.0 + sum2n = 0.0 + sum2d = 0.0 + sum3n = 0.0 + sum3d = 0.0 + do j = 1,n_proj + do k = 1,n_proj + sum1n = sum1n + float(h(i,j,k)) + sum1d = sum1d + float(href(i,j,k)) + sum2n = sum2n + float(h(k,i,j)) + sum2d = sum2d + float(href(k,i,j)) + sum3n = sum3n + float(h(j,k,i)) + sum3d = sum3d + float(href(j,k,i)) + end do + end do + if(sum1n .le. 0.0 .or. sum1d .le. 0.0) then + c2fit_proj1(i) = 0.0 + c2err_proj1(i) = 1.0 + else + a = sum1n/float(num_pairs_sig) + a_error = sqrt(sum1n)/float(num_pairs_sig) + b = sum1d/float(num_pairs_bkg) + b_error = sqrt(sum1d)/float(num_pairs_bkg) + c2fit_proj1(i) = a/b + c2err_proj1(i) = c2fit_proj1(i)*sqrt((a_error/a)**2 + 1 + (b_error/b)**2) + end if + if(sum2n .le. 0.0 .or. sum2d .le. 0.0) then + c2fit_proj2(i) = 0.0 + c2err_proj2(i) = 1.0 + else + a = sum2n/float(num_pairs_sig) + a_error = sqrt(sum2n)/float(num_pairs_sig) + b = sum2d/float(num_pairs_bkg) + b_error = sqrt(sum2d)/float(num_pairs_bkg) + c2fit_proj2(i) = a/b + c2err_proj2(i) = c2fit_proj2(i)*sqrt((a_error/a)**2 + 1 + (b_error/b)**2) + end if + if(sum3n .le. 0.0 .or. sum3d .le. 0.0) then + c2fit_proj3(i) = 0.0 + c2err_proj3(i) = 1.0 + else + a = sum3n/float(num_pairs_sig) + a_error = sqrt(sum3n)/float(num_pairs_sig) + b = sum3d/float(num_pairs_bkg) + b_error = sqrt(sum3d)/float(num_pairs_bkg) + c2fit_proj3(i) = a/b + c2err_proj3(i) = c2fit_proj3(i)*sqrt((a_error/a)**2 + 1 + (b_error/b)**2) + end if + end do + + Return + END + +C---------------------------------------------------------------------- + +C>>>>>>>>>>>>>> Piotr, this needs to be replaced with Ali random +C>>>>>>>>>>>>>>> number generator + +* real*4 function hbtpran(i) +* implicit none +* integer i +* real*4 r +* Call ranhbtp(r,1,i) +* hbtpran = r +* Return +* END + +* Include 'ranlux2.f' +C---------------------------------------------------------------------- + + + + diff --git a/HBTP/hbt_particle_st.inc b/HBTP/hbt_particle_st.inc new file mode 100644 index 00000000000..705475d991e --- /dev/null +++ b/HBTP/hbt_particle_st.inc @@ -0,0 +1,13 @@ +CCC Geant Particle Properties: + + Integer*4 part_maxlen + Parameter (part_maxlen = 50) + + STRUCTURE /particle/ + Integer*4 id ! Geant particle ID code number; required +CCC ! to be equal to the row number + Integer*4 charge ! Electric charge in units of |e| + Real*4 mass ! Rest mass in GeV/c**2 + Real*4 lifetime ! Proper lifetime in sec. + END STRUCTURE + diff --git a/HBTP/hbt_sec_track2_st.inc b/HBTP/hbt_sec_track2_st.inc new file mode 100644 index 00000000000..0251ba7536f --- /dev/null +++ b/HBTP/hbt_sec_track2_st.inc @@ -0,0 +1,21 @@ +CCC Second Track-to-Sector Mapping data structure: +CCC (Used for building the reference spectrum from the +CCC input event text file.) + + Integer*4 max_trk_sec2 + Integer*4 sec_maxlen2 + Parameter (max_trk_sec2 = 30) + Parameter (sec_maxlen2 = 28000) + + STRUCTURE /sec_trk_map2/ + Integer*4 sec_id ! unique sector ID number + Integer*4 n_trk_sec ! Number of tracks assigned to sector + Integer*4 flag ! normally=0, if = 1 then more than +CCC ! max_trk_sec tracks could have been +CCC ! assigned to this sector, however the +CCC ! maximum number that can be assigned is +CCC ! max_trk_sec2. + Integer*4 track_id(max_trk_sec2) +CCC ! Foreign keys to tracks in /track2/ that +CCC ! are assigned to this sector. + END STRUCTURE diff --git a/HBTP/hbt_sec_track_st.inc b/HBTP/hbt_sec_track_st.inc new file mode 100644 index 00000000000..1a7b88730c7 --- /dev/null +++ b/HBTP/hbt_sec_track_st.inc @@ -0,0 +1,19 @@ +CCC Track-to-Sector Mapping data structure: + + Integer*4 max_trk_sec + Integer*4 sec_maxlen + Parameter (max_trk_sec = 30) + Parameter (sec_maxlen = 28000) + + STRUCTURE /sec_trk_map/ + Integer*4 sec_id ! unique sector ID number + Integer*4 n_trk_sec ! Number of tracks assigned to sector + Integer*4 flag ! normally=0, if = 1 then more than +CCC ! max_trk_sec tracks could have been +CCC ! assigned to this sector, however the +CCC ! maximum number that can be assigned is +CCC ! max_trk_sec. + Integer*4 track_id(max_trk_sec) +CCC ! Foreign keys to tracks in /track/ that +CCC ! are assigned to this sector. + END STRUCTURE diff --git a/HBTP/hbt_track2_st.inc b/HBTP/hbt_track2_st.inc new file mode 100644 index 00000000000..bbbae1eeb87 --- /dev/null +++ b/HBTP/hbt_track2_st.inc @@ -0,0 +1,33 @@ +CCC Second Track Data Structure: +CCC (This one is needed to build the reference spectrum from +CCC the event text input file.) + + Integer*4 trk2_maxlen + Parameter (trk2_maxlen = 6500) + + STRUCTURE /track2/ + Integer*4 id ! Track ID number + Integer*4 px_sec ! px sector number + Integer*4 py_sec ! py sector number + Integer*4 pz_sec ! pz sector number + Integer*4 sector ! unique sector ID number + Integer*4 flag ! normally=0,if 1 indicates track assigned +CCC ! to sector with too many tracks, if = 1 +CCC ! then track is not used. See /sec_trk_map/ + Integer*4 out_flag ! flag indicating track in/out of accept. +CCC ! non-zero for track pushed out of accept. + Integer*4 merge_flag ! flag indicating track is merged (not used) + Integer*4 ge_pid ! Geant particle ID code number + Integer*4 start_vertex ! From input event file - track's start vrtx + Integer*4 stop_vertex ! From input event file - track's stop vrtx + Integer*4 event_line ! Line # of track in input event text file + + Real*4 px ! x component of track momentum in GeV/c + Real*4 py ! y component of track momentum in GeV/c + Real*4 pz ! z component of track momentum in GeV/c + Real*4 E ! Total energy of track in GeV + Real*4 pt ! pt of track momentum in GeV/c + Real*4 phi ! azimuthal angle of track in degrees + Real*4 eta ! pseudorapidity of track + END STRUCTURE + diff --git a/HBTP/hbt_track_st.inc b/HBTP/hbt_track_st.inc new file mode 100644 index 00000000000..c261d4aa721 --- /dev/null +++ b/HBTP/hbt_track_st.inc @@ -0,0 +1,31 @@ +CCC Track Data Structure: + + Integer*4 trk_maxlen + Parameter (trk_maxlen = 6500) + + STRUCTURE /track/ + Integer*4 id ! Track ID number + Integer*4 px_sec ! px sector number + Integer*4 py_sec ! py sector number + Integer*4 pz_sec ! pz sector number + Integer*4 sector ! unique sector ID number + Integer*4 flag ! normally=0,if 1 indicates track assigned +CCC ! to sector with too many tracks, if = 1 +CCC ! then track is not used. See /sec_trk_map/ + Integer*4 out_flag ! flag indicating track in/out of accept. +CCC ! non-zero for track pushed out of accept. + Integer*4 merge_flag ! flag indicating track is merged (not used) + Integer*4 ge_pid ! Geant particle ID code number + Integer*4 start_vertex ! From input event file - track's start vrtx + Integer*4 stop_vertex ! From input event file - track's stop vrtx + Integer*4 event_line ! Line # of track in input event text file + + Real*4 px ! x component of track momentum in GeV/c + Real*4 py ! y component of track momentum in GeV/c + Real*4 pz ! z component of track momentum in GeV/c + Real*4 E ! Total energy of track in GeV + Real*4 pt ! pt of track momentum in GeV/c + Real*4 phi ! azimuthal angle of track in degrees + Real*4 eta ! pseudorapidity of track + END STRUCTURE + diff --git a/HBTP/ranlux.f b/HBTP/ranlux.f new file mode 100644 index 00000000000..030639a1408 --- /dev/null +++ b/HBTP/ranlux.f @@ -0,0 +1,309 @@ +C* +C* $Id$ +C* +C* $Log$ +C* Revision 1.2 1997/09/22 13:45:47 mclareni +C* Correct error in initializing RANLUX by using RLUXIN with the output of +C* RLUXUT from a previous run. +C* +C* Revision 1.1.1.1 1996/04/01 15:02:55 mclareni +C* Mathlib gen +C* +C* +C#include "gen/pilot.h" + SUBROUTINE RANLUX(RVEC,LENV) +C Subtract-and-borrow random number generator proposed by +C Marsaglia and Zaman, implemented by F. James with the name +C RCARRY in 1991, and later improved by Martin Luescher +C in 1993 to produce "Luxury Pseudorandom Numbers". +C Fortran 77 coded by F. James, 1993 +C +C LUXURY LEVELS. +C ------ ------ The available luxury levels are: +C +C level 0 (p=24): equivalent to the original RCARRY of Marsaglia +C and Zaman, very long period, but fails many tests. +C level 1 (p=48): considerable improvement in quality over level 0, +C now passes the gap test, but still fails spectral test. +C level 2 (p=97): passes all known tests, but theoretically still +C defective. +C level 3 (p=223): DEFAULT VALUE. Any theoretically possible +C correlations have very small chance of being observed. +C level 4 (p=389): highest possible luxury, all 24 bits chaotic. +C +C!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +C!!! Calling sequences for RANLUX: ++ +C!!! CALL RANLUX (RVEC, LEN) returns a vector RVEC of LEN ++ +C!!! 32-bit random floating point numbers between ++ +C!!! zero (not included) and one (also not incl.). ++ +C!!! CALL RLUXGO(LUX,INT,K1,K2) initializes the generator from ++ +C!!! one 32-bit integer INT and sets Luxury Level LUX ++ +C!!! which is integer between zero and MAXLEV, or if ++ +C!!! LUX .GT. 24, it sets p=LUX directly. K1 and K2 ++ +C!!! should be set to zero unless restarting at a break++ +C!!! point given by output of RLUXAT (see RLUXAT). ++ +C!!! CALL RLUXAT(LUX,INT,K1,K2) gets the values of four integers++ +C!!! which can be used to restart the RANLUX generator ++ +C!!! at the current point by calling RLUXGO. K1 and K2++ +C!!! specify how many numbers were generated since the ++ +C!!! initialization with LUX and INT. The restarting ++ +C!!! skips over K1+K2*E9 numbers, so it can be long.++ +C!!! A more efficient but less convenient way of restarting is by: ++ +C!!! CALL RLUXIN(ISVEC) restarts the generator from vector ++ +C!!! ISVEC of 25 32-bit integers (see RLUXUT) ++ +C!!! CALL RLUXUT(ISVEC) outputs the current values of the 25 ++ +C!!! 32-bit integer seeds, to be used for restarting ++ +C!!! ISVEC must be dimensioned 25 in the calling program ++ +C!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + DIMENSION RVEC(LENV) + DIMENSION SEEDS(24), ISEEDS(24), ISDEXT(25) + PARAMETER (MAXLEV=4, LXDFLT=3) + DIMENSION NDSKIP(0:MAXLEV) + DIMENSION NEXT(24) + PARAMETER (TWOP12=4096., IGIGA=1000000000,JSDFLT=314159265) + PARAMETER (ITWO24=2**24, ICONS=2147483563) + SAVE NOTYET, I24, J24, CARRY, SEEDS, TWOM24, TWOM12, LUXLEV + SAVE NSKIP, NDSKIP, IN24, NEXT, KOUNT, MKOUNT, INSEED + INTEGER LUXLEV + LOGICAL NOTYET + DATA NOTYET, LUXLEV, IN24, KOUNT, MKOUNT /.TRUE., LXDFLT, 0,0,0/ + DATA I24,J24,CARRY/24,10,0./ +C default +C Luxury Level 0 1 2 *3* 4 + DATA NDSKIP/0, 24, 73, 199, 365 / +Corresponds to p=24 48 97 223 389 +C time factor 1 2 3 6 10 on slow workstation +C 1 1.5 2 3 5 on fast mainframe +C +C NOTYET is .TRUE. if no initialization has been performed yet. +C Default Initialization by Multiplicative Congruential + IF (NOTYET) THEN + NOTYET = .FALSE. + JSEED = JSDFLT + INSEED = JSEED + WRITE(6,'(A,I12)') ' RANLUX DEFAULT INITIALIZATION: ',JSEED + LUXLEV = LXDFLT + NSKIP = NDSKIP(LUXLEV) + LP = NSKIP + 24 + IN24 = 0 + KOUNT = 0 + MKOUNT = 0 + WRITE(6,'(A,I2,A,I4)') ' RANLUX DEFAULT LUXURY LEVEL = ', + + LUXLEV,' p =',LP + TWOM24 = 1. + DO 25 I= 1, 24 + TWOM24 = TWOM24 * 0.5 + K = JSEED/53668 + JSEED = 40014*(JSEED-K*53668) -K*12211 + IF (JSEED .LT. 0) JSEED = JSEED+ICONS + ISEEDS(I) = MOD(JSEED,ITWO24) + 25 CONTINUE + TWOM12 = TWOM24 * 4096. + DO 50 I= 1,24 + SEEDS(I) = REAL(ISEEDS(I))*TWOM24 + NEXT(I) = I-1 + 50 CONTINUE + NEXT(1) = 24 + I24 = 24 + J24 = 10 + CARRY = 0. + IF (SEEDS(24) .EQ. 0.) CARRY = TWOM24 + ENDIF +C +C The Generator proper: "Subtract-with-borrow", +C as proposed by Marsaglia and Zaman, +C Florida State University, March, 1989 +C + DO 100 IVEC= 1, LENV + UNI = SEEDS(J24) - SEEDS(I24) - CARRY + IF (UNI .LT. 0.) THEN + UNI = UNI + 1.0 + CARRY = TWOM24 + ELSE + CARRY = 0. + ENDIF + SEEDS(I24) = UNI + I24 = NEXT(I24) + J24 = NEXT(J24) + RVEC(IVEC) = UNI +C small numbers (with less than 12 "significant" bits) are "padded". + IF (UNI .LT. TWOM12) THEN + RVEC(IVEC) = RVEC(IVEC) + TWOM24*SEEDS(J24) +C and zero is forbidden in case someone takes a logarithm + IF (RVEC(IVEC) .EQ. 0.) RVEC(IVEC) = TWOM24*TWOM24 + ENDIF +C Skipping to luxury. As proposed by Martin Luscher. + IN24 = IN24 + 1 + IF (IN24 .EQ. 24) THEN + IN24 = 0 + KOUNT = KOUNT + NSKIP + DO 90 ISK= 1, NSKIP + UNI = SEEDS(J24) - SEEDS(I24) - CARRY + IF (UNI .LT. 0.) THEN + UNI = UNI + 1.0 + CARRY = TWOM24 + ELSE + CARRY = 0. + ENDIF + SEEDS(I24) = UNI + I24 = NEXT(I24) + J24 = NEXT(J24) + 90 CONTINUE + ENDIF + 100 CONTINUE + KOUNT = KOUNT + LENV + IF (KOUNT .GE. IGIGA) THEN + MKOUNT = MKOUNT + 1 + KOUNT = KOUNT - IGIGA + ENDIF + RETURN +C +C Entry to input and float integer seeds from previous run + ENTRY RLUXIN(ISDEXT) + NOTYET = .FALSE. + TWOM24 = 1. + DO 195 I= 1, 24 + NEXT(I) = I-1 + 195 TWOM24 = TWOM24 * 0.5 + NEXT(1) = 24 + TWOM12 = TWOM24 * 4096. + WRITE(6,'(A)') ' FULL INITIALIZATION OF RANLUX WITH 25 INTEGERS:' + WRITE(6,'(5X,5I12)') ISDEXT + DO 200 I= 1, 24 + SEEDS(I) = REAL(ISDEXT(I))*TWOM24 + 200 CONTINUE + CARRY = 0. + IF (ISDEXT(25) .LT. 0) CARRY = TWOM24 + ISD = IABS(ISDEXT(25)) + I24 = MOD(ISD,100) + ISD = ISD/100 + J24 = MOD(ISD,100) + ISD = ISD/100 + IN24 = MOD(ISD,100) + ISD = ISD/100 + LUXLEV = ISD + IF (LUXLEV .LE. MAXLEV) THEN + NSKIP = NDSKIP(LUXLEV) + WRITE (6,'(A,I2)') ' RANLUX LUXURY LEVEL SET BY RLUXIN TO: ', + + LUXLEV + ELSE IF (LUXLEV .GE. 24) THEN + NSKIP = LUXLEV - 24 + WRITE (6,'(A,I5)') ' RANLUX P-VALUE SET BY RLUXIN TO:',LUXLEV + ELSE + NSKIP = NDSKIP(MAXLEV) + WRITE (6,'(A,I5)') ' RANLUX ILLEGAL LUXURY RLUXIN: ',LUXLEV + LUXLEV = MAXLEV + ENDIF + INSEED = -1 + RETURN +C +C Entry to ouput seeds as integers + ENTRY RLUXUT(ISDEXT) + DO 300 I= 1, 24 + ISDEXT(I) = INT(SEEDS(I)*TWOP12*TWOP12) + 300 CONTINUE + ISDEXT(25) = I24 + 100*J24 + 10000*IN24 + 1000000*LUXLEV + IF (CARRY .GT. 0.) ISDEXT(25) = -ISDEXT(25) + RETURN +C +C Entry to output the "convenient" restart point + ENTRY RLUXAT(LOUT,INOUT,K1,K2) + LOUT = LUXLEV + INOUT = INSEED + K1 = KOUNT + K2 = MKOUNT + RETURN +C +C Entry to initialize from one or three integers + ENTRY RLUXGO(LUX,INS,K1,K2) + IF (LUX .LT. 0) THEN + LUXLEV = LXDFLT + ELSE IF (LUX .LE. MAXLEV) THEN + LUXLEV = LUX + ELSE IF (LUX .LT. 24 .OR. LUX .GT. 2000) THEN + LUXLEV = MAXLEV + WRITE (6,'(A,I7)') ' RANLUX ILLEGAL LUXURY RLUXGO: ',LUX + ELSE + LUXLEV = LUX + DO 310 ILX= 0, MAXLEV + IF (LUX .EQ. NDSKIP(ILX)+24) LUXLEV = ILX + 310 CONTINUE + ENDIF + IF (LUXLEV .LE. MAXLEV) THEN + NSKIP = NDSKIP(LUXLEV) + WRITE(6,'(A,I2,A,I4)') ' RANLUX LUXURY LEVEL SET BY RLUXGO :', + + LUXLEV,' P=', NSKIP+24 + ELSE + NSKIP = LUXLEV - 24 + WRITE (6,'(A,I5)') ' RANLUX P-VALUE SET BY RLUXGO TO:',LUXLEV + ENDIF + IN24 = 0 + IF (INS .LT. 0) WRITE (6,'(A)') + + ' Illegal initialization by RLUXGO, negative input seed' + IF (INS .GT. 0) THEN + JSEED = INS + WRITE(6,'(A,3I12)') ' RANLUX INITIALIZED BY RLUXGO FROM SEEDS', + + JSEED, K1,K2 + ELSE + JSEED = JSDFLT + WRITE(6,'(A)')' RANLUX INITIALIZED BY RLUXGO FROM DEFAULT SEED' + ENDIF + INSEED = JSEED + NOTYET = .FALSE. + TWOM24 = 1. + DO 325 I= 1, 24 + TWOM24 = TWOM24 * 0.5 + K = JSEED/53668 + JSEED = 40014*(JSEED-K*53668) -K*12211 + IF (JSEED .LT. 0) JSEED = JSEED+ICONS + ISEEDS(I) = MOD(JSEED,ITWO24) + 325 CONTINUE + TWOM12 = TWOM24 * 4096. + DO 350 I= 1,24 + SEEDS(I) = REAL(ISEEDS(I))*TWOM24 + NEXT(I) = I-1 + 350 CONTINUE + NEXT(1) = 24 + I24 = 24 + J24 = 10 + CARRY = 0. + IF (SEEDS(24) .EQ. 0.) CARRY = TWOM24 +C If restarting at a break point, skip K1 + IGIGA*K2 +C Note that this is the number of numbers delivered to +C the user PLUS the number skipped (if luxury .GT. 0). + KOUNT = K1 + MKOUNT = K2 + IF (K1+K2 .NE. 0) THEN + DO 500 IOUTER= 1, K2+1 + INNER = IGIGA + IF (IOUTER .EQ. K2+1) INNER = K1 + DO 450 ISK= 1, INNER + UNI = SEEDS(J24) - SEEDS(I24) - CARRY + IF (UNI .LT. 0.) THEN + UNI = UNI + 1.0 + CARRY = TWOM24 + ELSE + CARRY = 0. + ENDIF + SEEDS(I24) = UNI + I24 = NEXT(I24) + J24 = NEXT(J24) + 450 CONTINUE + 500 CONTINUE +C Get the right value of IN24 by direct calculation + IN24 = MOD(KOUNT, NSKIP+24) + IF (MKOUNT .GT. 0) THEN + IZIP = MOD(IGIGA, NSKIP+24) + IZIP2 = MKOUNT*IZIP + IN24 + IN24 = MOD(IZIP2, NSKIP+24) + ENDIF +C Now IN24 had better be between zero and 23 inclusive + IF (IN24 .GT. 23) THEN + WRITE (6,'(A/A,3I11,A,I5)') + + ' Error in RESTARTING with RLUXGO:',' The values', INS, + + K1, K2, ' cannot occur at luxury level', LUXLEV + IN24 = 0 + ENDIF + ENDIF + RETURN + END diff --git a/HBTP/ranlux2.f b/HBTP/ranlux2.f new file mode 100644 index 00000000000..65a8c847932 --- /dev/null +++ b/HBTP/ranlux2.f @@ -0,0 +1,316 @@ +C* +C* $Id$ +C* +C* $Log$ +C* Revision 1.2 1997/09/22 13:45:47 mclareni +C* Correct error in initializing RANLUX by using RLUXIN with the output of +C* RLUXUT from a previous run. +C* +C* Revision 1.1.1.1 1996/04/01 15:02:55 mclareni +C* Mathlib gen +C* +C* +C#include "gen/pilot.h" + SUBROUTINE RANLUX2(RVEC,LENV,Input_seed) +C Subtract-and-borrow random number generator proposed by +C Marsaglia and Zaman, implemented by F. James with the name +C RCARRY in 1991, and later improved by Martin Luescher +C in 1993 to produce "Luxury Pseudorandom Numbers". +C Fortran 77 coded by F. James, 1993 +C +C LUXURY LEVELS. +C ------ ------ The available luxury levels are: +C +C level 0 (p=24): equivalent to the original RCARRY of Marsaglia +C and Zaman, very long period, but fails many tests. +C level 1 (p=48): considerable improvement in quality over level 0, +C now passes the gap test, but still fails spectral test. +C level 2 (p=97): passes all known tests, but theoretically still +C defective. +C level 3 (p=223): DEFAULT VALUE. Any theoretically possible +C correlations have very small chance of being observed. +C level 4 (p=389): highest possible luxury, all 24 bits chaotic. +C +C!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +C!!! Calling sequences for RANLUX: ++ +C!!! CALL RANLUX (RVEC, LEN) returns a vector RVEC of LEN ++ +C!!! 32-bit random floating point numbers between ++ +C!!! zero (not included) and one (also not incl.). ++ +C!!! CALL RLUXGO(LUX,INT,K1,K2) initializes the generator from ++ +C!!! one 32-bit integer INT and sets Luxury Level LUX ++ +C!!! which is integer between zero and MAXLEV, or if ++ +C!!! LUX .GT. 24, it sets p=LUX directly. K1 and K2 ++ +C!!! should be set to zero unless restarting at a break++ +C!!! point given by output of RLUXAT (see RLUXAT). ++ +C!!! CALL RLUXAT(LUX,INT,K1,K2) gets the values of four integers++ +C!!! which can be used to restart the RANLUX generator ++ +C!!! at the current point by calling RLUXGO. K1 and K2++ +C!!! specify how many numbers were generated since the ++ +C!!! initialization with LUX and INT. The restarting ++ +C!!! skips over K1+K2*E9 numbers, so it can be long.++ +C!!! A more efficient but less convenient way of restarting is by: ++ +C!!! CALL RLUXIN(ISVEC) restarts the generator from vector ++ +C!!! ISVEC of 25 32-bit integers (see RLUXUT) ++ +C!!! CALL RLUXUT(ISVEC) outputs the current values of the 25 ++ +C!!! 32-bit integer seeds, to be used for restarting ++ +C!!! ISVEC must be dimensioned 25 in the calling program ++ +C!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + DIMENSION RVEC(LENV) + DIMENSION SEEDS(24), ISEEDS(24), ISDEXT(25) + PARAMETER (MAXLEV=4, LXDFLT=3) + DIMENSION NDSKIP(0:MAXLEV) + DIMENSION NEXT(24) + PARAMETER (TWOP12=4096., IGIGA=1000000000,JSDFLT=314159265) + PARAMETER (ITWO24=2**24, ICONS=2147483563) + SAVE NOTYET, I24, J24, CARRY, SEEDS, TWOM24, TWOM12, LUXLEV + SAVE NSKIP, NDSKIP, IN24, NEXT, KOUNT, MKOUNT, INSEED + INTEGER LUXLEV + Integer Input_seed,JSDFLT_set + LOGICAL NOTYET + DATA NOTYET, LUXLEV, IN24, KOUNT, MKOUNT /.TRUE., LXDFLT, 0,0,0/ + DATA I24,J24,CARRY/24,10,0./ +CCC Set starting seed value: + If(Input_seed.gt.0) then + JSDFLT_set = Input_seed + Else + JSDFLT_set = JSDFLT + End If +C default +C Luxury Level 0 1 2 *3* 4 + DATA NDSKIP/0, 24, 73, 199, 365 / +Corresponds to p=24 48 97 223 389 +C time factor 1 2 3 6 10 on slow workstation +C 1 1.5 2 3 5 on fast mainframe +C +C NOTYET is .TRUE. if no initialization has been performed yet. +C Default Initialization by Multiplicative Congruential + IF (NOTYET) THEN + NOTYET = .FALSE. + JSEED = JSDFLT_set + INSEED = JSEED + WRITE(6,'(A,I12)') ' RANLUX DEFAULT INITIALIZATION: ',JSEED + LUXLEV = LXDFLT + NSKIP = NDSKIP(LUXLEV) + LP = NSKIP + 24 + IN24 = 0 + KOUNT = 0 + MKOUNT = 0 + WRITE(6,'(A,I2,A,I4)') ' RANLUX DEFAULT LUXURY LEVEL = ', + + LUXLEV,' p =',LP + TWOM24 = 1. + DO 25 I= 1, 24 + TWOM24 = TWOM24 * 0.5 + K = JSEED/53668 + JSEED = 40014*(JSEED-K*53668) -K*12211 + IF (JSEED .LT. 0) JSEED = JSEED+ICONS + ISEEDS(I) = MOD(JSEED,ITWO24) + 25 CONTINUE + TWOM12 = TWOM24 * 4096. + DO 50 I= 1,24 + SEEDS(I) = REAL(ISEEDS(I))*TWOM24 + NEXT(I) = I-1 + 50 CONTINUE + NEXT(1) = 24 + I24 = 24 + J24 = 10 + CARRY = 0. + IF (SEEDS(24) .EQ. 0.) CARRY = TWOM24 + ENDIF +C +C The Generator proper: "Subtract-with-borrow", +C as proposed by Marsaglia and Zaman, +C Florida State University, March, 1989 +C + DO 100 IVEC= 1, LENV + UNI = SEEDS(J24) - SEEDS(I24) - CARRY + IF (UNI .LT. 0.) THEN + UNI = UNI + 1.0 + CARRY = TWOM24 + ELSE + CARRY = 0. + ENDIF + SEEDS(I24) = UNI + I24 = NEXT(I24) + J24 = NEXT(J24) + RVEC(IVEC) = UNI +C small numbers (with less than 12 "significant" bits) are "padded". + IF (UNI .LT. TWOM12) THEN + RVEC(IVEC) = RVEC(IVEC) + TWOM24*SEEDS(J24) +C and zero is forbidden in case someone takes a logarithm + IF (RVEC(IVEC) .EQ. 0.) RVEC(IVEC) = TWOM24*TWOM24 + ENDIF +C Skipping to luxury. As proposed by Martin Luscher. + IN24 = IN24 + 1 + IF (IN24 .EQ. 24) THEN + IN24 = 0 + KOUNT = KOUNT + NSKIP + DO 90 ISK= 1, NSKIP + UNI = SEEDS(J24) - SEEDS(I24) - CARRY + IF (UNI .LT. 0.) THEN + UNI = UNI + 1.0 + CARRY = TWOM24 + ELSE + CARRY = 0. + ENDIF + SEEDS(I24) = UNI + I24 = NEXT(I24) + J24 = NEXT(J24) + 90 CONTINUE + ENDIF + 100 CONTINUE + KOUNT = KOUNT + LENV + IF (KOUNT .GE. IGIGA) THEN + MKOUNT = MKOUNT + 1 + KOUNT = KOUNT - IGIGA + ENDIF + RETURN +C +C Entry to input and float integer seeds from previous run + ENTRY RLUXIN(ISDEXT) + NOTYET = .FALSE. + TWOM24 = 1. + DO 195 I= 1, 24 + NEXT(I) = I-1 + 195 TWOM24 = TWOM24 * 0.5 + NEXT(1) = 24 + TWOM12 = TWOM24 * 4096. + WRITE(6,'(A)') ' FULL INITIALIZATION OF RANLUX WITH 25 INTEGERS:' + WRITE(6,'(5X,5I12)') ISDEXT + DO 200 I= 1, 24 + SEEDS(I) = REAL(ISDEXT(I))*TWOM24 + 200 CONTINUE + CARRY = 0. + IF (ISDEXT(25) .LT. 0) CARRY = TWOM24 + ISD = IABS(ISDEXT(25)) + I24 = MOD(ISD,100) + ISD = ISD/100 + J24 = MOD(ISD,100) + ISD = ISD/100 + IN24 = MOD(ISD,100) + ISD = ISD/100 + LUXLEV = ISD + IF (LUXLEV .LE. MAXLEV) THEN + NSKIP = NDSKIP(LUXLEV) + WRITE (6,'(A,I2)') ' RANLUX LUXURY LEVEL SET BY RLUXIN TO: ', + + LUXLEV + ELSE IF (LUXLEV .GE. 24) THEN + NSKIP = LUXLEV - 24 + WRITE (6,'(A,I5)') ' RANLUX P-VALUE SET BY RLUXIN TO:',LUXLEV + ELSE + NSKIP = NDSKIP(MAXLEV) + WRITE (6,'(A,I5)') ' RANLUX ILLEGAL LUXURY RLUXIN: ',LUXLEV + LUXLEV = MAXLEV + ENDIF + INSEED = -1 + RETURN +C +C Entry to ouput seeds as integers + ENTRY RLUXUT(ISDEXT) + DO 300 I= 1, 24 + ISDEXT(I) = INT(SEEDS(I)*TWOP12*TWOP12) + 300 CONTINUE + ISDEXT(25) = I24 + 100*J24 + 10000*IN24 + 1000000*LUXLEV + IF (CARRY .GT. 0.) ISDEXT(25) = -ISDEXT(25) + RETURN +C +C Entry to output the "convenient" restart point + ENTRY RLUXAT(LOUT,INOUT,K1,K2) + LOUT = LUXLEV + INOUT = INSEED + K1 = KOUNT + K2 = MKOUNT + RETURN +C +C Entry to initialize from one or three integers + ENTRY RLUXGO(LUX,INS,K1,K2) + IF (LUX .LT. 0) THEN + LUXLEV = LXDFLT + ELSE IF (LUX .LE. MAXLEV) THEN + LUXLEV = LUX + ELSE IF (LUX .LT. 24 .OR. LUX .GT. 2000) THEN + LUXLEV = MAXLEV + WRITE (6,'(A,I7)') ' RANLUX ILLEGAL LUXURY RLUXGO: ',LUX + ELSE + LUXLEV = LUX + DO 310 ILX= 0, MAXLEV + IF (LUX .EQ. NDSKIP(ILX)+24) LUXLEV = ILX + 310 CONTINUE + ENDIF + IF (LUXLEV .LE. MAXLEV) THEN + NSKIP = NDSKIP(LUXLEV) + WRITE(6,'(A,I2,A,I4)') ' RANLUX LUXURY LEVEL SET BY RLUXGO :', + + LUXLEV,' P=', NSKIP+24 + ELSE + NSKIP = LUXLEV - 24 + WRITE (6,'(A,I5)') ' RANLUX P-VALUE SET BY RLUXGO TO:',LUXLEV + ENDIF + IN24 = 0 + IF (INS .LT. 0) WRITE (6,'(A)') + + ' Illegal initialization by RLUXGO, negative input seed' + IF (INS .GT. 0) THEN + JSEED = INS + WRITE(6,'(A,3I12)') ' RANLUX INITIALIZED BY RLUXGO FROM SEEDS', + + JSEED, K1,K2 + ELSE + JSEED = JSDFLT_set + WRITE(6,'(A)')' RANLUX INITIALIZED BY RLUXGO FROM DEFAULT SEED' + ENDIF + INSEED = JSEED + NOTYET = .FALSE. + TWOM24 = 1. + DO 325 I= 1, 24 + TWOM24 = TWOM24 * 0.5 + K = JSEED/53668 + JSEED = 40014*(JSEED-K*53668) -K*12211 + IF (JSEED .LT. 0) JSEED = JSEED+ICONS + ISEEDS(I) = MOD(JSEED,ITWO24) + 325 CONTINUE + TWOM12 = TWOM24 * 4096. + DO 350 I= 1,24 + SEEDS(I) = REAL(ISEEDS(I))*TWOM24 + NEXT(I) = I-1 + 350 CONTINUE + NEXT(1) = 24 + I24 = 24 + J24 = 10 + CARRY = 0. + IF (SEEDS(24) .EQ. 0.) CARRY = TWOM24 +C If restarting at a break point, skip K1 + IGIGA*K2 +C Note that this is the number of numbers delivered to +C the user PLUS the number skipped (if luxury .GT. 0). + KOUNT = K1 + MKOUNT = K2 + IF (K1+K2 .NE. 0) THEN + DO 500 IOUTER= 1, K2+1 + INNER = IGIGA + IF (IOUTER .EQ. K2+1) INNER = K1 + DO 450 ISK= 1, INNER + UNI = SEEDS(J24) - SEEDS(I24) - CARRY + IF (UNI .LT. 0.) THEN + UNI = UNI + 1.0 + CARRY = TWOM24 + ELSE + CARRY = 0. + ENDIF + SEEDS(I24) = UNI + I24 = NEXT(I24) + J24 = NEXT(J24) + 450 CONTINUE + 500 CONTINUE +C Get the right value of IN24 by direct calculation + IN24 = MOD(KOUNT, NSKIP+24) + IF (MKOUNT .GT. 0) THEN + IZIP = MOD(IGIGA, NSKIP+24) + IZIP2 = MKOUNT*IZIP + IN24 + IN24 = MOD(IZIP2, NSKIP+24) + ENDIF +C Now IN24 had better be between zero and 23 inclusive + IF (IN24 .GT. 23) THEN + WRITE (6,'(A/A,3I11,A,I5)') + + ' Error in RESTARTING with RLUXGO:',' The values', INS, + + K1, K2, ' cannot occur at luxury level', LUXLEV + IN24 = 0 + ENDIF + ENDIF + RETURN + END -- 2.39.3